~ chicken-core (chicken-5) 8214de96adaae257620c1cca968af78965aff590
commit 8214de96adaae257620c1cca968af78965aff590
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Oct 21 12:03:46 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Nov 13 11:41:48 2016 +0100
overhauled egg-file validation
diff --git a/egg-information.scm b/egg-information.scm
index 98c1ce53..6988a4d8 100644
--- a/egg-information.scm
+++ b/egg-information.scm
@@ -1,52 +1,73 @@
;;; loading and accessing egg-information
-(define toplevel-items
- '(synopsis authors category license version dependencies synopsis
- test-dependencies build-dependencies components foreign-dependencies
- platform doc-from-wiki installed-files))
-
-(define valid-items
- (append toplevel-items
- '(synopsis authors category license version dependencies files
- source-file csc-options test-dependencies destination linkage
- build-dependencies components foreign-dependencies link-options
- custom-bulild target host platform doc-from-wiki extension
- program data)))
-
-(define nested-items
- '(components target host extension program data))
-
-(define named-items
- '(extension program data c-include scheme-include))
+;;; validate egg-information tree
+(define (egg-version? v)
+ (and (list? v)
+ (pair? v)
+ (null? (cdr v))
+ (let ((str (->string (car v))))
+ (irregex-match '(seq (+ numeric) #\. (+ numeric) #\. (+ numeric)) str))))
-;;; validate egg-information tree
+;; ENTRY = (NAME TOPLEVEL? NESTED? NAMED? [VALIDATOR])
+(define egg-info-items
+ `((synopsis #t #f #f)
+ (authors #t #f #f)
+ (author #t #f #f)
+ (category #t #f #f)
+ (license #t #f #f)
+ (version #t #f #f ,egg-version?)
+ (dependencies #t #f #f ,list?)
+ (test-dependencies #t #f #f ,list?)
+ (build-dependencies #t #f #f ,list?)
+ (components #t #f #f)
+ (foreign-dependencies #t #f #f ,list?)
+ (platform #t #f #f)
+ (doc-from-wiki #t #f #f)
+ (installed-files #t #f #f ,list?)
+ (maintainers #t #f #f)
+ (maintainer #t #f #f)
+ (files #f #t #f ,list?)
+ (source-file #f #f #f)
+ (csc-options #f #f #f)
+ (link-options #f #f #f)
+ (custom-build #f #f #f)
+ (target #f #t #f)
+ (host #f #t #f)
+ (extension #f #t #t)
+ (program #f #t #t)
+ (data #f #t #t)
+ (c-include #f #f #t)
+ (scheme-include #f #f #t)))
(define (validate-egg-info info)
- (define (valid-item? item)
- (and (list? item) (pair? item) (symbol? (car item))))
- (define (toplevel-item? item)
- (and (valid-item? item) (memq (car item) toplevel-items)))
- (unless (list? info)
- (error "egg-information has invalid structure" info))
- (unless (every toplevel-item? info)
- (error "egg-information has invalid toplevel structure" info))
- (define (validate info)
+ (define (validate info top?)
(for-each
(lambda (item)
- (unless (valid-item? item)
- (error "egg-information item has invalid structure" item))
- (when (and (memq (car item) named-items) (not (symbol? (cadr item))))
- (error "missing name for item" item))
- (if (memq (car item) nested-items)
- (validate (if (memq (car item) named-items)
- (cddr item)
- (cdr item)))
- (unless (memq (car item) valid-items)
- (error "invalid item" item))))
+ (cond ((or (not (pair? item))
+ (not (list? item))
+ (not (symbol? (car item))))
+ (error "invalid egg information item" item))
+ ((assq (car item) egg-info-items) =>
+ (lambda (a)
+ (apply (lambda (_ toplevel nested named #!optional validator)
+ (when (and top? (not toplevel))
+ (error "egg information item not allowed at toplevel"
+ item))
+ (when (and named
+ (or (null? (cddr item))
+ (not (symbol? (caddr item)))))
+ (error "unnamed egg information item" item))
+ (when (and validator
+ (not (validator (cdr item))))
+ (error "egg information item has invalid structure" item))
+ (when nested
+ (validate (if named (cddr item) (cdr item)) #f)))
+ a)))
+ (else (error "unknown egg information item" item))))
info))
- (validate info)
+ (validate info #t)
info)
Trap