~ chicken-core (chicken-5) 01d34ab52c2b3409d844366b82fdc29f691760fe
commit 01d34ab52c2b3409d844366b82fdc29f691760fe
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Oct 2 19:30:44 2016 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sun Oct 2 19:30:44 2016 +0200
output tweaks in chicken-install, explicit recursive download, some bugfixes, remove programs and shared libraries before overwriting
diff --git a/chicken-install.scm b/chicken-install.scm
index da118d21..686a0df3 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -69,6 +69,7 @@
(define proxy-port #f)
(define proxy-user-pass #f)
(define retrieve-only #f)
+(define retrieve-recursive #f)
(define do-not-build #f)
(define list-versions-only #f)
(define canonical-eggs '())
@@ -80,6 +81,7 @@
(define target-extension cross-chicken)
(define sudo-install #f)
(define update-module-db #f)
+(define purge-mode #f)
(define platform
(if (eq? 'mingw (build-platform))
@@ -142,11 +144,14 @@
(string=? suffix
(substring s (- len-s len-suffix))))))
-(define (d fstr . args)
- (unless quiet
- (let ((port (current-error-port)))
- (apply fprintf port fstr args)
- (flush-output port) ) ))
+(define (d flag . args)
+ (let ((flag (and (not (string? flag)) flag))
+ (fstr (if (string? flag) flag (car args)))
+ (args (if (string? flag) args (cdr args))))
+ (when (or flag (not quiet))
+ (let ((port (current-error-port)))
+ (apply fprintf port fstr args)
+ (flush-output port) ) )))
(define (version>=? v1 v2)
(define (version->list v)
@@ -302,10 +307,12 @@
(create-directory cache-directory))
(cond ((or (not (probe-dir cached))
(not (file-exists? eggfile)))
+ (d "~a not cached~%" name)
(fetch))
((and (file-exists? status)
(not (equal? current-status
(with-input-from-file status read))))
+ (d "status changed for ~a~%" name)
(fetch)))
(let* ((info (load-egg-info eggfile))
(lversion (get-egg-property info 'version)))
@@ -313,6 +320,7 @@
(> (- now (with-input-from-file timestamp read)) +one-hour+)
(not (check-remote-version name version
(and lversion lversion))))
+ (d "version of ~a out of date~%" name)
(fetch)
(let ((info (load-egg-info eggfile))) ; new egg info (fetched)
(values cached (get-egg-property info 'version))))
@@ -397,18 +405,18 @@
(lambda (a)
;; push to front
(set! canonical-eggs (cons a (delete a canonical-eggs eq?)))))
- (else
+ (else
(let ((name (if (pair? egg) (car egg) egg))
(version (override-version egg)))
(let-values (((dir ver) (locate-egg name version)))
(when (or (not dir)
(null? (directory dir)))
(error "extension or version not found"))
- (d " ~a located at ~a~%" egg dir)
+ (d retrieve-only "~a located at ~a~%" egg dir)
(set! canonical-eggs
(cons (list name dir ver) canonical-eggs)))))))
eggs)
- (unless retrieve-only
+ (when (or (not retrieve-only) retrieve-recursive)
(for-each
(lambda (e+d+v)
(unless (member (car e+d+v) checked-eggs)
@@ -597,7 +605,8 @@
(or (and versions
(begin
(printf "~a:" name)
- (for-each (cut printf " ~a" <>) versions)))
+ (for-each (cut printf " ~a" <>) versions)
+ (newline)))
(loop2 (cdr srvs))))))
(loop1 (cdr eggs)))))))
@@ -710,21 +719,41 @@
(file-copy dbfile (make-pathname (repo-path) +module-db+) #t))))
+;; purge cache for given (or all) eggs
+
+(define (purge-cache eggs)
+ (cond ((null? eggs)
+ (d "purging complete cache at ~a~%" cache-directory)
+ (delete-directory cache-directory #t))
+ (else
+ (for-each
+ (lambda (egg)
+ (let* ((name (if (pair? egg) (car egg) egg))
+ (dname (make-pathname cache-directory name)))
+ (when (file-exists? dname)
+ (d "purging ~a from cache at ~a~%" name dname)
+ (delete-directory dname #t))))
+ eggs))))
+
+
;; command line parsing and selection of operations
(define (perform-actions eggs)
(load-defaults)
(cond (update-module-db (update-db))
+ (purge-mode (purge-cache eggs))
((null? eggs)
- (set! canonical-eggs
- (map (lambda (fname)
- (list (pathname-file fname) (current-directory) #f))
- (glob "*.egg")))
- (retrieve-eggs '())
- (unless retrieve-only (install-eggs)))
+ (cond (list-versions-only (print "no eggs specified"))
+ (else
+ (set! canonical-eggs
+ (map (lambda (fname)
+ (list (pathname-file fname) (current-directory) #f))
+ (glob "*.egg")))
+ (retrieve-eggs '())
+ (unless retrieve-only (install-eggs)))))
(else
(let ((eggs (apply-mappings eggs)))
- (cond (list-versions-only (list-egg-versions eggs))
+ (cond (list-versions-only (list-egg-versions eggs)))
;;XXX other actions...
(else
(retrieve-eggs eggs)
@@ -743,9 +772,17 @@
((equal? arg "-test")
(set! run-tests #t)
(loop (cdr args)))
- ((member arg '("-r" "-retrieve"))
+ ((equal? arg "-r")
+ (if retrieve-only
+ (set! retrieve-recursive #t)
+ (set! retrieve-only #t))
+ (loop (cdr args)))
+ ((equal? arg "-retrieve")
(set! retrieve-only #t)
(loop (cdr args)))
+ ((equal? arg "-recursive")
+ (set! retrieve-recursive #t)
+ (loop (cdr args)))
((equal? arg "-list-versions")
(set! list-versions-only #t)
(loop (cdr args)))
@@ -773,6 +810,9 @@
((member arg '("-s" "-sudo"))
(set! sudo-install #t)
(loop (cdr args)))
+ ((equal? arg "-purge")
+ (set! purge-mode #t)
+ (loop (cdr args)))
;;XXX
diff --git a/egg-compile.scm b/egg-compile.scm
index 8e5ebd32..0ae8fdf3 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -48,6 +48,11 @@
((unix) "install -m644")
((windows) "xcopy /y")))
+(define (remove-file-command platform)
+ (case platform
+ ((unix) "rm -f")
+ ((windows) "del /f /q")))
+
(define (uses-compiled-import-library? mode)
(not (and (eq? mode 'host) staticbuild)))
@@ -373,30 +378,24 @@
(print cmd " " out " " ddir (quotearg (slashify (conc dest "/" name ext)
platform)))))
-(define (gen-install-dynamic-extension name #!key platform mode srcdir)
+(define (gen-install-dynamic-extension name #!key platform mode srcdir (ext ".so"))
(let* ((cmd (install-executable-command platform))
+ (dcmd (remove-file-command platform))
(mkdir (mkdir-command platform))
(sname (prefix srcdir name))
- (out (quotearg (target-file (conc sname ".so") mode)))
- (ext (object-extension platform))
+ (out (quotearg (target-file (conc sname ext) mode)))
(dest (destination-repository mode))
(dfile (quotearg (slashify dest platform)))
- (ddir (shell-variable "DESTDIR" platform)))
+ (ddir (shell-variable "DESTDIR" platform))
+ (destf (quotearg (slashify (conc dest "/" name ext) platform))))
(print "\n" mkdir " " ddir dfile)
- (print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" name ".so") platform)))))
+ (when (eq? platform 'unix)
+ (print dcmd " " ddir destf))
+ (print cmd " " out " " ddir destf)))
(define (gen-install-import-library name #!key platform mode srcdir)
- (let* ((cmd (install-executable-command platform))
- (mkdir (mkdir-command platform))
- (sname (prefix srcdir name))
- (out (quotearg (target-file (conc sname ".import.so") mode)))
- (dest (destination-repository mode))
- (dfile (quotearg (slashify dest platform)))
- (ddir (shell-variable "DESTDIR" platform)))
- (print "\n" mkdir " " ddir dfile)
- (print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" name ".import.so") platform)))))
+ (gen-install-dynamic-extension name platform: platform mode: mode srcdir: srcdir
+ ext: ".import.so"))
(define (gen-install-import-library-source name #!key platform mode srcdir)
(let* ((cmd (install-executable-command platform))
@@ -412,16 +411,19 @@
(define (gen-install-program name #!key platform mode srcdir)
(let* ((cmd (install-executable-command platform))
+ (dcmd (remove-file-command platform))
(mkdir (mkdir-command platform))
(ext (executable-extension platform))
(sname (prefix srcdir name))
(out (quotearg (target-file (conc sname ext) mode)))
(dest (if (eq? mode 'target) target-bindir host-bindir))
(dfile (quotearg (slashify dest platform)))
- (ddir (shell-variable "DESTDIR" platform)))
+ (ddir (shell-variable "DESTDIR" platform))
+ (destf (quotearg (slashify (conc dest "/" name ext) platform))))
(print "\n" mkdir " " ddir dfile)
- (print cmd " " out " " ddir
- (quotearg (slashify (conc dest "/" name ext) platform)))))
+ (when (eq? platform 'unix)
+ (print dcmd " " ddir destf))
+ (print cmd " " out " " ddir destf)))
(define (gen-install-data name #!key platform files destination mode srcdir)
(let* ((cmd (install-file-command platform))
@@ -432,10 +434,10 @@
(print "\n" mkdir " " ddir dfile)
(print cmd (arglist (map (cut prefix srcdir <>) files)) " " ddir dfile)))
-(define (gen-install-c-include name #!key platform deps files dest mode srcdir)
+(define (gen-install-c-include name #!key platform deps files destination mode srcdir)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
- (dest (or dest (if (eq? mode 'target) target-incdir host-incdir)))
+ (dest (or destination (if (eq? mode 'target) target-incdir host-incdir)))
(dfile (quotearg (slashify dest platform)))
(ddir (shell-variable "DESTDIR" platform)))
(print "\n" mkdir " " ddir dfile)
Trap