~ chicken-core (chicken-5) fd80ab7e4b7a398f9ee07095448ac302b64f7461
commit fd80ab7e4b7a398f9ee07095448ac302b64f7461
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Dec 10 20:56:04 2016 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Dec 10 20:56:04 2016 +0100
moved egg-info validation into chicken-install
diff --git a/chicken-install.scm b/chicken-install.scm
index 05259d61..6b1a38a5 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -137,6 +137,87 @@
(exit code))
+;;; 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))))
+
+(define (optname? x)
+ (and (list? x) (pair? x)
+ (or (null? (cdr x))
+ (string? (cadr x))
+ (symbol? (cadr x)))))
+
+;; ENTRY = (NAME TOPLEVEL? NESTED? NAMED? [VALIDATOR])
+(define egg-info-items
+ `((synopsis #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?)
+ (maintainer #t #f #f)
+ (files #f #t #f ,list?)
+ (source #f #f #f)
+ (csc-options #f #f #f)
+ (link-options #f #f #f)
+ (custom-build #f #f #f)
+ (linkage #f #f #f)
+ (target #f #t #f)
+ (host #f #t #f)
+ (types-file #f #f ,optname?)
+ (inline-file #f #f ,optname?)
+ (extension #f #t #t)
+ (generated-source-file #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 (validate info top?)
+ (for-each
+ (lambda (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 #t)
+ info)
+
+
;; utilities
;; Simpler replacement for SRFI-13's string-suffix?
@@ -318,7 +399,7 @@
(with-input-from-file status read))))
(d "status changed for ~a~%" name)
(fetch #f)))
- (let* ((info (load-egg-info eggfile))
+ (let* ((info (validate-egg-info (load-egg-info eggfile)))
(vfile (make-pathname cached +version-file+))
(lversion (or (get-egg-property info 'version)
(and (file-exists? vfile)
@@ -332,7 +413,7 @@
(not (check-remote-version name version lversion)))
(d "version of ~a out of date~%" name)
(fetch #t)
- (let* ((info (load-egg-info eggfile)) ; new egg info (fetched)
+ (let* ((info (validate-egg-info (load-egg-info eggfile))) ; new egg info (fetched)
(lversion (or (get-egg-property info 'version)
(and (file-exists? vfile)
(with-input-from-file vfile read)))))
@@ -378,7 +459,7 @@
((probe-dir (make-pathname (car locs) name))
=> (lambda (dir)
(let* ((eggfile (make-pathname dir name +egg-extension+))
- (info (load-egg-info eggfile))
+ (info (validate-egg-info (load-egg-info eggfile)))
(rversion (get-egg-property info 'version)))
(if (or (not rversion)
(version>=? rversion version))
@@ -436,7 +517,7 @@
(d "checking ~a ...~%" (car e+d+v))
(set! checked-eggs (cons (car e+d+v) checked-eggs))
(let* ((fname (make-pathname (cadr e+d+v) (car e+d+v) +egg-extension+))
- (info (load-egg-info fname)))
+ (info (validate-egg-info (load-egg-info fname))))
(d "checking platform for `~a'~%" (car e+d+v))
(check-platform (car e+d+v) info)
(d "checking dependencies for `~a'~%" (car e+d+v))
@@ -538,7 +619,7 @@
((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
(sf (make-pathname (repo-path) ep +egg-info-extension+)))
(and (file-exists? sf)
- (load-egg-info sf #f))) =>
+ (load-egg-info sf))) =>
(lambda (info)
(let ((a (assq 'version info)))
(if a
@@ -633,7 +714,7 @@
(let* ((name (car egg))
(dir (cadr egg))
(eggfile (make-pathname dir name +egg-extension+))
- (info (load-egg-info eggfile #f)))
+ (info (load-egg-info eggfile)))
(when (or host-extension
(and (not target-extension)
(not host-extension)))
diff --git a/egg-information.scm b/egg-information.scm
index daaba3bd..ae9f0b3d 100644
--- a/egg-information.scm
+++ b/egg-information.scm
@@ -1,98 +1,13 @@
;;; loading and accessing egg-information
-;;; 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))))
-
-(define (optname? x)
- (and (list? x) (pair? x)
- (or (null? (cdr x))
- (string? (cadr x))
- (symbol? (cadr x)))))
-
-;; ENTRY = (NAME TOPLEVEL? NESTED? NAMED? [VALIDATOR])
-(define egg-info-items
- `((synopsis #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?)
- (maintainer #t #f #f)
- (files #f #t #f ,list?)
- (source #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)
- (types-file #f #f ,optname?)
- (inline-file #f #f ,optname?)
- (extension #f #t #t)
- (generated-source-file #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 (validate info top?)
- (for-each
- (lambda (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 #t)
- info)
-
-
;;; load egg-info from file and perform validation
-(define (load-egg-info fname #!optional (validate #t))
- (with-input-from-file fname
- (lambda ()
- (let ((info (read)))
- (if validate
- (validate-egg-info info)
- info)))))
+(define (load-egg-info fname)
+ (with-input-from-file fname read))
-;;; lookup specific entries in egg-information
+;;; lookup specific toplevel properties of egg-information
(define (get-egg-property info prop #!optional default)
(let ((p (assq prop info)))
@@ -101,3 +16,41 @@
(define (get-egg-property* info prop #!optional (default '()))
(let ((p (assq prop info)))
(or (and p (cdr p)) default)))
+
+
+;;; lookup specific properties for specific extensions
+
+(define (get-extension-property/internal info ext prop get default host)
+ (define (find-prop exp)
+ (and (not (null? exp))
+ (case (caar exp)
+ ((target)
+ (or (and (not host) (find-prop (cdar exp)))
+ (find-prop (cdr exp))))
+ ((host)
+ (or (and host (find-prop (cdar exp)))
+ (find-prop (cdr exp))))
+ (else (if (eq? prop (caar exp))
+ (car exp)
+ (find-prop (cdr exp)))))))
+ (or (let walk ((p (cdr (assq 'components info))))
+ (and (not (null? p))
+ (case (caar p)
+ ((target)
+ (or (and (not host) (walk (cdar p)))
+ (walk (cdr p))))
+ ((host)
+ (or (and host (walk (cdar p)))
+ (walk (cdr p))))
+ ((extension)
+ (and (eq? ext (cadar p))
+ (let ((p (find-prop (caddr p))))
+ (and p (get p)))))
+ (else (walk (cdr p))))))
+ default))
+
+(define (get-extension-property info ext prop #!optional default host)
+ (get-extension-property/internal info ext prop cadr default host))
+
+(define (get-extension-property* info ext prop #!optional default host)
+ (get-extension-property/internal info ext prop cdr default host))
Trap