diff options
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/cargo.scm | 1 | ||||
-rw-r--r-- | guix/build-system/copy.scm | 4 | ||||
-rw-r--r-- | guix/build-system/dune.scm | 1 | ||||
-rw-r--r-- | guix/build-system/font.scm | 1 | ||||
-rw-r--r-- | guix/build-system/guile.scm | 2 | ||||
-rw-r--r-- | guix/build-system/meson.scm | 1 | ||||
-rw-r--r-- | guix/build-system/ocaml.scm | 1 | ||||
-rw-r--r-- | guix/build-system/ruby.scm | 1 | ||||
-rw-r--r-- | guix/build-system/scons.scm | 1 | ||||
-rw-r--r-- | guix/build-system/texlive.scm | 1 | ||||
-rw-r--r-- | guix/build-system/waf.scm | 1 | ||||
-rw-r--r-- | guix/build/debug-link.scm | 12 | ||||
-rw-r--r-- | guix/build/dune-build-system.scm | 4 | ||||
-rw-r--r-- | guix/channels.scm | 6 | ||||
-rw-r--r-- | guix/download.scm | 8 | ||||
-rw-r--r-- | guix/import/opam.scm | 4 | ||||
-rw-r--r-- | guix/inferior.scm | 70 | ||||
-rw-r--r-- | guix/platform.scm | 55 | ||||
-rw-r--r-- | guix/scripts/container/exec.scm | 10 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 11 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 14 | ||||
-rw-r--r-- | guix/scripts/repl.scm | 14 | ||||
-rw-r--r-- | guix/transformations.scm | 91 | ||||
-rw-r--r-- | guix/ui.scm | 3 |
24 files changed, 229 insertions, 88 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 60c35eed07..912400a191 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -123,6 +123,7 @@ to NAME and VERSION." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define (package-cargo-inputs p) diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index 4894ba46fb..6efc2b2766 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2023 Jonathan Brielmaier <jonathan.brielmaier@web.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -94,6 +95,7 @@ %standard-phases)) (system (%current-system)) (target #f) + (substitutable? #t) (imported-modules %copy-build-system-modules) (modules '((guix build copy-build-system) (guix build utils)))) @@ -129,6 +131,8 @@ (gexp->derivation name builder #:system system #:target #f + #:substitutable? substitutable? + #:graft? #f #:guile-for-build guile))) (define copy-build-system diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 12100fd8e8..3f81d21441 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -157,6 +157,7 @@ provides a 'setup.ml' file as its build system." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define dune-build-system diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index 74dc80b5db..a99f76c66b 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -112,6 +112,7 @@ (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile))) (define font-build-system diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 36a88e181a..ffc892260a 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -114,6 +114,7 @@ (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile))) (define* (guile-cross-build name @@ -170,6 +171,7 @@ (gexp->derivation name builder #:system system #:target target + #:graft? #f #:guile-for-build guile))) (define guile-build-system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index 9fee6c4570..b0bf8cb6e6 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -55,6 +55,7 @@ for TRIPLET." ((target-x86-64? triplet) "x86_64") ((target-arm32? triplet) "arm") ((target-aarch64? triplet) "aarch64") + ((target-mips64el? triplet) "mips64") ((target-powerpc? triplet) (if (target-64bit? triplet) "ppc64" diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index b08985cd4d..921c1f8629 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -310,6 +310,7 @@ provides a 'setup.ml' file as its build system." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define ocaml-build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 342daf7978..0aa273b4f4 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -114,6 +114,7 @@ NAME and VERSION." (gexp->derivation name build #:system system #:target #f + #:graft? #f #:modules imported-modules #:guile-for-build guile))) diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index 7a02fa8a0f..9af24d40f8 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -121,6 +121,7 @@ provides a 'SConstruct' file as its build system." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define scons-build-system diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index dbb72cd24a..336e192d83 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -182,6 +182,7 @@ level package ID." (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:substitutable? substitutable? #:guile-for-build guile))) diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index e8cd5520b8..1d520050f6 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -111,6 +111,7 @@ as its build system." (gexp->derivation name build #:system system #:target #f + #:graft? #f #:modules imported-modules #:guile-for-build guile))) diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm index f3284f74c4..80941df2fc 100644 --- a/guix/build/debug-link.scm +++ b/guix/build/debug-link.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -175,7 +175,15 @@ directories." outputs)) (append-map (lambda (directory) - (filter elf-file? + (filter (lambda (file) + (catch 'system-error + (lambda () + (elf-file? file)) + (lambda args + ;; FILE might be a dangling symlink. + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) (with-error-to-port (%make-void-port "w") (lambda () (find-files directory))))) diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index e9ccc71057..f311cd37f1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -42,13 +42,13 @@ build-flags))) #t) -(define* (check #:key (test-flags '()) (test-target "test") tests? +(define* (check #:key (test-flags '()) tests? (jbuild? #f) (package #f) (dune-release-flags '()) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target + (apply invoke program "runtest" (append (if package (list "-p" package) dune-release-flags) test-flags)))) diff --git a/guix/channels.scm b/guix/channels.scm index d84228c47e..40cbc4bb3a 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> @@ -1057,7 +1057,9 @@ true, include its introduction, if any." (name ',(channel-name channel)) (url ,(channel-url channel)) (branch ,(channel-branch channel)) - (commit ,(channel-commit channel)) + ,@(if (channel-commit channel) + `((commit ,(channel-commit channel))) + '()) ,@(if intro `((introduction (make-channel-introduction ,(channel-introduction-first-signed-commit intro) diff --git a/guix/download.scm b/guix/download.scm index 2e9ecb43fc..fff54d7a17 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -112,22 +112,16 @@ (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/ "http://downloads.sourceforge.net/project/" "http://ufpr.dl.sourceforge.net/project/" - "http://heanet.dl.sourceforge.net/project/" "http://freefr.dl.sourceforge.net/project/" "http://internode.dl.sourceforge.net/project/" "http://jaist.dl.sourceforge.net/project/" - "http://kent.dl.sourceforge.net/project/" "http://liquidtelecom.dl.sourceforge.net/project/" ;; "http://nbtelecom.dl.sourceforge.net/project/" ;never returns 404s "http://nchc.dl.sourceforge.net/project/" - "http://ncu.dl.sourceforge.net/project/" "http://netcologne.dl.sourceforge.net/project/" "http://netix.dl.sourceforge.net/project/" "http://pilotfiber.dl.sourceforge.net/project/" - "http://superb-sea2.dl.sourceforge.net/project/" - "http://tenet.dl.sourceforge.net/project/" - "http://vorboss.dl.sourceforge.net/project/" - "http://netassist.dl.sourceforge.net/project/") + "http://tenet.dl.sourceforge.net/project/") (netfilter.org ; https://www.netfilter.org/mirrors.html "http://ftp.netfilter.org/pub/" "ftp://ftp.es.netfilter.org/mirrors/netfilter/" diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 29b2b886bf..938a88f69d 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -382,8 +382,8 @@ or #f on failure." ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(beautify-description - (metadata-ref opam-content "description"))) + (description ,(and=> (metadata-ref opam-content "description") + beautify-description)) (license ,(spdx-string->license (metadata-ref opam-content "license")))) (filter diff --git a/guix/inferior.scm b/guix/inferior.scm index defdcc4e48..5dfd30a6c8 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -149,33 +149,47 @@ custom binary port)." ;; the REPL process wouldn't get EOF on standard input. (match (socketpair AF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0) ((parent . child) - (match (primitive-fork) - (0 - (dynamic-wind - (lambda () - #t) - (lambda () - (close-port parent) - (close-fdes 0) - (close-fdes 1) - (close-fdes 2) - (dup2 (fileno child) 0) - (dup2 (fileno child) 1) - ;; Mimic 'open-pipe*'. - (if (file-port? (current-error-port)) - (let ((error-port-fileno - (fileno (current-error-port)))) - (unless (eq? error-port-fileno 2) - (dup2 error-port-fileno - 2))) - (dup2 (open-fdes "/dev/null" O_WRONLY) - 2)) - (apply execlp command command args)) - (lambda () - (primitive-_exit 127)))) - (pid - (close-port child) - (values parent pid)))))) + (if (defined? 'spawn) + (let* ((void (open-fdes "/dev/null" O_WRONLY)) + (pid (catch 'system-error + (lambda () + (spawn command (cons command args) + #:input child + #:output child + #:error (if (file-port? (current-error-port)) + (current-error-port) + void))) + (const #f)))) ;can't exec, for instance ENOENT + (close-fdes void) + (close-port child) + (values parent pid)) + (match (primitive-fork) ;Guile < 3.0.9 + (0 + (dynamic-wind + (lambda () + #t) + (lambda () + (close-port parent) + (close-fdes 0) + (close-fdes 1) + (close-fdes 2) + (dup2 (fileno child) 0) + (dup2 (fileno child) 1) + ;; Mimic 'open-pipe*'. + (if (file-port? (current-error-port)) + (let ((error-port-fileno + (fileno (current-error-port)))) + (unless (eq? error-port-fileno 2) + (dup2 error-port-fileno + 2))) + (dup2 (open-fdes "/dev/null" O_WRONLY) + 2)) + (apply execlp command command args)) + (lambda () + (primitive-_exit 127)))) + (pid + (close-port child) + (values parent pid))))))) (define* (inferior-pipe directory command error-port) "Return two values: an input/output pipe on the Guix instance in DIRECTORY diff --git a/guix/platform.scm b/guix/platform.scm index f873913fe0..a2d95ab507 100644 --- a/guix/platform.scm +++ b/guix/platform.scm @@ -22,6 +22,8 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (platform platform? platform-target @@ -29,6 +31,10 @@ platform-linux-architecture platform-glibc-dynamic-linker + &platform-not-found-error + platform-not-found-error? + false-if-platform-not-found + platform-modules platforms lookup-platform-by-system @@ -72,6 +78,20 @@ ;;; +;;; Exceptions. +;;; +(define-condition-type &platform-not-found-error &error + platform-not-found-error? + (target-or-system platform-not-found-error-target-or-system)) + +(define-syntax-rule (false-if-platform-not-found exp) + "Evaluate EXP but return #f if it raises a platform-not-found-error? +exception." + (guard (ex ((platform-not-found-error? ex) #f)) + exp)) + + +;;; ;;; Platforms. ;;; @@ -94,23 +114,32 @@ (platform-modules))))) (define (lookup-platform-by-system system) - "Return the platform corresponding to the given SYSTEM." - (find (lambda (platform) - (let ((s (platform-system platform))) - (and (string? s) (string=? s system)))) - (platforms))) + "Return the platform corresponding to the given SYSTEM. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (find (lambda (platform) + (let ((s (platform-system platform))) + (and (string? s) (string=? s system)))) + (platforms)) + (raise-exception (condition (&platform-not-found-error + (target-or-system system)))))) (define (lookup-platform-by-target target) - "Return the platform corresponding to the given TARGET." - (find (lambda (platform) - (let ((t (platform-target platform))) - (and (string? t) (string=? t target)))) - (platforms))) + "Return the platform corresponding to the given TARGET. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (find (lambda (platform) + (let ((t (platform-target platform))) + (and (string? t) (string=? t target)))) + (platforms)) + (raise-exception (condition (&platform-not-found-error + (target-or-system target)))))) (define (lookup-platform-by-target-or-system target-or-system) - "Return the platform corresponding to the given TARGET or SYSTEM." - (or (lookup-platform-by-target target-or-system) - (lookup-platform-by-system target-or-system))) + "Return the platform corresponding to the given TARGET or SYSTEM. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (false-if-platform-not-found (lookup-platform-by-target target-or-system)) + (false-if-platform-not-found (lookup-platform-by-system target-or-system)) + (raise-exception (condition (&platform-not-found-error + (target-or-system target-or-system)))))) (define (platform-system->target system) "Return the target matching the given SYSTEM if it exists or false diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index 51b616b384..3e70b1d3c2 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -102,4 +102,12 @@ and the other containing arguments for the command to be executed." environment) (apply execlp program program program-args))))))) (unless (zero? result) - (leave (G_ "exec failed with status ~d~%") result))))))) + (match (status:exit-val result) + (#f + (if (status:term-sig result) + (leave (G_ "process terminated with signal ~a~%") + (status:term-sig result)) + (leave (G_ "process stopped with signal ~a~%") + (status:stop-sig result)))) + (code + (leave (G_ "process exited with status ~d~%") code))))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index c7fd8fd340..46435ae48e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,8 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> -;;; Copyright © 2022 John Kehayias <john.kehayias@protonmail.com> +;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -475,10 +475,13 @@ cache." (catch 'system-error (lambda () (when emulate-fhs? - ;; When running in a container with EMULATE-FHS?, override $PATH + ;; When running in a container with EMULATE-FHS?, augment $PATH ;; (optional, but to better match FHS expectations), and generate ;; /etc/ld.so.cache. - (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin") + (setenv "PATH" (string-append "/bin:/usr/bin:/sbin:/usr/sbin" + (if (getenv "PATH") + (string-append ":" (getenv "PATH")) + ""))) (invoke "ldconfig" "-X")) (apply execlp program program args)) (lambda _ diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f102180c9..6847dd1962 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -569,6 +569,12 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (category packaging) (synopsis "view and query package dependency graphs") + (define (shorter? str1 str2) + (< (string-length str1) (string-length str2))) + + (define length-sorted + (cut sort <> shorter?)) + (with-error-handling (define opts (parse-command-line args %options @@ -598,13 +604,17 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (run-with-store store ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) + (mlet %store-monad ((_g (set-grafting #f)) (nodes (mapm %store-monad (node-type-convert type) (reverse items)))) (if (assoc-ref opts 'path?) + ;; Sort by string length such that, in case of multiple + ;; outputs, the shortest one (which corresponds to "out") is + ;; picked (yup, a hack). (match nodes - (((node1 _ ...) (node2 _ ...)) + (((= length-sorted (node1 _ ...)) + (= length-sorted (node2 _ ...))) (display-path node1 node2 type)) (_ (leave (G_ "'--path' option requires exactly two \ diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 50d18c7760..787c63d48e 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -52,12 +52,19 @@ (option '(#\t "type") #t #f (lambda (opt name arg result) (alist-cons 'type (string->symbol arg) result))) + (option '("list-types") #f #f + (lambda (opt name arg result) + (display (string-join '("guile" "machine") "\n" 'suffix)) + (exit 0))) (option '("listen") #t #f (lambda (opt name arg result) (alist-cons 'listen arg result))) (option '(#\q) #f #f (lambda (opt name arg result) (alist-cons 'ignore-dot-guile? #t result))) + (option '(#\i "interactive") #f #f + (lambda (opt name arg result) + (alist-cons 'interactive? #t result))) (option '(#\L "load-path") #t #f (lambda (opt name arg result) ;; XXX: Imperatively modify the search paths. @@ -71,6 +78,8 @@ In the Guix execution environment, run FILE as a Guile script with command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) (display (G_ " + --list-types display REPL types and exit")) + (display (G_ " -t, --type=TYPE start a REPL of the given TYPE")) (display (G_ " --listen=ENDPOINT listen to ENDPOINT instead of standard input")) @@ -78,6 +87,9 @@ command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) -q inhibit loading of ~/.guile")) (newline) (display (G_ " + -i, --interactive launch REPL after evaluating FILE")) + (newline) + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (newline) (display (G_ " @@ -190,7 +202,7 @@ call THUNK." ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".". (load-in-vicinity (getcwd) (car script))))) - (when (null? script) + (when (or (null? script) (assoc-ref opts 'interactive?)) ;; Start REPL (let ((type (assoc-ref opts 'type))) (call-with-connection (assoc-ref opts 'listen) diff --git a/guix/transformations.scm b/guix/transformations.scm index bf9639020b..8ff472ad21 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -757,35 +757,72 @@ additional patches." (rewrite obj) obj))) +(define* (package-with-upstream-version p #:optional version) + "Return package P changed to use the given upstream VERSION or, if VERSION +is #f, the latest known upstream version." + (let ((source (package-latest-release p #:version version))) + (cond ((not source) + (if version + (warning + (G_ "could not find version ~a of '~a' upstream~%") + version (package-name p)) + (warning + (G_ "could not determine latest upstream release of '~a'~%") + (package-name p))) + p) + ((string=? (upstream-source-version source) + (package-version p)) + (unless version + (info (G_ "~a is already the latest version of '~a'~%") + (package-version p) (package-name p))) + p) + (else + (when (version>? (package-version p) + (upstream-source-version source)) + (warning (G_ "using ~a ~a, which is older than the packaged \ +version (~a)~%") + (package-name p) + (upstream-source-version source) + (package-version p))) + + (unless (pair? (upstream-source-signature-urls source)) + (warning (G_ "cannot authenticate source of '~a', version ~a~%") + (package-name p) + (upstream-source-version source))) + + ;; TODO: Take 'upstream-source-input-changes' into account. + (package + (inherit p) + (version (upstream-source-version source)) + (source source)))))) + (define (transform-package-latest specs) "Return a procedure that rewrites package graphs such that those in SPECS are replaced by their latest upstream version." - (define (package-with-latest-upstream p) - (let ((source (package-latest-release p))) - (cond ((not source) - (warning - (G_ "could not determine latest upstream release of '~a'~%") - (package-name p)) - p) - ((string=? (upstream-source-version source) - (package-version p)) - p) - (else - (unless (pair? (upstream-source-signature-urls source)) - (warning (G_ "cannot authenticate source of '~a', version ~a~%") - (package-name p) - (upstream-source-version source))) - - ;; TODO: Take 'upstream-source-input-changes' into account. - (package - (inherit p) - (version (upstream-source-version source)) - (source source)))))) + (define rewrite + (package-input-rewriting/spec + (map (lambda (spec) + (cons spec package-with-upstream-version)) + specs))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + +(define (transform-package-version specs) + "Return a procedure that rewrites package graphs such that those in SPECS +are replaced by the specified upstream version." (define rewrite (package-input-rewriting/spec (map (lambda (spec) - (cons spec package-with-latest-upstream)) + (match (string-tokenize spec %not-equal) + ((spec version) + (cons spec (cut package-with-upstream-version <> version))) + (_ + (raise (formatted-message + (G_ "~a: invalid upstream version specification") + spec))))) specs))) (lambda (obj) @@ -809,7 +846,8 @@ are replaced by their latest upstream version." (with-debug-info . ,transform-package-with-debug-info) (without-tests . ,transform-package-tests) (with-patch . ,transform-package-patches) - (with-latest . ,transform-package-latest))) + (with-latest . ,transform-package-latest) + (with-version . ,transform-package-version))) (define (transformation-procedure key) "Return the transformation procedure associated with KEY, a symbol such as @@ -881,6 +919,8 @@ building for ~a instead of ~a, so tuning cannot be guessed~%") (parser 'with-patch)) (option '("with-latest") #t #f (parser 'with-latest)) + (option '("with-version") #t #f + (parser 'with-version)) (option '("help-transform") #f #f (lambda _ @@ -916,6 +956,9 @@ building for ~a instead of ~a, so tuning cannot be guessed~%") --with-latest=PACKAGE use the latest upstream release of PACKAGE")) (display (G_ " + --with-version=PACKAGE=VERSION + use the given upstream VERSION of PACKAGE")) + (display (G_ " --with-c-toolchain=PACKAGE=TOOLCHAIN build PACKAGE and its dependents with TOOLCHAIN")) (display (G_ " diff --git a/guix/ui.scm b/guix/ui.scm index f26c4534aa..9f81ff3b8e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -591,6 +591,9 @@ FILE." (set! execlp (error-reporting-wrapper execlp (filename . args) filename)) +(set! mkdir + (error-reporting-wrapper mkdir (directory . args) directory)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error nicely." |