~ chicken-core (chicken-5) 70a3d2d0073ce046a87a6518c924fe3138531ee0
commit 70a3d2d0073ce046a87a6518c924fe3138531ee0
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Sep 7 14:30:06 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Sep 7 14:30:06 2016 +0200
egg tools build
diff --git a/NOTES b/NOTES
index 67b09948..16493a89 100644
--- a/NOTES
+++ b/NOTES
@@ -144,3 +144,4 @@ env LD_LIBRARY_PATH=/home/felix/chicken/chicken-5-new-egg-install ../chicken-ins
chicken-install.scm setup-api.scm
new-install.scm egg-compile.scm egg-environment.scm egg-download.scm
gg setup-info
+
diff --git a/chicken-install.scm b/chicken-install.scm
index 4e4d425b..8af98e9c 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -53,6 +53,7 @@
(include "mini-srfi-1.scm")
(include "egg-environment.scm")
+(include "egg-information.scm")
(include "egg-compile.scm")
(include "egg-download.scm")
@@ -434,7 +435,7 @@
#;(for-each
(lambda (e)
(d "removing previously installed extension `~a'" e)
- (remove-extension e) ) ; - not implemented yet
+ (remove-extension e) )
ueggs)
(retrieve-eggs ueggs) ) ) ) ) ) )
canonical-eggs)))
@@ -618,8 +619,8 @@
(generate-shell-commands platform install iscript dir
(install-prefix 'host name info)
(install-suffix 'host name info))
- (run-script dir bscript platform)
- (run-script dir iscript platform))))
+ (run-script dir bscript platform #f)
+ (run-script dir iscript platform sudo-install))))
(when target-extension
(let-values (((build install info) (compile-egg-info info platform 'target)))
(let ((bscript (make-pathname dir name
@@ -634,7 +635,7 @@
(install-prefix 'target name info)
(install-suffix 'target name info))
(run-script dir bscript platform #f)
- (run-script dir iscript platform sudo-install))))))
+ (run-script dir iscript platform #f))))))
canonical-eggs))
(define (run-script dir script platform sudo?)
diff --git a/chicken-status.scm b/chicken-status.scm
index 98c95560..490289b0 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -1,6 +1,6 @@
;;;; chicken-status.scm
;
-; Copyright (c) 2008-2015, The CHICKEN Team
+; Copyright (c) 2008-2016, The CHICKEN Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -25,64 +25,44 @@
(module main ()
- (import scheme chicken)
- (import setup-api)
- (import chicken.data-structures
- chicken.files
- chicken.foreign
- chicken.format
- chicken.irregex
- chicken.ports
- chicken.posix
- chicken.pretty-print)
+ (import (scheme))
+ (import (chicken))
+ (import (chicken data-structures)
+ (chicken files)
+ (chicken foreign)
+ (chicken format)
+ (chicken irregex)
+ (chicken ports)
+ (chicken posix)
+ (chicken pretty-print))
(include "mini-srfi-1.scm")
+ (include "egg-environment.scm")
+ (include "egg-information.scm")
- (define-foreign-variable C_TARGET_LIB_HOME c-string)
- (define-foreign-variable C_BINARY_VERSION int)
- (define-foreign-variable C_TARGET_PREFIX c-string)
-
- (define *cross-chicken* (feature? #:cross-chicken))
- (define *host-extensions* *cross-chicken*)
- (define *target-extensions* *cross-chicken*)
- (define *prefix* #f)
- (define *deploy* #f)
+ (define host-extensions #t)
+ (define target-extensions #t)
(define (repo-path)
- (if *deploy*
- *prefix*
- (if (and *cross-chicken* (not *host-extensions*))
- (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
- (if *prefix*
- (make-pathname
- *prefix*
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
- (repository-path)))))
+ (destination-repository
+ (if (and cross-chicken (not host-extensions))
+ 'target
+ 'host)))
(define (grep rx lst)
(filter (cut irregex-search rx <>) lst))
- (define (gather-extensions patterns)
- (let* ((extensions (gather-all-extensions))
- (pats (concatenate (map (cut grep <> extensions) patterns))))
+ (define (read-info egg)
+ (load-egg-info (make-pathname (repo-path) egg #f)))
+
+ (define (filter-eggs patterns)
+ (let* ((eggs (gather-eggs))
+ (pats (concatenate (map (cut grep <> eggs) patterns))))
(delete-duplicates pats)))
- (define (gather-eggs patterns)
- (define (egg-name extension)
- (and-let* ((egg (assq 'egg-name (read-info extension (repo-path)))))
- (cadr egg)))
- (let loop ((eggs '())
- (extensions (gather-extensions patterns)))
- (if (null? extensions)
- eggs
- (let ((egg (egg-name (car extensions))))
- (loop (if (and egg (not (member egg eggs)))
- (cons egg eggs)
- eggs)
- (cdr extensions))))))
-
- (define (gather-all-extensions)
- (map pathname-file (glob (make-pathname (repo-path) "*" "setup-info"))))
+ (define (gather-eggs)
+ (map pathname-file
+ (glob (make-pathname (repo-path) "*" +egg-info-extension+))))
(define (format-string str cols #!optional right (padc #\space))
(let* ((len (string-length str))
@@ -102,42 +82,84 @@
(min default-width w)))
default-width)))))
- (define (list-installed-extensions extensions)
+ (define (list-installed-eggs eggs)
(let ((w (quotient (- (get-terminal-width) 2) 2)))
(for-each
- (lambda (extension)
- (let ((version (assq 'version (read-info extension (repo-path)))))
+ (lambda (egg)
+ (let ((version (get-egg-property (read-info egg) 'version)))
(if version
(print
- (format-string (string-append extension " ") w #f #\.)
+ (format-string (string-append egg " ") w #f #\.)
(format-string
(string-append " version: " (->string (cadr version)))
w #t #\.))
- (print extension))))
- (sort extensions string<?))))
-
- (define (list-installed-eggs eggs)
- (for-each print eggs))
-
- (define (list-installed-files extensions)
+ (print egg))))
+ (sort eggs string<?))))
+
+ (define (gather-components lst mode)
+ (append-map (cut gather-components-rec <> mode) lst))
+
+ (define (gather-components-rec info mode)
+ (case (car info)
+ ((host)
+ (if host-extensions
+ (gather-components (cdr info) 'host)
+ '()))
+ ((target)
+ (if target-extensions
+ (gather-components (cdr info) 'target)
+ '()))
+ ((extension) (list (list 'extension mode (cadr info))))
+ ((data) (list (list 'data mode (cadr info))))
+ ((c-include) (list (list 'c-include mode (cadr info))))
+ ((scheme-include) (list (list 'scheme-include mode (cadr info))))
+ ((program) (list (list 'program mode (cadr info))))))
+
+ (define (list-installed-components eggs)
+ (let ((w (quotient (- (get-terminal-width) 2) 2)))
+ (for-each
+ (lambda (egg)
+ (let* ((info (read-info egg))
+ (version (get-egg-property info 'version))
+ (comps (get-egg-property info 'components)))
+ (if version
+ (print (format-string (string-append egg " ") w #f #\.)
+ (format-string (string-append " version: "
+ (->string (cadr version)))
+ w #t #\.))
+ (print egg))
+ (when comps
+ (let ((lst (gather-components eggs #f)))
+ (for-each
+ (lambda (comp)
+ (print " " (format-string (->string (car comp)) 32)
+ " " (format-string (->string (cadr comp)) 32)
+ (case (caddr comp)
+ ((host) " (host)")
+ ((target) " (target)")
+ (else ""))))
+ lst)))))
+ eggs)))
+
+ (define (list-installed-files eggs)
(for-each
print
(sort
(append-map
- (lambda (extension)
- (let ((files (assq 'files (read-info extension (repo-path)))))
+ (lambda (egg)
+ (let ((files (get-egg-property (read-info egg) 'installed-files)))
(if files
(cdr files)
'())))
- extensions)
+ eggs)
string<?)))
(define (dump-installed-versions)
(for-each
- (lambda (extension)
- (let ((version (assq 'version (read-info extension (repo-path)))))
- (pp (list (string->symbol extension) (->string (and version (cadr version)))))))
- (gather-all-extensions)))
+ (lambda (egg)
+ (let ((version (get-egg-property (read-info egg) 'version)))
+ (pp (list (string->symbol egg) (->string (and version (cadr version)))))))
+ (gather-eggs)))
(define (usage code)
(print #<<EOF
@@ -149,81 +171,52 @@ usage: chicken-status [OPTION | PATTERN] ...
-exact treat PATTERN as exact match (not a pattern)
-host when cross-compiling, show status of host extensions only
-target when cross-compiling, show status of target extensions only
- -p -prefix PREFIX change installation prefix to PREFIX
- -deploy prefix is a deployment directory
-list dump installed extensions and their versions in "override" format
- -e -eggs list installed eggs
+ -c -components list installed components
EOF
);|
(exit code))
- (define *short-options* '(#\h #\f #\p))
+ (define short-options '(#\h #\f #\c))
(define (main args)
(let ((files #f)
- (eggs #f)
- (dump #f)
- (exact #f))
+ (comps #f)
+ (dump #f)
+ (exact #f))
(let loop ((args args) (pats '()))
- (if (null? args)
- (cond
- ((and eggs (or dump files))
- (with-output-to-port (current-error-port)
- (cut print "-eggs cannot be used with -list."))
- (exit 1))
- ((and *deploy* (not *prefix*))
- (with-output-to-port (current-error-port)
- (cut print "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
- (exit 1))
- (else
- (let ((status
- (lambda ()
- (let* ((patterns
- (map
- irregex
- (cond ((null? pats) '(".*"))
- (exact (map (lambda (p)
- (string-append "^" (irregex-quote p) "$"))
- pats))
- (else (map ##sys#glob->regexp pats)))))
- (eggs/exts ((if eggs gather-eggs gather-extensions) patterns)))
- (if (null? eggs/exts)
- (display "(none)\n" (current-error-port))
- ((cond (eggs list-installed-eggs)
- (files list-installed-files)
- (else list-installed-extensions))
- eggs/exts))))))
- (cond (dump (dump-installed-versions))
- ((and *host-extensions* *target-extensions*)
- (print "host at " (repo-path) ":\n")
- (status)
- (fluid-let ((*host-extensions* #f))
- (print "\ntarget at " (repo-path) ":\n")
- (status)))
- (else (status))))))
- (let ((arg (car args)))
- (cond ((or (string=? arg "-help")
- (string=? arg "-h")
- (string=? arg "--help"))
- (usage 0))
+ (if (null? args)
+ (cond ((and comps (or dump files))
+ (with-output-to-port (current-error-port)
+ (cut print "-components cannot be used with -list."))
+ (exit 1))
+ (dump (dump-installed-versions))
+ (else
+ (let* ((patterns
+ (map irregex
+ (cond ((null? pats) '(".*"))
+ (exact (map (lambda (p)
+ (string-append "^"
+ (irregex-quote p)
+ "$"))
+ pats))
+ (else (map ##sys#glob->regexp pats)))))
+ (eggs (filter-eggs patterns)))
+ (if (null? eggs)
+ (display "(none)\n" (current-error-port))
+ ((cond (comps list-installed-components)
+ (files list-installed-files)
+ (else list-installed-eggs))
+ eggs)))))
+ (let ((arg (car args)))
+ (cond ((member arg '("-help" "-h" "--help"))
+ (usage 0))
((string=? arg "-host")
- (set! *target-extensions* #f)
+ (set! target-extensions #f)
(loop (cdr args) pats))
((string=? arg "-target")
- (set! *host-extensions* #f)
- (loop (cdr args) pats))
- ((string=? "-deploy" arg)
- (set! *deploy* #t)
+ (set! host-extensions #f)
(loop (cdr args) pats))
- ((or (string=? arg "-p") (string=? arg "-prefix"))
- (unless (pair? (cdr args)) (usage 1))
- (set! *prefix*
- (let ((p (cadr args)))
- (if (absolute-pathname? p)
- p
- (normalize-pathname
- (make-pathname (current-directory) p) ) ) ) )
- (loop (cddr args) pats))
((string=? arg "-exact")
(set! exact #t)
(loop (cdr args) pats))
@@ -233,21 +226,22 @@ EOF
((or (string=? arg "-f") (string=? arg "-files"))
(set! files #t)
(loop (cdr args) pats))
- ((or (string=? arg "-e") (string=? arg "-eggs"))
- (set! eggs #t)
+ ((or (string=? arg "-c") (string=? arg "-components"))
+ (set! comps #t)
(loop (cdr args) pats))
((string=? arg "-version")
(print (chicken-version))
(exit 0))
- ((and (positive? (string-length arg))
- (char=? #\- (string-ref arg 0)))
- (if (> (string-length arg) 2)
- (let ((sos (string->list (substring arg 1))))
- (if (every (cut memq <> *short-options*) sos)
- (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
- (usage 1)))
- (usage 1)))
- (else (loop (cdr args) (cons arg pats)))))))))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (every (cut memq <> short-options) sos)
+ (loop (append (map (cut string #\- <>) sos)
+ (cdr args)) pats)
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args) (cons arg pats)))))))))
(main (command-line-arguments))
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 26eaaa01..7850a04b 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -1,6 +1,6 @@
;;;; chicken-uninstall.scm
;
-; Copyright (c) 2008-2015, The CHICKEN Team
+; Copyright (c) 2008-2016, The CHICKEN Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -23,87 +23,107 @@
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
+
(module main ()
- (import scheme chicken)
- (import setup-api)
- (import chicken.data-structures
- chicken.files
- chicken.foreign
- chicken.format
- chicken.irregex
- chicken.ports
- chicken.posix)
-
- (include "mini-srfi-1.scm")
-
- (define-foreign-variable C_TARGET_LIB_HOME c-string)
- (define-foreign-variable C_BINARY_VERSION int)
-
- (define *cross-chicken* (feature? #:cross-chicken))
- (define *host-extensions* *cross-chicken*)
- (define *target-extensions* *cross-chicken*)
- (define *prefix* #f)
- (define *deploy* #f)
-
- (define (repo-path)
- (if *deploy*
- *prefix*
- (if (and *cross-chicken* (not *host-extensions*))
- (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
- (if *prefix*
- (make-pathname
- *prefix*
- (sprintf "lib/chicken/~a" (##sys#fudge 42)))
- (repository-path)))))
-
- (define *force* #f)
-
- (define (grep rx lst)
- (filter (cut irregex-search rx <>) lst))
-
- (define (gather-eggs patterns)
- (let* ((eggs (map pathname-file
- (glob (make-pathname (repo-path) "*" "setup-info"))))
- (pats (concatenate (map (cut grep <> eggs) patterns))))
- (delete-duplicates pats)))
-
- (define (fini code)
- (print "aborted.")
- (exit code))
-
- (define (ask eggs)
- (handle-exceptions ex
- (if (eq? ex 'aborted)
- (fini 1)
- (signal ex))
- (yes-or-no?
- (string-intersperse
- (append
- '("About to delete the following extensions:\n\n")
- (map (cut string-append " " <> "\n") eggs)
- '("\nDo you want to proceed?"))
- "")
- default: "no"
- abort: (abort-setup))))
-
- (define (uninstall pats)
- (let ((eggs (gather-eggs pats)))
- (cond ((null? eggs)
- (print "nothing to remove.") )
- ((or *force* (ask eggs))
- (for-each
- (lambda (e)
- (print "removing " e)
- (cond ((and *host-extensions* *target-extensions*)
- (remove-extension e)
- (fluid-let ((*host-extensions* #f))
- (remove-extension e (repo-path)) ))
- (else (remove-extension e (repo-path)))))
- eggs)))))
-
- (define (usage code)
- (print #<<EOF
+ (import (scheme)
+ (chicken))
+ (import (chicken data-structures)
+ (chicken files)
+ (chicken foreign)
+ (chicken io)
+ (chicken format)
+ (chicken irregex)
+ (chicken ports)
+ (chicken posix))
+
+(include "mini-srfi-1.scm")
+(include "egg-environment.scm")
+(include "egg-information.scm")
+
+(define host-extensions #t)
+(define target-extensions #t)
+(define force-uninstall #f)
+(define sudo-uninstall #f)
+
+(define (repo-path)
+ (destination-repository
+ (if (and cross-chicken (not host-extensions))
+ 'target
+ 'host)))
+
+(define (grep rx lst)
+ (filter (cut irregex-search rx <>) lst))
+
+(define (gather-eggs patterns)
+ (let* ((eggs (map pathname-file
+ (glob (make-pathname (repo-path) "*" +egg-info-extension+))))
+ (pats (concatenate (map (cut grep <> eggs) patterns))))
+ (delete-duplicates pats)))
+
+(define (fini code)
+ (print "aborted.")
+ (exit code))
+
+(define (ask eggs)
+ (print (string-intersperse
+ (append '("About to delete the following extensions:\n\n")
+ (map (cut string-append " " <> "\n") eggs)
+ '("\nDo you want to proceed ? (no/yes)"))
+ ""))
+ (flush-output)
+ (let loop ()
+ (let ((r (trim (read-line))))
+ (cond ((string=? r "yes"))
+ ((string=? r "no") (fini 1))
+ (else (loop))))))
+
+(define (trim str)
+ (define (left lst)
+ (cond ((null? lst) '())
+ ((char-whitespace? (car lst)) (left (cdr lst)))
+ (else (cons (car lst) (left (cdr lst))))))
+ (list->string (reverse (left (reverse (left (string->list str)))))))
+
+(define (remove-extension egg #!optional (repo (repo-path)))
+ (and-let* ((files (get-egg-property (load-egg-info egg) 'installed-files)))
+ (for-each
+ (lambda (f)
+ (let ((p (if (absolute-pathname? f) f (make-pathname repo f))))
+ (when (file-exists? p) (delete-installed-file p))))
+ (cdr files)))
+ (delete-installed-file (make-pathname repo egg +egg-info-extension+)))
+
+(define (delete-file-command platform)
+ (case platform
+ ((unix) "rm -f ")
+ ((windows) "del /q /s ")))
+
+(define (delete-installed-file fname)
+ (cond ((not (file-exists? fname))
+ (warning "file does not exist" fname))
+ ((and sudo-uninstall (eq? 'unix default-platform))
+ (let ((r (system (string-append "sudo " (delete-file-command 'unix)
+ "\"" fname "\""))))
+ (unless (zero? r)
+ (warning "deleting file failed" fname))))
+ (else (delete-file fname))))
+
+(define (uninstall pats)
+ (let ((eggs (gather-eggs pats)))
+ (cond ((null? eggs)
+ (print "nothing to remove.") )
+ ((or force-uninstall (ask eggs))
+ (for-each
+ (lambda (e)
+ (print "removing " e)
+ (when host-extensions (remove-extension e))
+ (when (and cross-chicken target-extensions)
+ (remove-extension e (destination-repository 'target))))
+ eggs)))))
+
+(define (usage code)
+ (print #<<EOF
usage: chicken-uninstall [OPTION | PATTERN] ...
-h -help show this message and exit
@@ -111,80 +131,62 @@ usage: chicken-uninstall [OPTION | PATTERN] ...
-force don't ask, delete whatever matches
-exact treat PATTERN as exact match (not a pattern)
-s -sudo use external command to elevate privileges for deleting files
- -p -prefix PREFIX change installation prefix to PREFIX
- -deploy prefix is a deployment directory
-host when cross-compiling, uninstall host extensions only
-target when cross-compiling, uninstall target extensions only
EOF
-);| (sic)
- (exit code))
-
- (define *short-options* '(#\h #\s #\p))
-
- (define (main args)
- (let ((exact #f))
- (let loop ((args args) (pats '()))
- (cond ((null? args)
- (when (null? pats) (usage 1))
- (when (and *deploy* (not *prefix*))
- (with-output-to-port (current-error-port)
- (cut print "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
- (exit 1))
- (uninstall
- (reverse
- (map
- (lambda (p)
- (if exact
- (irregex (string-append "^" (irregex-quote p) "$"))
- (##sys#glob->regexp p)))
- pats))))
- (else
- (let ((arg (car args)))
- (cond ((or (string=? arg "-help")
- (string=? arg "-h")
- (string=? arg "--help"))
- (usage 0))
- ((string=? arg "-version")
- (print (chicken-version))
- (exit 0))
- ((string=? arg "-target")
- (set! *host-extensions* #f)
- (loop (cdr args) pats))
- ((string=? arg "-host")
- (set! *target-extensions* #f)
- (loop (cdr args) pats))
- ((string=? arg "-force")
- (set! *force* #t)
- (loop (cdr args) pats))
- ((string=? arg "-exact")
- (set! exact #t)
- (loop (cdr args) pats))
- ((or (string=? arg "-s") (string=? arg "-sudo"))
- (sudo-install #t)
- (loop (cdr args) pats))
- ((string=? "-deploy" arg)
- (set! *deploy* #t)
- (loop (cdr args) pats))
- ((or (string=? arg "-p") (string=? arg "-prefix"))
- (unless (pair? (cdr args)) (usage 1))
- (set! *prefix*
- (let ((p (cadr args)))
- (if (absolute-pathname? p)
- p
- (normalize-pathname
- (make-pathname (current-directory) p) ) ) ) )
- (loop (cddr args) pats))
- ((and (positive? (string-length arg))
- (char=? #\- (string-ref arg 0)))
- (if (> (string-length arg) 2)
- (let ((sos (string->list (substring arg 1))))
- (if (every (cut memq <> *short-options*) sos)
- (loop
- (append (map (cut string #\- <>) sos) (cdr args)) pats)
- (usage 1)))
- (usage 1)))
- (else (loop (cdr args) (cons arg pats))))))))))
-
- (main (command-line-arguments))
+)
+ (exit code))
+
+(define short-options '(#\h #\s #\p))
+
+(define (main args)
+ (let ((exact #f))
+ (let loop ((args args) (pats '()))
+ (cond ((null? args)
+ (when (null? pats) (usage 1))
+ (uninstall
+ (reverse
+ (map
+ (lambda (p)
+ (if exact
+ (irregex (string-append "^" (irregex-quote p) "$"))
+ (##sys#glob->regexp p)))
+ pats))))
+ (else
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((string=? arg "-version")
+ (print (chicken-version))
+ (exit 0))
+ ((string=? arg "-target")
+ (set! host-extensions #f)
+ (loop (cdr args) pats))
+ ((string=? arg "-host")
+ (set! target-extensions #f)
+ (loop (cdr args) pats))
+ ((string=? arg "-force")
+ (set! force-uninstall #t)
+ (loop (cdr args) pats))
+ ((string=? arg "-exact")
+ (set! exact #t)
+ (loop (cdr args) pats))
+ ((or (string=? arg "-s") (string=? arg "-sudo"))
+ (set! sudo-uninstall #t)
+ (loop (cdr args) pats))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (every (cut memq <> short-options) sos)
+ (loop (append (map (cut string #\- <>) sos)
+ (cdr args)) pats)
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args) (cons arg pats))))))))))
+
+(main (command-line-arguments))
- )
+)
diff --git a/distribution/manifest b/distribution/manifest
index 0768fe88..7349d12e 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -310,6 +310,7 @@ setup.defaults
egg-environment.scm
egg-download.scm
egg-compile.scm
+egg-information.scm
chicken-do.c
chicken-status.1
chicken-install.1
diff --git a/egg-compile.scm b/egg-compile.scm
index 69c6273a..4e06df9e 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -1,19 +1,6 @@
;;;; egg-info processing and compilation
-(define valid-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))
-
(define default-extension-options '())
(define default-program-options '())
(define default-static-program-link-options '())
@@ -29,45 +16,6 @@
(define +windows-object-extension+ ".obj")
-;;; validate egg-information tree
-
-(define (validate-egg-info info)
- (unless (list? info)
- (error "egg-information has invalid structure"))
- (for-each
- (lambda (item)
- (unless (and (list? item) (pair? item) (symbol? (car 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-egg-info (if (memq (car item) named-items)
- (cddr item)
- (cdr item)))
- (unless (memq (car item) valid-items)
- (error "invalid item" item))))
- info)
- 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)))))
-
-
-;;; lookup specific entries in egg-information
-
-(define (get-egg-property info prop #!optional default)
- (let ((p (assq prop info)))
- (or (and p (cadr p)) default)))
-
-
;;; some utilities
(define (object-extension platform)
@@ -411,7 +359,7 @@
(sname (prefix srcdir name))
(out (quotearg (target-file (conc sname ext) mode)))
(dest (destination-repository mode))
- (dfile (quotearg dest platform))
+ (dfile (quotearg dest))
(ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
(print cmd " " out " " ddir (quotearg (slashify (conc dest "/" name ext)
diff --git a/egg-information.scm b/egg-information.scm
new file mode 100644
index 00000000..4480a880
--- /dev/null
+++ b/egg-information.scm
@@ -0,0 +1,66 @@
+;;; loading and accessing egg-information
+
+
+(define toplevel-items
+ '(synopsis authors category license version dependencies
+ test-dependencies build-dependencies components foreign-dependencies
+ platform doc-from-wiki))
+
+(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 (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"))
+ (unless (every toplevel-item? info)
+ (error "egg-information is invalid toplevel structure"))
+ (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-egg-info (if (memq (car item) named-items)
+ (cddr item)
+ (cdr item)))
+ (unless (memq (car item) valid-items)
+ (error "invalid item" item))))
+ info)
+ 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)))))
+
+
+;;; lookup specific entries in egg-information
+
+(define (get-egg-property info prop #!optional default)
+ (let ((p (assq prop info)))
+ (or (and p (cadr p)) default)))
diff --git a/rules.make b/rules.make
index 004b2d62..b2e67e0d 100644
--- a/rules.make
+++ b/rules.make
@@ -803,11 +803,11 @@ csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-install.c: $(SRCDIR)chicken-install.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-compile.scm $(SRCDIR)egg-download.scm $(SRCDIR)egg-environment.scm
+chicken-install.c: $(SRCDIR)chicken-install.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-compile.scm $(SRCDIR)egg-download.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm
+chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-status.c: $(SRCDIR)chicken-status.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm
+chicken-status.c: $(SRCDIR)chicken-status.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
csc.c: $(SRCDIR)csc.scm mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
Trap