diff options
| -rw-r--r-- | guix/scripts/archive.scm | 65 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 131 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 27 |
3 files changed, 109 insertions, 114 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 2b4d39c7b8..4f39920fe7 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -371,36 +371,33 @@ output port." (cons line result))))) (with-error-handling - ;; Ask for absolute file names so that .drv file names passed from the - ;; user to 'read-derivation' are absolute when it returns. - (with-fluids ((%file-port-name-canonicalization 'absolute)) - (let ((opts (parse-command-line args %options (list %default-options)))) - (parameterize ((%graft? (assoc-ref opts 'graft?))) - (cond ((assoc-ref opts 'generate-key) - => - generate-key-pair) - ((assoc-ref opts 'authorize) - (authorize-key)) - (else - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-store store - (set-build-options-from-command-line store opts) - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'list) - (list-contents (current-input-port))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%"))))))))))))) + (let ((opts (parse-command-line args %options (list %default-options)))) + (parameterize ((%graft? (assoc-ref opts 'graft?))) + (cond ((assoc-ref opts 'generate-key) + => + generate-key-pair) + ((assoc-ref opts 'authorize) + (authorize-key)) + (else + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'list) + (list-contents (current-input-port))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (G_ "either '--export' or '--import' \ +must be specified~%")))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index bf307d1421..f054fc2bce 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -809,7 +809,11 @@ build---packages, gexps, derivations, and so on." (cond ((derivation-path? spec) (catch 'system-error (lambda () - (list (read-derivation-from-file spec))) + ;; Ask for absolute file names so that .drv file + ;; names passed from the user to 'read-derivation' + ;; are absolute when it returns. + (let ((spec (canonicalize-path spec))) + (list (read-derivation-from-file spec)))) (lambda args ;; Non-existent .drv files can be substituted down ;; the road, so don't error out. @@ -927,67 +931,64 @@ needed." (list %default-options))) (with-error-handling - ;; Ask for absolute file names so that .drv file names passed from the - ;; user to 'read-derivation' are absolute when it returns. - (with-fluids ((%file-port-name-canonicalization 'absolute)) - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - - (parameterize ((current-terminal-columns (terminal-columns))) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - ;; If FILE is a .drv that's not in - ;; store, keep it so that it can be - ;; substituted. - (and (or (not (derivation-path? file)) - (not (file-exists? file))) - file)) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - - (unless (or (assoc-ref opts 'log-file?) - (assoc-ref opts 'derivations-only?)) - (show-what-to-build store drv - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - ;; Pass 'show-build-log' the output file names, not the - ;; derivation file names, because there can be several - ;; derivations leading to the same output. - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation->output-path drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store (append drv items) - mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots))))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + ;; If FILE is a .drv that's not in + ;; store, keep it so that it can be + ;; substituted. + (and (or (not (derivation-path? file)) + (not (file-exists? file))) + file)) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (or (assoc-ref opts 'log-file?) + (assoc-ref opts 'derivations-only?)) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + ;; Pass 'show-build-log' the output file names, not the + ;; derivation file names, because there can be several + ;; derivations leading to the same output. + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation->output-path drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store (append drv items) + mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots)))))))))) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 53f407b2fc..fca1e3777c 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -552,20 +552,17 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (read/eval-package-expression exp))) (_ #f)) opts))) - ;; Ask for absolute file names so that .drv file names passed from the - ;; user to 'read-derivation' are absolute when it returns. - (with-fluids ((%file-port-name-canonicalization 'absolute)) - (run-with-store store - ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) - (nodes (mapm %store-monad - (node-type-convert type) - items))) - (export-graph (concatenate nodes) - (current-output-port) - #:node-type type - #:backend backend)) - #:system (assq-ref opts 'system)))))) + (run-with-store store + ;; XXX: Since grafting can trigger unsolicited builds, disable it. + (mlet %store-monad ((_ (set-grafting #f)) + (nodes (mapm %store-monad + (node-type-convert type) + items))) + (export-graph (concatenate nodes) + (current-output-port) + #:node-type type + #:backend backend)) + #:system (assq-ref opts 'system))))) #t) ;;; graph.scm ends here |