From dfe33b672c765f5e33d931abd2958370453d6266 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sat, 16 Jan 2016 16:03:44 +0100 Subject: [PATCH 1/2] Add -prefix and -deploy support to chicken-{uninstall,status} This can be helpful when managing deployed programs. --- NEWS | 4 +++ chicken-status.scm | 96 +++++++++++++++++++++++++++++++++------------------ chicken-uninstall.scm | 36 ++++++++++++++++--- manual/Extensions | 4 +++ setup-api.scm | 6 +++- 5 files changed, 106 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 6abe42d..a5b6b1c 100644 --- a/NEWS +++ b/NEWS @@ -35,6 +35,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. - Unit "posix": The following posix procedures now work on port objects: file-stat, file-size, file-owner, file-permissions, diff --git a/chicken-status.scm b/chicken-status.scm index a7fc346..71927b7 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 57bedf6..4ac9c27 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 e863185..93ebf06 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 48b1cb1..fd98d6e 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) -- 2.1.4