diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 55 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 140 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 18 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 12 | ||||
| -rw-r--r-- | guix/scripts/refresh.scm | 235 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 18 |
10 files changed, 302 insertions, 230 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fb2f61ce30..950f0f41d8 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) @@ -55,7 +56,11 @@ (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix archive [OPTION]... PACKAGE... @@ -85,6 +90,8 @@ Export/import one or more packages from/to the store.\n")) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) @@ -161,6 +168,11 @@ Export/import one or more packages from/to the store.\n")) (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -239,7 +251,6 @@ build and a list of store files to transfer." resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) - (set-build-options-from-command-line store opts) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) @@ -329,21 +340,23 @@ the input port." ((assoc-ref opts 'authorize) (authorize-key)) (else - (with-store store - (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 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (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 '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 564bdf0ced..5a158799ae 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -450,13 +450,13 @@ options handled by 'set-build-options-from-command-line', and listed in (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) (display (G_ " - --verbosity=LEVEL use the given verbosity LEVEL")) - (display (G_ " --rounds=N build N times in a row to detect non-determinism")) (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (G_ " - -M, --max-jobs=N allow at most N build jobs"))) + -M, --max-jobs=N allow at most N build jobs")) + (display (G_ " + --debug=LEVEL produce debugging output at LEVEL"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -479,7 +479,7 @@ options handled by 'set-build-options-from-command-line', and listed in (assoc-ref opts 'print-extended-build-trace?) #:multiplexed-build-output? (assoc-ref opts 'multiplexed-build-output?) - #:verbosity (assoc-ref opts 'verbosity))) + #:verbosity (assoc-ref opts 'debug))) (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) @@ -553,12 +553,12 @@ options handled by 'set-build-options-from-command-line', and listed in (apply values (alist-cons 'timeout (string->number* arg) result) rest))) - (option '("verbosity") #t #f + (option '("debug") #t #f (lambda (opt name arg result . rest) - (let ((level (string->number arg))) + (let ((level (string->number* arg))) (apply values - (alist-cons 'verbosity level - (alist-delete 'verbosity result)) + (alist-cons 'debug level + (alist-delete 'debug result)) rest)))) (option '(#\c "cores") #t #f (lambda (opt name arg result . rest) @@ -590,7 +590,8 @@ options handled by 'set-build-options-from-command-line', and listed in (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... @@ -619,6 +620,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -q, --quiet do not show the build log")) (display (G_ " --log-file return the log file names for the given derivations")) @@ -694,9 +697,15 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\q "quiet") #f #f (lambda (opt name arg result) - (alist-cons 'quiet? #t result))) + (alist-cons 'verbosity 0 + (alist-delete 'verbosity result)))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) @@ -819,66 +828,59 @@ needed." (parse-command-line args %options (list %default-options))) - (define quiet? - (assoc-ref opts 'quiet?)) - (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-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)) - (current-build-output-port - (if quiet? - (%make-void-port "w") - (build-event-output-port - (build-status-updater print-build-event))))) - (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)) - 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?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name 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 drv 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)) + 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?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name 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 drv 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/environment.scm b/guix/scripts/environment.scm index 86e1eb115f..116b8dcbce 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -158,6 +158,8 @@ COMMAND or an interactive shell in that environment.\n")) --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) @@ -179,7 +181,8 @@ COMMAND or an interactive shell in that environment.\n")) (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either @@ -260,6 +263,11 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -674,7 +682,7 @@ message if any test fails." (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) (define manifest (options/resolve-packages store opts)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9acec48577..0f315a9352 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il> -;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -820,10 +820,11 @@ descriptions maintained upstream." (lambda (uri) (and=> (follow-redirects-to-github uri) (lambda (github-uri) - (emit-warning - package - (format #f (G_ "URL should be '~a'") github-uri) - 'source)))) + (unless (string=? github-uri uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source))))) (origin-uris origin))))) (define (check-derivation package) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 98b06971bd..b19a4ae1b1 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> @@ -553,9 +553,7 @@ please email '~a'~%") "run.c" "-o" result) (delete-file "run.c"))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) - (else _IOLBF))) + (setvbuf (current-output-port) 'line) ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. @@ -600,7 +598,8 @@ please email '~a'~%") (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . 2) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -687,6 +686,11 @@ please email '~a'~%") (alist-cons 'profile-name arg result)) (_ (leave (G_ "~a: unsupported profile name~%") arg))))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -725,6 +729,8 @@ Create a bundle of PACKAGE.\n")) --profile-name=NAME populate /var/guix/profiles/.../NAME")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) (display (G_ " @@ -774,7 +780,7 @@ Create a bundle of PACKAGE.\n")) (with-error-handling (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5743816324..7ff6bfd6d8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -293,7 +293,8 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (define %default-options ;; Alist of default option values. - `((verbosity . 0) + `((verbosity . 1) + (debug . 0) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -346,7 +347,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) (display (G_ " - --verbose produce verbose output")) + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) @@ -472,13 +473,21 @@ kind of search path~%") (values (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)) #f))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result arg-handler) + (let ((level (string->number* arg))) + (values (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + #f)))) (option '("bootstrap") #f #f (lambda (opt name arg result arg-handler) (values (alist-cons 'bootstrap? #t result) #f))) - (option '("verbose") #f #f + (option '("verbose") #f #f ;deprecated (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) + (values (alist-cons 'verbosity 2 + (alist-delete 'verbosity + result)) #f))) (option '("allow-collisions") #f #f (lambda (opt name arg result arg-handler) @@ -907,14 +916,12 @@ processed, #f otherwise." (define opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) - (define verbose? - (assoc-ref opts 'verbose?)) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (with-status-report print-build-event/quiet + (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e7ff44c0d5..6d1914f7c2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -66,7 +66,8 @@ (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... @@ -89,6 +90,8 @@ Download and deploy the latest version of Guix.\n")) (display (G_ " -n, --dry-run show what would be pulled and built")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) @@ -135,6 +138,11 @@ Download and deploy the latest version of Guix.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -510,7 +518,7 @@ Use '~/.config/guix/channels.scm' instead.")) (process-query opts profile)) (else (with-store store - (with-status-report print-build-event + (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 003c915da3..a0de9f6c10 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,11 +1,12 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +42,6 @@ #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) - #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -172,6 +172,79 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) +(define (options->packages opts) + "Return the list of packages requested by OPTS, honoring options like +'--recursive'." + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (define (keep-newest package lst) + ;; If a newer version of PACKAGE is already in LST, return LST; otherwise + ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. + (let ((name (package-name package))) + (match (find (lambda (p) + (string=? (package-name p) name)) + lst) + ((? package? other) + (if (version>? (package-version other) (package-version package)) + lst + (cons package (delq other lst)))) + (_ + (cons package lst))))) + + (define args-packages + ;; Packages explicitly passed as command-line arguments. + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts) + (() ;default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ;user-specified packages + some))) + + (define packages + (match (assoc-ref opts 'manifest) + (#f args-packages) + ((? string? file) (packages-from-manifest file)))) + + (if (assoc-ref opts 'recursive?) + (mlet %store-monad ((edges (node-edges %bag-node-type + (all-packages)))) + (return (node-transitive-edges packages edges))) + (with-monad %store-monad + (return packages)))) + ;;; ;;; Updates. @@ -224,7 +297,7 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball) + (let-values (((version tarball changes) (package-update store package updaters #:key-download key-download)) ((loc) @@ -238,6 +311,26 @@ warn about packages that have no matching updater." (location->string loc) (package-name package) (package-version package) version) + (for-each + (lambda (change) + (format (current-error-port) + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (G_ "~a: consider adding this input: ~a~%")) + (('add 'native) + (G_ "~a: consider adding this native input: ~a~%")) + (('add 'propagated) + (G_ "~a: consider adding this propagated input: ~a~%")) + (('remove 'regular) + (G_ "~a: consider removing this input: ~a~%")) + (('remove 'native) + (G_ "~a: consider removing this native input: ~a~%")) + (('remove 'propagated) + (G_ "~a: consider removing this propagated input: ~a~%"))) + (package-name package) + (upstream-input-change-name change))) + (changes)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) @@ -335,19 +428,6 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (map full-name covering)))) (return #t)))) -(define (refresh-recursive packages) - "Check all of the package inputs of PACKAGES for newer upstream versions." - (mlet %store-monad ((edges (node-edges %bag-node-type - ;; Here we don't want the -boot0 packages. - (fold-packages cons '())))) - (let ((dependent (node-transitive-edges packages edges))) - ;; par-for-each has an undefined return value, so packages which cause - ;; errors can be ignored. - (par-for-each (lambda (package) - (guix-refresh package)) - (map package-name dependent))) - (return #t))) - (define (list-transitive packages) "List all the packages that would cause PACKAGES to be rebuilt if they are changed." ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE @@ -414,40 +494,6 @@ all are dependent packages: ~{~a~^ ~}~%") (lists (concatenate lists)))) - (define (keep-newest package lst) - ;; If a newer version of PACKAGE is already in LST, return LST; otherwise - ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. - (let ((name (package-name package))) - (match (find (lambda (p) - (string=? (package-name p) name)) - lst) - ((? package? other) - (if (version>? (package-version other) (package-version package)) - lst - (cons package (delq other lst)))) - (_ - (cons package lst))))) - - (define core-package? - (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) - (final-inputs (map input->package %final-inputs)) - (core (append final-inputs - (append-map (compose (cut filter-map input->package <>) - package-transitive-inputs) - final-inputs))) - (names (delete-duplicates (map package-name core)))) - (lambda (package) - "Return true if PACKAGE is likely a \"core package\"---i.e., one whose -update would trigger a complete rebuild." - ;; Compare by name because packages in base.scm basically inherit - ;; other packages. So, even if those packages are not core packages - ;; themselves, updating them would also update those who inherit from - ;; them. - ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. - (member (package-name package) names)))) - (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) @@ -458,65 +504,38 @@ update would trigger a complete rebuild." ;; Warn about missing updaters when a package is explicitly given on ;; the command line. - (warn? (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression))) - (args-packages - (match (filter-map (match-lambda - (('argument . spec) - ;; Take either the specified version or the - ;; latest one. - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some))) - (packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file))))) + (warn? (and (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression) + (assoc-ref opts 'manifest)) + (not recursive?)))) (with-error-handling (with-store store (run-with-store store - (cond - (list-dependent? - (list-dependents packages)) - (list-transitive? - (list-transitive packages)) - (recursive? - (refresh-recursive packages)) - (update? - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command))) - (current-keyring - (or (assoc-ref opts 'keyring) - (string-append (config-directory) - "/upstream/trustedkeys.kbx")))) - (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) - (with-monad %store-monad - (return #t)))) - (else - (for-each (cut check-for-package-update <> updaters - #:warn? warn?) - packages) - (with-monad %store-monad + (mlet %store-monad ((packages (options->packages opts))) + (cond + (list-dependent? + (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) + (for-each + (cut update-package store <> updaters + #:key-download key-download + #:warn? warn?) + packages) + (return #t))) + (else + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) + packages) (return #t))))))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 53b1777241..797a76db3f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; @@ -219,7 +219,7 @@ provide." (set! port (guix:open-connection-for-uri uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF))) + (setvbuf port 'none))) (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else @@ -567,7 +567,7 @@ initial connection on which HTTP requests are sent." verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) - (setvbuf p _IOFBF (expt 2 16))) + (setvbuf p 'block (expt 2 16))) ;; Send REQUESTS, up to a certain number, in a row. ;; XXX: Do our own caching to work around inefficiencies when diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6cda3ccbd6..569b826acd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1015,6 +1015,8 @@ Some ACTIONS support additional ARGS.\n")) --full-boot for 'vm', make a full boot sequence")) (display (G_ " --skip-checks skip file system and initrd module safety checks")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -1074,6 +1076,11 @@ Some ACTIONS support additional ARGS.\n")) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -1092,7 +1099,8 @@ Some ACTIONS support additional ARGS.\n")) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . #f) ;default (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -1267,9 +1275,9 @@ argument list and OPTS is the option alist." (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-report (if (memq command '(init reconfigure)) - print-build-event/quiet - print-build-event) + (with-status-verbosity (or (assoc-ref opts 'verbosity) + (if (memq command '(init reconfigure)) + 1 2)) (process-command command args opts)))))) ;;; Local Variables: |