~ chicken-core (chicken-5) ea8b704d09c83e4dfd298d728f8afbb12ce4859b
commit ea8b704d09c83e4dfd298d728f8afbb12ce4859b
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jul 10 22:28:58 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jul 17 14:11:39 2016 +0200
continuing to complete retrieval + version mgmt
diff --git a/NOTES b/NOTES
index 4fe6d73e..7dd2763d 100644
--- a/NOTES
+++ b/NOTES
@@ -6,9 +6,6 @@ NOTES (new install)
** TODO What should the default optimization options be?
- also for compiled import libraries.
- respect DEBUGBUILD?
-** TODO Do validation of egg-info at some stage
-** TODO Ensure destination directories exist
-** TODO Install commands must respect DESTDIR.
* Implement minimal "chicken-install"
** TODO rename new-install.scm later
@@ -21,16 +18,16 @@ NOTES (new install)
*** TODO retrieve egg
- also support recursive retrieve?
*** TODO Comment all toplevel procedures
+*** TODO Add usage information
* TODO repository-path
- allow multiple locations?
- - might be needed anyway, unless components are to be usable only when installed.
- CHICKEN_REPOSITORY
- perhaps: CHICKEN_INSTALL_REPOSITORY (defaults to install-prefix) as
installation target.
* Installation
- - unlink .so's before overwriting them.
+** TODO unlink .so's before overwriting them.
* Issues
** Link-options are passed directly to csc
@@ -41,10 +38,7 @@ NOTES (new install)
** TODO drop "keep-going" mode.
** TODO "-feature" + "-no-feature"
** TODO Hack for OSX SIP?
-** TODO drop csi's -setup-mode
** TODO reinstall, no-install?
-
-* csi
** TODO Drop -setup-mode
* TODO "build-dependencies"
@@ -52,26 +46,14 @@ NOTES (new install)
- or is the intent differently? Ask moritz.
* Download/build directories
-** TODO download into cache dir (".chicken-install.download")
- - in HOME, or PWD?
- - when does it become stale?
- - sjamaan recoommends retrieving current egg-versions every time.
-** TODO build in temp dir (".chicken-install.build")
- - remove if not "-k" and all goes well.
- - use different name (or ".") in case of "-k"?
- - print directories on failure?
** TODO special mode if installing directory from source dir
+** TODO handle egg-files given on command-line
* TODO Add/remove files
- update distribution/manifest
- add: egg-download.scm egg-compile.scm egg-environment.scm
- rm: setup-api.scm setup-download.scm
-* TODO Extract download stuff
-** TODO Drop extension listing
-** TODO Simplify "local" transport
- - no tag or trunk directories.
-
* TODO Check what cmdline options to retain
** TODO Option for explicitly generating Windows/UNIX build/install scripts
- i.e. selecting target platform.
@@ -80,20 +62,13 @@ NOTES (new install)
** setup-info files
*** one for the whole egg (use "components" to find associated parts).
*** TODO Fix "extension-information"
-*** TODO syntax-only extensions
-** TODO setup.defaults
-** TODO Retrieval from local directory
+*** TODO syntax-only extensions
+ - i.e. matchable (is it?)
** TODO Cross-build + cross-chickens
- needs to compile egg info twice (host- + target-mode).
* TODO Drop CHICKEN_PREFIX
-* Drop
-** TODO svn transport
-** TODO deployment
-
-* TODO Remove setup-api/setup-download from repo
-
* Build/install scripts
** TODO fully sh(1) compatible
- http://people.fas.harvard.edu/~lib113/reference/unix/portable_scripting.html
diff --git a/egg-compile.scm b/egg-compile.scm
index e7102ee1..5ed02841 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -5,7 +5,7 @@
'(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))
+ custom-bulild target host platform))
(define nested-items
'(components target host))
@@ -43,7 +43,8 @@
((memq (car item) nested-items)
(validate-egg-info
(if (memq (car item) named-items) (cddr item) (cdr item))))))
- info))
+ info)
+ info)
;;; load egg-info from file and perform validation
diff --git a/new-install.scm b/new-install.scm
index c143c79e..a7469199 100644
--- a/new-install.scm
+++ b/new-install.scm
@@ -44,7 +44,10 @@
(define retrieve-only #f)
(define list-versions-only #f)
(define canonical-eggs '())
+(define dependencies '())
+(define checked-eggs '())
(define run-tests #f)
+(define force-install #f)
(define platform
(if (eq? 'mingw (build-platform))
@@ -52,7 +55,9 @@
'unix))
(define current-status
- (list (get-environment-variable "CSC_OPTIONS"))) ;XXX more?
+ (list (get-environment-variable "CSC_OPTIONS")
+ (get-environment-variable "LD_LIBRARY_PATH")
+ (get-environment-variable "DYLD_LIBRARY_PATH"))) ;XXX more?
(define (probe-dir dir)
(and dir (file-exists? dir) (directory? dir) dir))
@@ -333,9 +338,164 @@
(cons (list name dir ver) canonical-eggs)))))))
eggs)
(unless retrieve-only
- ;;XXX recursive retrieval of dependencies...
- (error "to be implemented"))) ; XXX
+ (for-each
+ (lambda (e+d+v)
+ (unless (member (car e+d+v) checked-eggs)
+ (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)))
+ (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))
+ (let-values (((missing upgrade)
+ (outdated-dependencies (car e+d+v) info)))
+ (set! missing (apply-mappings missing))
+ (set! dependencies
+ (cons (cons (car e+d+v)
+ (map (lambda (mu)
+ (if (pair? mu)
+ (car mu)
+ mu))
+ (append missing upgrade)))
+ dependencies))
+ (when (pair? missing)
+ (print " missing: " (string-intersperse missing ", "))
+ (retrieve-eggs missing))
+ (when (and (pair? upgrade)
+ (or force-install
+ (replace-extension-question e+d+v upgrade)))
+ (let ((ueggs (unzip1 upgrade)))
+ (d " upgrade: ~a~%" (string-intersperse ueggs ", "))
+ ;; XXX think about this...
+ #;(for-each
+ (lambda (e)
+ (d "removing previously installed extension `~a'" e)
+ (remove-extension e) )
+ ueggs)
+ (retrieve-eggs ueggs) ) ) ) ) ) )
+ canonical-eggs)))
+(define (outdated-dependencies egg info)
+ (let ((ds (get-egg-dependencies info)))
+ (for-each
+ (lambda (h) (set! ds (h egg ds)))
+ hacks)
+ (let loop ((deps ds) (missing '()) (upgrade '()))
+ (if (null? deps)
+ (values (reverse missing) (reverse upgrade))
+ (let ((dep (car deps))
+ (rest (cdr deps)))
+ (let-values (((m u) (check-dependency dep)))
+ (loop rest
+ (if m (cons m missing) missing)
+ (if u (cons u upgrade) upgrade))))))))
+
+(define (get-egg-dependencies info)
+ (append (get-egg-property info 'dependencies '())
+ (if run-tests (get-egg-property info 'test-dependencies '()))))
+
+(define (check-dependency dep)
+ (cond ((or (symbol? dep) (string? dep))
+ (values (and (not (ext-version dep)) (->string dep))
+ #f))
+ ((and (list? dep) (eq? 'or (car dep)))
+ (let scan ((ordeps (cdr dep)) (bestm #f) (bestu #f))
+ (if (null? ordeps)
+ (values (cond (bestu #f) ; upgrade overrides new
+ (bestm bestm)
+ (else #f))
+ bestu)
+ (let-values (((m u) (check-dependency (car ordeps))))
+ (if (and (not m) (not u))
+ (values #f #f)
+ (scan (cdr ordeps)
+ (if (and m (not bestm))
+ m
+ bestm)
+ (if (and u (not bestu))
+ u
+ bestu)))))))
+ ((and (list? dep) (= 2 (length dep))
+ (or (string? (car dep)) (symbol? (car dep))))
+ (let ((v (ext-version (car dep))))
+ (cond ((not v)
+ (values (->string (car dep)) #f))
+ ((not (version>=? v (->string (cadr dep))))
+ (cond ((string=? "chicken" (->string (car dep)))
+ (if force-install
+ (values #f #f)
+ (error
+ (string-append
+ "Your CHICKEN version is not recent enough to use this extension - version "
+ (cadr dep)
+ " or newer is required"))))
+ (else
+ (values #f
+ (cons (->string (car dep)) (->string (cadr dep)))))))
+ (else (values #f #f)))))
+ (else
+ (warning "invalid dependency syntax in extension meta information"
+ dep)
+ (values #f #f))))
+
+(define (check-platform name info)
+ (define (fail)
+ (error "extension is not targeted for this system" name))
+ (unless cross-chicken
+ (and-let* ((platform (get-egg-property info 'platform)))
+ (let loop ((p platform))
+ (cond ((symbol? p)
+ (or (feature? p) (fail)))
+ ((not (list? p))
+ (error "invalid `platform' property" name platform))
+ ((and (eq? 'not (car p)) (pair? (cdr p)))
+ (and (not (loop (cadr p))) (fail)))
+ ((eq? 'and (car p))
+ (and (every loop (cdr p)) (fail)))
+ ((eq? 'or (car p))
+ (and (not (any loop (cdr p))) (fail)))
+ (else (error "invalid `platform' property" name platform)))))))
+
+(define (replace-extension-question e+d+v upgrade)
+ (print (string-intersperse
+ (append
+ (list "The following installed extensions are outdated, because `"
+ (car e+d+v)
+ "' requires later versions:\n")
+ (filter-map
+ (lambda (e)
+ (cond ((assq (string->symbol (car e)) override) =>
+ (lambda (a)
+ (unless (equal? (cadr a) (cdr e))
+ (warning
+ (sprintf "version `~a' of extension `~a' overrides required version `~a'"
+ (cadr a) (car a) (cdr e))))
+ #f))
+ (else
+ (conc
+ " " (car e)
+ " (" (let ((v (assq 'version (extension-information (car e)))))
+ (if v (cadr v) "???"))
+ " -> " (cdr e) ")"
+ #\newline) )))
+ upgrade)
+ '("\nDo you want to replace the existing extensions ? (yes/no/abort) "))
+ ""))
+ (flush-output)
+ (let loop ()
+ (let ((r (trim (read-line))))
+ (cond ((string=? r "yes"))
+ ((string=? r "no") #f)
+ ((string=? r "abort") (exit 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)))))))
+
;; list available egg versions
@@ -358,9 +518,9 @@
;; perform installation of retrieved eggs
-(define (install-canonical-eggs)
- ...
- )
+(define (install-eggs)
+ ;; ...
+ #f)
;; command line parsing and selection of operations
@@ -371,14 +531,14 @@
(map (lambda (fname)
(list (pathname-file fname) (current-directory) #f))
(glob "*.egg")))
- (install-canonical-eggs))
+ (install-eggs))
(else
(let ((eggs (apply-mappings eggs)))
(cond (list-versions-only (list-egg-versions eggs))
;;XXX other actions...
(else
(retrieve-eggs eggs)
- (install-canonical-eggs)))))))
+ (install-eggs)))))))
(define (main args)
(setup-proxy (get-environment-variable "http_proxy"))
@@ -402,6 +562,9 @@
((equal? arg "-defaults")
(set! user-defaults (cadr args))
(loop (cddr args)))
+ ((equal? arg "-force")
+ (set! force-install #t)
+ (loop (cdr args)))
;;XXX
Trap