diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 33 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 56 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 24 |
3 files changed, 87 insertions, 26 deletions
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fbd22a9e29..a49bfdbeb8 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -38,21 +38,18 @@ (define %store (make-parameter #f)) -(define (derivations-from-package-expressions exp system source?) - "Eval EXP and return the corresponding derivation path for SYSTEM. +(define (derivations-from-package-expressions str system source?) + "Read/eval STR and return the corresponding derivation path for SYSTEM. When SOURCE? is true, return the derivations of the package sources." - (let ((p (eval exp (current-module)))) - (if (package? p) - (if source? - (let ((source (package-source p)) - (loc (package-location p))) - (if source - (package-source-derivation (%store) source) - (leave (_ "~a: error: package `~a' has no source~%") - (location->string loc) (package-name p)))) - (package-derivation (%store) p system)) - (leave (_ "expression `~s' does not evaluate to a package~%") - exp)))) + (let ((p (read/eval-package-expression str))) + (if source? + (let ((source (package-source p)) + (loc (package-location p))) + (if source + (package-source-derivation (%store) source) + (leave (_ "~a: error: package `~a' has no source~%") + (location->string loc) (package-name p)))) + (package-derivation (%store) p system)))) ;;; @@ -119,9 +116,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (alist-cons 'derivations-only? #t result))) (option '(#\e "expression") #t #f (lambda (opt name arg result) - (alist-cons 'expression - (call-with-input-string arg read) - result))) + (alist-cons 'expression arg result))) (option '(#\K "keep-failed") #f #f (lambda (opt name arg result) (alist-cons 'keep-failed? #t result))) @@ -227,8 +222,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) (let* ((src? (assoc-ref opts 'source?)) (sys (assoc-ref opts 'system)) (drv (filter-map (match-lambda - (('expression . exp) - (derivations-from-package-expressions exp sys + (('expression . str) + (derivations-from-package-expressions str sys src?)) (('argument . (? derivation-path? drv)) drv) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index f2d2e17d4b..12d80fd171 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -20,6 +20,7 @@ #:use-module (guix ui) #:use-module (guix store) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) @@ -48,6 +49,11 @@ Invoke the garbage collector.\n")) --list-live list live paths")) (newline) (display (_ " + --references list the references of PATHS")) + (display (_ " + --referrers list the referrers of PATHS")) + (newline) + (display (_ " -h, --help display this help and exit")) (display (_ " -V, --version display version information and exit")) @@ -125,6 +131,14 @@ interpreted." (option '("list-live") #f #f (lambda (opt name arg result) (alist-cons 'action 'list-live + (alist-delete 'action result)))) + (option '("references") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-references + (alist-delete 'action result)))) + (option '("referrers") #f #f + (lambda (opt name arg result) + (alist-cons 'action 'list-referrers (alist-delete 'action result)))))) @@ -142,9 +156,37 @@ interpreted." (alist-cons 'argument arg result)) %default-options)) + (define (symlink-target file) + (let ((s (false-if-exception (lstat file)))) + (if (and s (eq? 'symlink (stat:type s))) + (symlink-target (readlink file)) + file))) + + (define (store-directory file) + ;; Return the store directory that holds FILE if it's in the store, + ;; otherwise return FILE. + (or (and=> (string-match (string-append "^" (regexp-quote (%store-prefix)) + "/([^/]+)") + file) + (compose (cut string-append (%store-prefix) "/" <>) + (cut match:substring <> 1))) + file)) + (with-error-handling - (let ((opts (parse-options)) - (store (open-connection))) + (let* ((opts (parse-options)) + (store (open-connection)) + (paths (filter-map (match-lambda + (('argument . arg) arg) + (_ #f)) + opts))) + (define (list-relatives relatives) + (for-each (compose (lambda (path) + (for-each (cut simple-format #t "~a~%" <>) + (relatives store path))) + store-directory + symlink-target) + paths)) + (case (assoc-ref opts 'action) ((collect-garbage) (let ((min-freed (assoc-ref opts 'min-freed))) @@ -152,11 +194,11 @@ interpreted." (collect-garbage store min-freed) (collect-garbage store)))) ((delete) - (let ((paths (filter-map (match-lambda - (('argument . arg) arg) - (_ #f)) - opts))) - (delete-paths store paths))) + (delete-paths store paths)) + ((list-references) + (list-relatives references)) + ((list-referrers) + (list-relatives referrers)) ((list-dead) (for-each (cut simple-format #t "~a~%" <>) (dead-paths store))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1f9355ff22..ccca614d88 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -281,6 +281,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (display (_ " -i, --install=PACKAGE install PACKAGE")) (display (_ " + -e, --install-from-expression=EXP + install the package EXP evaluates to")) + (display (_ " -r, --remove=PACKAGE remove PACKAGE")) (display (_ " -u, --upgrade=REGEXP upgrade all the installed packages matching REGEXP")) @@ -325,6 +328,10 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\i "install") #t #f (lambda (opt name arg result) (alist-cons 'install arg result))) + (option '(#\e "install-from-expression") #t #f + (lambda (opt name arg result) + (alist-cons 'install (read/eval-package-expression arg) + result))) (option '(#\r "remove") #t #f (lambda (opt name arg result) (alist-cons 'remove arg result))) @@ -490,6 +497,19 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (delete-duplicates (map input->name+path deps) same?)) + (define (package->tuple p) + (let ((path (package-derivation (%store) p)) + (deps (package-transitive-propagated-inputs p))) + `(,(package-name p) + ,(package-version p) + + ;; When given a package via `-e', install the first of its + ;; outputs (XXX). + ,(car (package-outputs p)) + + ,path + ,(canonicalize-deps deps)))) + ;; First roll back if asked to. (if (and (assoc-ref opts 'roll-back?) (not dry-run?)) (begin @@ -515,6 +535,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (install (append upgrade (filter-map (match-lambda + (('install . (? package? p)) + #f) (('install . (? store-path?)) #f) (('install . package) @@ -530,6 +552,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) install)) (install* (append (filter-map (match-lambda + (('install . (? package? p)) + (package->tuple p)) (('install . (? store-path? path)) (let-values (((name version) (package-name->name+version |