~ chicken-core (chicken-5) c24fcb6f525fa795afeaaf0a94f587518c0ae2e1
commit c24fcb6f525fa795afeaaf0a94f587518c0ae2e1
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 16 16:03:44 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jan 24 11:39:00 2016 +1300
Add -prefix and -deploy support to chicken-{uninstall,status}
This can be helpful when managing deployed programs.
Signed-off-by: Evan Hanson <evhan@foldling.org>
diff --git a/NEWS b/NEWS
index 786c1074..ca5cdb37 100644
--- a/NEWS
+++ b/NEWS
@@ -41,6 +41,10 @@
basic source-level debugging of compiled Scheme code.
- A statistical profiler has been added, enabling sampling-based
runtime profiling of compiled programs.
+ - "chicken-uninstall"
+ - -prefix and -deploy options were added, matching chicken-install.
+ - "chicken-status"
+ - -prefix and -deploy options were added, matching chicken-install.
4.10.1
diff --git a/chicken-status.scm b/chicken-status.scm
index a7fc346a..71927b72 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -35,15 +35,24 @@
(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 (repo-path)
- (if (and *cross-chicken* (not *host-extensions*))
- (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
- (repository-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 (grep rx lst)
(filter (cut irregex-search rx <>) lst))
@@ -136,13 +145,15 @@ 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
EOF
);|
(exit code))
- (define *short-options* '(#\h #\f))
+ (define *short-options* '(#\h #\f #\p))
(define (main args)
(let ((files #f)
@@ -151,36 +162,41 @@ EOF
(exact #f))
(let loop ((args args) (pats '()))
(if (null? args)
- (if (and eggs (or dump files))
- (begin
- (with-output-to-port (current-error-port)
- (cut print "-eggs cannot be used with -list."))
- (exit 1))
- (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)))))
+ (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")
@@ -192,6 +208,18 @@ EOF
((string=? arg "-target")
(set! *host-extensions* #f)
(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))
((string=? arg "-exact")
(set! exact #t)
(loop (cdr args) pats))
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 57bedf6b..4ac9c27b 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -41,11 +41,19 @@
(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 (and *cross-chicken* (not *host-extensions*))
- (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
- (repository-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)
@@ -102,21 +110,27 @@ usage: chicken-uninstall [OPTION | PATTERN] ...
-force don't ask, delete whatever matches
-exact treat PATTERN as exact match (not a pattern)
-s -sudo use sudo(1) 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))
+ (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
+ (reverse
(map
(lambda (p)
(if exact
@@ -147,6 +161,18 @@ EOF
((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)
diff --git a/manual/Extensions b/manual/Extensions
index e8631858..93ebf06a 100644
--- a/manual/Extensions
+++ b/manual/Extensions
@@ -589,6 +589,8 @@ Available options:
; {{-version}} : show version and exit
; {{-force}} : don't ask, delete whatever matches
; {{-s -sudo}} : use {{sudo(1)}} for deleting files
+; {{-p -prefix PREFIX}} : change installation prefix to {{PREFIX}}
+; {{-deploy}} : uninstall extension from the application directory for a deployed application (see [[Deployment]] for more information)
; {{-host}} : when cross-compiling, remove extensions for host system only
; {{-target}} : when cross-compiling, remove extensions for target system only
; {{-exact}} : match extension-name exactly (do not match as pattern)
@@ -600,6 +602,8 @@ Available options:
; {{-f -files}} : list installed files
; {{-host}} : when cross-compiling, show extensions for host system only
; {{-target}} : when cross-compiling, show extensions for target system only
+; {{-p -prefix PREFIX}} : change installation prefix to {{PREFIX}}
+; {{-deploy}} : look for extensions in the application directory for a deployed application (see [[Deployment]] for more information)
; {{-exact}} : match extension-name exactly (do not match as pattern)
; {{-list}} : list installed egg version in format suitable for {{chicken-install -override}}
diff --git a/setup-api.scm b/setup-api.scm
index 48b1cb11..fd98d6e4 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -624,7 +624,11 @@
(define (remove-extension egg #!optional (repo (repository-path)))
(and-let* ((files (assq 'files (read-info egg repo))))
- (for-each remove-file* (cdr files)))
+ (for-each
+ (lambda (f)
+ (let ((p (if (absolute-pathname? f) f (make-pathname repo f))))
+ (remove-file* p)))
+ (cdr files)))
(remove-file* (make-pathname repo egg setup-file-extension)))
(define ($system str)
Trap