~ chicken-core (chicken-5) 24b0ce85ca5cb8881155d4a9834a4b036d1701da
commit 24b0ce85ca5cb8881155d4a9834a4b036d1701da
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Jan 21 21:27:49 2016 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jan 24 11:39:13 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 85e29d63..145b3d31 100644
--- a/NEWS
+++ b/NEWS
@@ -73,6 +73,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 e6f6c727..9b71d44b 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -43,15 +43,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))
@@ -143,13 +152,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)
@@ -158,36 +169,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")
@@ -199,6 +215,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 fbee0f21..7da83e6a 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -50,11 +50,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)
@@ -110,21 +118,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
@@ -155,6 +169,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 55cd1243..37737ca7 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 4c679ba8..b7704168 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -637,7 +637,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