From abc4cb57ca6ae015e916d0218a904b250ec23659 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Sat, 3 Sep 2016 09:04:52 +0200 Subject: guix: ant-build-system: Fix pattern for collecting jar files. The former pattern included the "jar" binary. * guix/build/ant-build-system.scm (generate-classpath): Change pattern. Suggested by: Ricardo Wurmus --- guix/build/ant-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 6dc19ff2db..00a4a46d81 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -83,7 +83,7 @@ INPUTS." (string-join (apply append (map (match-lambda ((_ . dir) - (find-files dir "\\.*jar$"))) + (find-files dir "\\.jar$"))) inputs)) ":")) (define* (unpack #:key source #:allow-other-keys) -- cgit v1.2.3 From 14d5ca2e2e57643b6b4acfb980b18b7474c27e7b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 3 Sep 2016 00:17:27 +0200 Subject: ui: Initialize %FILE-PORT-NAME-CANONICALIZATION to #f. This avoids loads of needless 'stat' calls due to the default 'relative setting and the 'canonicalize-path' calls it leads to. This was especially visible when 'guix substitute' access files in /var/guix/substitute/cache. * guix/ui.scm (run-guix-command): Set %FILE-PORT-NAME-CANONICALIZATION to #f. --- guix/ui.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 906b349845..452d16308e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1187,7 +1187,9 @@ found." (let ((command-main (module-ref module (symbol-append 'guix- command)))) (parameterize ((program-name command)) - (apply command-main args)))) + ;; Disable canonicalization so we don't don't stat unreasonably. + (with-fluids ((%file-port-name-canonicalization #f)) + (apply command-main args))))) (define (run-guix . args) "Run the 'guix' command defined by command line ARGS. -- cgit v1.2.3 From 2ff0da025745dd4ddce45d34c89fdf39190f9104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Sep 2016 23:39:17 +0200 Subject: file-systems: Always use (guix build syscalls). * gnu/build/file-systems.scm: Use (guix build syscalls) unconditionally. Override the 'mount' and 'umount' bindings when (guile) provides them. (MS_RDONLY, MS_NOSUID, MS_NODEV, MS_NOEXEC, MS_REMOUNT) (MS_BIND, MS_MOVE): Remove. * guix/build/syscalls.scm (%libc-errno-pointer): Add 'false-if-exception' around 'dynamic-func'. --- gnu/build/file-systems.scm | 34 ++++++++++++---------------------- guix/build/syscalls.scm | 3 ++- 2 files changed, 14 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index f277cbfa34..f1fccbdf2e 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -19,6 +19,7 @@ (define-module (gnu build file-systems) #:use-module (guix build utils) #:use-module (guix build bournish) + #:use-module (guix build syscalls) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -41,17 +42,16 @@ uuid->string string->uuid - MS_RDONLY - MS_NOSUID - MS_NODEV - MS_NOEXEC - MS_BIND - MS_MOVE bind-mount mount-flags->bit-mask check-file-system - mount-file-system)) + mount-file-system) + #:re-export (mount + umount + MS_BIND + MS_MOVE + MS_RDONLY)) ;;; Commentary: ;;; @@ -61,21 +61,11 @@ ;;; Code: ;; 'mount' is already defined in the statically linked Guile used for initial -;; RAM disks, but in all other cases the (guix build syscalls) module contains -;; the mount binding. -(eval-when (expand load eval) - (unless (defined? 'mount) - (module-use! (current-module) - (resolve-interface '(guix build syscalls))))) - -;; Linux mount flags, from libc's . -(define MS_RDONLY 1) -(define MS_NOSUID 2) -(define MS_NODEV 4) -(define MS_NOEXEC 8) -(define MS_REMOUNT 32) -(define MS_BIND 4096) -(define MS_MOVE 8192) +;; RAM disks, in which case the bindings in (guix build syscalls) do not work +;; (the FFI bindings do not work there). Override them in that case. +(when (module-defined? the-scm-module 'mount) + (set! mount (@ (guile) mount)) + (set! umount (@ (guile) umount))) (define (bind-mount source target) "Bind-mount SOURCE at TARGET." diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index c663899160..e5315ed6f3 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -283,7 +283,8 @@ given TYPES. READ uses WRAP-FIELDS to return its value." (define %libc-errno-pointer ;; Glibc's 'errno' pointer. - (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link)))) + (let ((errno-loc (false-if-exception + (dynamic-func "__errno_location" (dynamic-link))))) (and errno-loc (let ((proc (pointer->procedure '* errno-loc '()))) (proc))))) -- cgit v1.2.3 From 7ca87354db53fd1e1a7a3dfeddb9a598ea064bbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Sep 2016 23:41:53 +0200 Subject: Add (guix modules). * guix/modules.scm, tests/modules.scm: New files. * Makefile.am (MODULES, SCM_TESTS): Add them. * doc/guix.texi (G-Expressions): Add an example of 'source-module-closure'. --- Makefile.am | 2 + doc/guix.texi | 22 ++++++++ guix/modules.scm | 155 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/modules.scm | 45 ++++++++++++++++ 4 files changed, 224 insertions(+) create mode 100644 guix/modules.scm create mode 100644 tests/modules.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 165dfe9727..1a34e0d5ca 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,6 +41,7 @@ MODULES = \ guix/combinators.scm \ guix/utils.scm \ guix/sets.scm \ + guix/modules.scm \ guix/download.scm \ guix/git-download.scm \ guix/hg-download.scm \ @@ -222,6 +223,7 @@ SCM_TESTS = \ tests/pk-crypto.scm \ tests/pki.scm \ tests/sets.scm \ + tests/modules.scm \ tests/gnu-maintenance.scm \ tests/substitute.scm \ tests/builders.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index d6c041862d..b6ca34a2f3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3825,6 +3825,28 @@ In this example, the @code{(guix build utils)} module is automatically pulled into the isolated build environment of our gexp, such that @code{(use-modules (guix build utils))} works as expected. +@cindex module closure +@findex source-module-closure +Usually you want the @emph{closure} of the module to be imported---i.e., +the module itself and all the modules it depends on---rather than just +the module; failing to do that, attempts to use the module will fail +because of missing dependent modules. The @code{source-module-closure} +procedure computes the closure of a module by looking at its source file +headers, which comes in handy in this case: + +@example +(use-modules (guix modules)) ;for 'source-module-closure' + +(with-imported-modules (source-module-closure + '((guix build utils) + (gnu build vm))) + (gexp->derivation "something-with-vms" + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + @dots{}))) +@end example + The syntactic form to construct gexps is summarized below. @deffn {Scheme Syntax} #~@var{exp} diff --git a/guix/modules.scm b/guix/modules.scm new file mode 100644 index 0000000000..24f613ff4e --- /dev/null +++ b/guix/modules.scm @@ -0,0 +1,155 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix modules) + #:use-module ((guix utils) #:select (memoize)) + #:use-module (guix sets) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (source-module-closure + live-module-closure + guix-module-name?)) + +;;; Commentary: +;;; +;;; This module provides introspection tools for Guile modules at the source +;;; level. Namely, it allows you to determine the closure of a module; it +;;; does so just by reading the 'define-module' clause of the module and its +;;; dependencies. This is primarily useful as an argument to +;;; 'with-imported-modules'. +;;; +;;; Code: + +(define (colon-symbol? obj) + "Return true if OBJ is a symbol that starts with a colon." + (and (symbol? obj) + (string-prefix? ":" (symbol->string obj)))) + +(define (colon-symbol->keyword symbol) + "Convert SYMBOL to a keyword after stripping its initial ':'." + (symbol->keyword + (string->symbol (string-drop (symbol->string symbol) 1)))) + +(define (extract-dependencies clauses) + "Return the list of modules imported according to the given 'define-module' +CLAUSES." + (let loop ((clauses clauses) + (result '())) + (match clauses + (() + (reverse result)) + ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _) + rest ...) + (loop rest (cons module result))) + ((#:use-module module rest ...) + (loop rest (cons module result))) + ((#:autoload module _ rest ...) + (loop rest (cons module result))) + (((or #:export #:re-export #:export-syntax #:re-export-syntax + #:replace #:version) + _ rest ...) + (loop rest result)) + (((or #:pure #:no-backtrace) rest ...) + (loop rest result)) + (((? colon-symbol? symbol) rest ...) + (loop (cons (colon-symbol->keyword symbol) rest) + result))))) + +(define module-file-dependencies + (memoize + (lambda (file) + "Return the list of the names of modules that the Guile module in FILE +depends on." + (call-with-input-file file + (lambda (port) + (match (read port) + (('define-module name clauses ...) + (extract-dependencies clauses)) + ;; XXX: R6RS 'library' form is ignored. + (_ + '()))))))) + +(define (module-name->file-name module) + "Return the file name for MODULE." + (string-append (string-join (map symbol->string module) "/") + ".scm")) + +(define (guix-module-name? name) + "Return true if NAME (a list of symbols) denotes a Guix or GuixSD module." + (match name + (('guix _ ...) #t) + (('gnu _ ...) #t) + (_ #f))) + +(define* (source-module-dependencies module #:optional (load-path %load-path)) + "Return the modules used by MODULE by looking at its source code." + ;; The (system syntax) module is a special-case because it has no + ;; corresponding source file (as of Guile 2.0.) + (if (equal? module '(system syntax)) + '() + (module-file-dependencies + (search-path load-path + (module-name->file-name module))))) + +(define* (module-closure modules + #:key + (select? guix-module-name?) + (dependencies source-module-dependencies)) + "Return the closure of MODULES, calling DEPENDENCIES to determine the list +of modules used by a given module. MODULES and the result are a list of Guile +module names. Only modules that match SELECT? are considered." + (let loop ((modules modules) + (result '()) + (visited (set))) + (match modules + (() + (reverse result)) + ((module rest ...) + (cond ((set-contains? visited module) + (loop rest result visited)) + ((select? module) + (loop (append (dependencies module) rest) + (cons module result) + (set-insert module visited))) + (else + (loop rest result visited))))))) + +(define* (source-module-closure modules + #:optional (load-path %load-path) + #:key (select? guix-module-name?)) + "Return the closure of MODULES by reading 'define-module' forms in their +source code. MODULES and the result are a list of Guile module names. Only +modules that match SELECT? are considered." + (module-closure modules + #:dependencies (cut source-module-dependencies <> load-path) + #:select? select?)) + +(define* (live-module-closure modules + #:key (select? guix-module-name?)) + "Return the closure of MODULES, determined by looking at live (loaded) +module information. MODULES and the result are a list of Guile module names. +Only modules that match SELECT? are considered." + (define (dependencies module) + (map module-name + (delq the-scm-module (module-uses (resolve-module module))))) + + (module-closure modules + #:dependencies dependencies + #:select? select?)) + +;;; modules.scm ends here diff --git a/tests/modules.scm b/tests/modules.scm new file mode 100644 index 0000000000..04945e531b --- /dev/null +++ b/tests/modules.scm @@ -0,0 +1,45 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-modules) + #:use-module (guix modules) + #:use-module ((guix build-system gnu) #:select (%gnu-build-system-modules)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +(test-begin "modules") + +(test-assert "closure of (guix build gnu-build-system)" + (lset= equal? + (live-module-closure '((guix build gnu-build-system))) + (source-module-closure '((guix build gnu-build-system))) + %gnu-build-system-modules + (source-module-closure %gnu-build-system-modules) + (live-module-closure %gnu-build-system-modules))) + +(test-assert "closure of (gnu build install)" + (lset= equal? + (live-module-closure '((gnu build install))) + (source-module-closure '((gnu build install))))) + +(test-assert "closure of (gnu build vm)" + (lset= equal? + (live-module-closure '((gnu build vm))) + (source-module-closure '((gnu build vm))))) + +(test-end) -- cgit v1.2.3 From 26ffb69399752d6b2c1ea93ac8c6cf7e3d178c02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 09:17:57 +0200 Subject: syscalls: Use #:return-errno? when it is available. * guix/build/syscalls.scm (errno): Do not export. (syscall->procedure): Change to return a procedure that returns both the value and errno. Use #:return-errno? where available. (mount, umount, swapon, swapoff, mkdtemp!, fdatasync, statfs) (clone, setns, pivot-root, fcntl-flock, network-interface-names) (network-interface-flags, set-network-interface-flags) (set-network-interface-address, network-interface-address): (network-interfaces, tcgetattr, tcsetattr, terminal-window-size): Adjust accordingly using 'let-values'. --- guix/build/syscalls.scm | 177 +++++++++++++++++++++++++----------------------- 1 file changed, 92 insertions(+), 85 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index e5315ed6f3..2cee6544c4 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -24,12 +24,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 ftw) - #:export (errno - MS_RDONLY + #:export (MS_RDONLY MS_NOSUID MS_NODEV MS_NOEXEC @@ -282,14 +282,14 @@ given TYPES. READ uses WRAP-FIELDS to return its value." ;;; (define %libc-errno-pointer - ;; Glibc's 'errno' pointer. + ;; Glibc's 'errno' pointer, for use with Guile < 2.0.12. (let ((errno-loc (false-if-exception (dynamic-func "__errno_location" (dynamic-link))))) (and errno-loc (let ((proc (pointer->procedure '* errno-loc '()))) (proc))))) -(define errno +(define errno ;for Guile < 2.0.12 (if %libc-errno-pointer (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) (lambda () @@ -328,13 +328,26 @@ given TYPES. READ uses WRAP-FIELDS to return its value." (call-with-restart-on-EINTR (lambda () expr))) (define (syscall->procedure return-type name argument-types) - "Return a procedure that wraps the C function NAME using the dynamic FFI. + "Return a procedure that wraps the C function NAME using the dynamic FFI, +and that returns two values: NAME's return value, and errno. + If an error occurs while creating the binding, defer the error report until the returned procedure is called." (catch #t (lambda () (let ((ptr (dynamic-func name (dynamic-link)))) - (pointer->procedure return-type ptr argument-types))) + ;; The #:return-errno? facility was introduced in Guile 2.0.12. + ;; Support older versions of Guile by catching 'wrong-number-of-args'. + (catch 'wrong-number-of-args + (lambda () + (pointer->procedure return-type ptr argument-types + #:return-errno? #t)) + (lambda (key . rest) + (let ((proc (pointer->procedure return-type ptr argument-types))) + (lambda args + (let ((result (apply proc args)) + (err (errno))) + (values result err)))))))) (lambda args (lambda _ (error (format #f "~a: syscall->procedure failed: ~s" @@ -401,18 +414,18 @@ may be a bitwise-or of the MS_* constants, and OPTIONS may be a string. When FLAGS contains MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on error." - (let ((ret (proc (if source - (string->pointer source) - %null-pointer) - (string->pointer target) - (if type - (string->pointer type) - %null-pointer) - flags - (if options - (string->pointer options) - %null-pointer))) - (err (errno))) + (let-values (((ret err) + (proc (if source + (string->pointer source) + %null-pointer) + (string->pointer target) + (if type + (string->pointer type) + %null-pointer) + flags + (if options + (string->pointer options) + %null-pointer)))) (unless (zero? ret) (throw 'system-error "mount" "mount ~S on ~S: ~A" (list source target (strerror err)) @@ -426,8 +439,8 @@ error." #:key (update-mtab? #f)) "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* constants from ." - (let ((ret (proc (string->pointer target) flags)) - (err (errno))) + (let-values (((ret err) + (proc (string->pointer target) flags))) (unless (zero? ret) (throw 'system-error "umount" "~S: ~A" (list target (strerror err)) @@ -451,8 +464,8 @@ constants from ." (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0)) "Use the block special device at DEVICE for swapping." - (let ((ret (proc (string->pointer device) flags)) - (err (errno))) + (let-values (((ret err) + (proc (string->pointer device) flags))) (unless (zero? ret) (throw 'system-error "swapon" "~S: ~A" (list device (strerror err)) @@ -462,8 +475,7 @@ constants from ." (let ((proc (syscall->procedure int "swapoff" '(*)))) (lambda (device) "Stop using block special device DEVICE for swapping." - (let ((ret (proc (string->pointer device))) - (err (errno))) + (let-values (((ret err) (proc (string->pointer device)))) (unless (zero? ret) (throw 'system-error "swapoff" "~S: ~A" (list device (strerror err)) @@ -499,8 +511,7 @@ user-land process." (lambda (tmpl) "Create a new unique directory in the file system using the template string TMPL and return its file name. TMPL must end with 'XXXXXX'." - (let ((result (proc (string->pointer tmpl))) - (err (errno))) + (let-values (((result err) (proc (string->pointer tmpl)))) (when (null-pointer? result) (throw 'system-error "mkdtemp!" "~S: ~A" (list tmpl (strerror err)) @@ -513,9 +524,8 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." "Flush buffered output of PORT, an output file port, and then call fdatasync(2) on the underlying file descriptor." (force-output port) - (let* ((fd (fileno port)) - (ret (proc fd)) - (err (errno))) + (let*-values (((fd) (fileno port)) + ((ret err) (proc fd))) (unless (zero? ret) (throw 'system-error "fdatasync" "~S: ~A" (list fd (strerror err)) @@ -566,9 +576,9 @@ fdatasync(2) on the underlying file descriptor." (lambda (file) "Return a data structure describing the file system mounted at FILE." - (let* ((stat (make-bytevector sizeof-statfs)) - (ret (proc (string->pointer file) (bytevector->pointer stat))) - (err (errno))) + (let*-values (((stat) (make-bytevector sizeof-statfs)) + ((ret err) (proc (string->pointer file) + (bytevector->pointer stat)))) (if (zero? ret) (read-statfs stat) (throw 'system-error "statfs" "~A: ~A" @@ -611,11 +621,11 @@ mounted at FILE." "Create a new child process by duplicating the current parent process. Unlike the fork system call, clone accepts FLAGS that specify which resources are shared between the parent and child processes." - (let ((ret (proc syscall-id flags - %null-pointer ;child stack - %null-pointer %null-pointer ;ptid & ctid - %null-pointer)) ;unused - (err (errno))) + (let-values (((ret err) + (proc syscall-id flags + %null-pointer ;child stack + %null-pointer %null-pointer ;ptid & ctid + %null-pointer))) ;unused (if (= ret -1) (throw 'system-error "clone" "~d: ~A" (list flags (strerror err)) @@ -632,8 +642,7 @@ are shared between the parent and child processes." file descriptor obtained by opening a /proc/PID/ns/* file. NSTYPE specifies which type of namespace the current process may be reassociated with, or 0 if there is no such limitation." - (let ((ret (proc fdes nstype)) - (err (errno))) + (let-values (((ret err) (proc fdes nstype))) (unless (zero? ret) (throw 'system-error "setns" "~d ~d: ~A" (list fdes nstype (strerror err)) @@ -644,9 +653,9 @@ there is no such limitation." (lambda (new-root put-old) "Change the root file system to NEW-ROOT and move the current root file system to PUT-OLD." - (let ((ret (proc (string->pointer new-root) - (string->pointer put-old))) - (err (errno))) + (let-values (((ret err) + (proc (string->pointer new-root) + (string->pointer put-old)))) (unless (zero? ret) (throw 'system-error "pivot_root" "~S ~S: ~A" (list new-root put-old (strerror err)) @@ -717,12 +726,12 @@ exception if it's already taken." ;; XXX: 'fcntl' is a vararg function, but here we happily use the ;; standard ABI; crossing fingers. - (let ((ret (proc fd - (if wait? - F_SETLKW ; lock & wait - F_SETLK) ; non-blocking attempt - (bytevector->pointer bv))) - (err (errno))) + (let-values (((ret err) + (proc fd + (if wait? + F_SETLKW ;lock & wait + F_SETLK) ;non-blocking attempt + (bytevector->pointer bv)))) (unless (zero? ret) ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) @@ -857,19 +866,19 @@ to interfaces that are currently up." (len (* ifreq-struct-size 10)) (reqs (make-bytevector len)) (conf (make-c-struct ifconf-struct - (list len (bytevector->pointer reqs)))) - (ret (%ioctl (fileno sock) SIOCGIFCONF conf)) - (err (errno))) - (when close? - (close-port sock)) - (if (zero? ret) - (bytevector->string-list reqs ifreq-struct-size - (match (parse-c-struct conf ifconf-struct) - ((len . _) len))) - (throw 'system-error "network-interface-list" - "network-interface-list: ~A" - (list (strerror err)) - (list err))))) + (list len (bytevector->pointer reqs))))) + (let-values (((ret err) + (%ioctl (fileno sock) SIOCGIFCONF conf))) + (when close? + (close-port sock)) + (if (zero? ret) + (bytevector->string-list reqs ifreq-struct-size + (match (parse-c-struct conf ifconf-struct) + ((len . _) len))) + (throw 'system-error "network-interface-list" + "network-interface-list: ~A" + (list (strerror err)) + (list err)))))) (define %interface-line ;; Regexp matching an interface line in Linux's /proc/net/dev. @@ -897,9 +906,9 @@ interface NAME." (let ((req (make-bytevector ifreq-struct-size))) (bytevector-copy! (string->utf8 name) 0 req 0 (min (string-length name) (- IF_NAMESIZE 1))) - (let* ((ret (%ioctl (fileno socket) SIOCGIFFLAGS - (bytevector->pointer req))) - (err (errno))) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCGIFFLAGS + (bytevector->pointer req)))) (if (zero? ret) ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of @@ -927,9 +936,9 @@ interface NAME." ;; Set the 'ifr_flags' field. (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness) (sizeof short)) - (let* ((ret (%ioctl (fileno socket) SIOCSIFFLAGS - (bytevector->pointer req))) - (err (errno))) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCSIFFLAGS + (bytevector->pointer req)))) (unless (zero? ret) (throw 'system-error "set-network-interface-flags" "set-network-interface-flags on ~A: ~A" @@ -943,9 +952,9 @@ interface NAME." (min (string-length name) (- IF_NAMESIZE 1))) ;; Set the 'ifr_addr' field. (write-socket-address! sockaddr req IF_NAMESIZE) - (let* ((ret (%ioctl (fileno socket) SIOCSIFADDR - (bytevector->pointer req))) - (err (errno))) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCSIFADDR + (bytevector->pointer req)))) (unless (zero? ret) (throw 'system-error "set-network-interface-address" "set-network-interface-address on ~A: ~A" @@ -958,9 +967,9 @@ the same type as that returned by 'make-socket-address'." (let ((req (make-bytevector ifreq-struct-size))) (bytevector-copy! (string->utf8 name) 0 req 0 (min (string-length name) (- IF_NAMESIZE 1))) - (let* ((ret (%ioctl (fileno socket) SIOCGIFADDR - (bytevector->pointer req))) - (err (errno))) + (let-values (((ret err) + (%ioctl (fileno socket) SIOCGIFADDR + (bytevector->pointer req)))) (if (zero? ret) (read-socket-address req IF_NAMESIZE) (throw 'system-error "network-interface-address" @@ -1076,9 +1085,10 @@ return the list of resulting objects." (lambda () "Return a list of objects, each denoting a configured network interface. This is implemented using the 'getifaddrs' libc function." - (let* ((ptr (bytevector->pointer (make-bytevector (sizeof* '*)))) - (ret (proc ptr)) - (err (errno))) + (let*-values (((ptr) + (bytevector->pointer (make-bytevector (sizeof* '*)))) + ((ret err) + (proc ptr))) (if (zero? ret) (let* ((ptr (dereference-pointer ptr)) (result (unfold-interface-list ptr))) @@ -1181,9 +1191,8 @@ given an integer, returns the list of names of the constants that are or'd." (let ((proc (syscall->procedure int "tcgetattr" (list int '*)))) (lambda (fd) "Return the structure for the tty at FD." - (let* ((bv (make-bytevector sizeof-termios)) - (ret (proc fd (bytevector->pointer bv))) - (err (errno))) + (let*-values (((bv) (make-bytevector sizeof-termios)) + ((ret err) (proc fd (bytevector->pointer bv)))) (if (zero? ret) (read-termios bv) (throw 'system-error "tcgetattr" "~A" @@ -1206,8 +1215,7 @@ produced by 'tcsetattr-action'; see tcsetattr(3) for details." (match/write input-flags output-flags control-flags local-flags line-discipline control-chars input-speed output-speed)) - (let ((ret (proc fd actions (bytevector->pointer bv))) - (err (errno))) + (let-values (((ret err) (proc fd actions (bytevector->pointer bv)))) (unless (zero? ret) (throw 'system-error "tcgetattr" "~A" (list (strerror err)) @@ -1238,10 +1246,9 @@ produced by 'tcsetattr-action'; see tcsetattr(3) for details." "Return a structure describing the terminal at PORT, or raise a 'system-error' if PORT is not backed by a terminal. This procedure corresponds to the TIOCGWINSZ ioctl." - (let* ((size (make-bytevector sizeof-winsize)) - (ret (%ioctl (fileno port) TIOCGWINSZ - (bytevector->pointer size))) - (err (errno))) + (let*-values (((size) (make-bytevector sizeof-winsize)) + ((ret err) (%ioctl (fileno port) TIOCGWINSZ + (bytevector->pointer size)))) (if (zero? ret) (read-winsize size) (throw 'system-error "terminal-window-size" "~A" -- cgit v1.2.3 From 0c90ed5505e04540b1982c04993369fb9706a916 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 09:23:43 +0200 Subject: gnupg: Honor $GUIX_GPG_COMMAND and default to 'gpg'. * guix/gnupg.scm (%gpg-command): Change to "gpg" or $GUIX_GPG_COMMAND. --- guix/gnupg.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gnupg.scm b/guix/gnupg.scm index d1d8b377e1..ef8f9000dc 100644 --- a/guix/gnupg.scm +++ b/guix/gnupg.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2013, 2014 Ludovic Courtès +;;; Copyright © 2010, 2011, 2013, 2014, 2016 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -40,7 +40,7 @@ (define %gpg-command ;; The GnuPG 2.x command-line program name. - (make-parameter "gpg2")) + (make-parameter (or (getenv "GUIX_GPG_COMMAND") "gpg"))) (define %openpgp-key-server ;; The default key server. Note that keys.gnupg.net appears to be -- cgit v1.2.3 From dd72173455b31aeddb4a691285bd5c0702c75d34 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 19:27:27 +0200 Subject: guix package: Clarify upgrade code. * guix/scripts/package.scm (upgradeable?): Rename to... (upgraded-manifest-entry): ... this. Change to take a and to return a . (options->installable)[to-upgrade]: Adjust accordingly. --- guix/scripts/package.scm | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index fd42cdb36e..14a0895b43 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -261,19 +261,25 @@ synopsis or description matches all of REGEXPS." ((<) #t) (else #f))))) -(define (upgradeable? name current-version current-path) - "Return #t if there's a version of package NAME newer than CURRENT-VERSION, -or if the newest available version is equal to CURRENT-VERSION but would have -an output path different than CURRENT-PATH." - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (case (version-compare candidate-version current-version) - ((>) #t) - ((<) #f) - ((=) (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - (not (string=? current-path candidate-path)))))) - (#f #f))) +(define (upgraded-manifest-entry entry) + "Return either a corresponding to an upgrade of ENTRY, or +#f if no upgrade was found." + (match entry + (($ name version output (? string? path)) + (match (vhash-assoc name (find-newest-available-packages)) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version version) + ((>) + (package->manifest-entry pkg output)) + ((<) + #f) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + (and (not (string=? path candidate-path)) + (package->manifest-entry pkg output)))))) + (#f + #f))))) ;;; @@ -560,16 +566,9 @@ return the new list of manifest entries." (options->upgrade-predicate opts)) (define to-upgrade - (filter-map (match-lambda - (($ name version output path _) - (and (upgrade? name) - (upgradeable? name version path) - (let ((output (or output "out"))) - (call-with-values - (lambda () - (specification->package+output name output)) - package->manifest-entry)))) - (_ #f)) + (filter-map (lambda (entry) + (and (upgrade? (manifest-entry-name entry)) + (upgraded-manifest-entry entry))) (manifest-entries manifest))) (define to-install -- cgit v1.2.3 From c8c25704aeb2e5fa4feb6a86235f9565738eea99 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 20:19:21 +0200 Subject: profiles: Add manifest-transaction helper procedures. * guix/profiles.scm (manifest-transaction-install-entry) (manifest-transaction-remove-pattern) (manifest-transaction-null?): New procedures. * tests/profiles.scm ("manifest-transaction-null?"): New test. --- guix/profiles.scm | 27 ++++++++++++++++++++++++++- tests/profiles.scm | 3 +++ 2 files changed, 29 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index cd448e3f25..ac2fa051b2 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -78,6 +78,9 @@ manifest-transaction? manifest-transaction-install manifest-transaction-remove + manifest-transaction-install-entry + manifest-transaction-remove-pattern + manifest-transaction-null? manifest-perform-transaction manifest-transaction-effects @@ -383,6 +386,28 @@ no match.." (remove manifest-transaction-remove ; list of (default '()))) +(define (manifest-transaction-install-entry entry transaction) + "Augment TRANSACTION's set of installed packages with ENTRY, a +." + (manifest-transaction + (inherit transaction) + (install + (cons entry (manifest-transaction-install transaction))))) + +(define (manifest-transaction-remove-pattern pattern transaction) + "Add PATTERN to TRANSACTION's list of packages to remove." + (manifest-transaction + (inherit transaction) + (remove + (cons pattern (manifest-transaction-remove transaction))))) + +(define (manifest-transaction-null? transaction) + "Return true if TRANSACTION has no effect---i.e., it neither installs nor +remove software." + (match transaction + (($ () ()) #t) + (($ _ _) #f))) + (define (manifest-transaction-effects manifest transaction) "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values: the list of packages that would be removed, installed, upgraded, or downgraded @@ -424,7 +449,7 @@ replace it." downgrade))))))) (define (manifest-perform-transaction manifest transaction) - "Perform TRANSACTION on MANIFEST and return new manifest." + "Perform TRANSACTION on MANIFEST and return the new manifest." (let ((install (manifest-transaction-install transaction)) (remove (manifest-transaction-remove transaction))) (manifest-add (manifest-remove manifest remove) diff --git a/tests/profiles.scm b/tests/profiles.scm index 028d7b6fb4..f9c2f5499e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -187,6 +187,9 @@ (and (null? remove) (null? install) (null? downgrade) (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade))))) +(test-assert "manifest-transaction-null?" + (manifest-transaction-null? (manifest-transaction))) + (test-assertm "profile-derivation" (mlet* %store-monad ((entry -> (package->manifest-entry %bootstrap-guile)) -- cgit v1.2.3 From 5239f3d90841de767c86d0f3a7975b8d799d583d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 22:28:12 +0200 Subject: guix package: Build up the transaction incrementally. * guix/scripts/package.scm (upgraded-manifest-entry): Rename to... (transaction-upgrade-entry): ... this. Add 'transaction' parameter and return a transaction. (options->installable): Likewise. [to-upgrade]: Rename to... [upgraded]: ... this, and change to be a transaction. Return a transaction. (options->removable): Likewise. (process-actions): Adjust accordingly. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades") ("transaction-upgrade-entry, one upgrade"): New tests. --- guix/scripts/package.scm | 100 +++++++++++++++++++++++++++-------------------- tests/packages.scm | 29 ++++++++++++++ 2 files changed, 87 insertions(+), 42 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 14a0895b43..dc5fcba922 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -261,25 +261,30 @@ synopsis or description matches all of REGEXPS." ((<) #t) (else #f))))) -(define (upgraded-manifest-entry entry) - "Return either a corresponding to an upgrade of ENTRY, or -#f if no upgrade was found." +(define (transaction-upgrade-entry entry transaction) + "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a +." (match entry (($ name version output (? string? path)) (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version version) ((>) - (package->manifest-entry pkg output)) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) ((<) - #f) + transaction) ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) - (and (not (string=? path candidate-path)) - (package->manifest-entry pkg output)))))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))) (#f - #f))))) + transaction))))) ;;; @@ -559,17 +564,20 @@ upgrading, #f otherwise." (output #f) (item item)))) -(define (options->installable opts manifest) +(define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." +return an variant of TRANSACTION that accounts for the specified installations +and upgrades." (define upgrade? (options->upgrade-predicate opts)) - (define to-upgrade - (filter-map (lambda (entry) - (and (upgrade? (manifest-entry-name entry)) - (upgraded-manifest-entry entry))) - (manifest-entries manifest))) + (define upgraded + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -586,23 +594,29 @@ return the new list of manifest entries." (_ #f)) opts)) - (append to-upgrade to-install)) - -(define (options->removable options manifest) - "Given options, return the list of manifest patterns of packages to be -removed from MANIFEST." - (filter-map (match-lambda - (('remove . spec) - (call-with-values - (lambda () - (package-specification->name+version+output spec)) - (lambda (name version output) - (manifest-pattern - (name name) - (version version) - (output output))))) - (_ #f)) - options)) + (fold manifest-transaction-install-entry + upgraded + to-install)) + +(define (options->removable options manifest transaction) + "Given options, return a variant of TRANSACTION augmented with the list of +patterns of packages to remove." + (fold (lambda (opt transaction) + (match opt + (('remove . spec) + (call-with-values + (lambda () + (package-specification->name+version+output spec)) + (lambda (name version output) + (manifest-transaction-remove-pattern + (manifest-pattern + (name name) + (version version) + (output output)) + transaction)))) + (_ transaction))) + transaction + options)) (define (register-gc-root store profile) "Register PROFILE, a profile generation symlink, as a GC root, unless it @@ -813,16 +827,18 @@ processed, #f otherwise." opts) ;; Then, process normal package installation/removal/upgrade. - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction - (install (map transform-entry install)) - (remove remove))) - (new (manifest-perform-transaction manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction store manifest transaction + (let* ((manifest (profile-manifest profile)) + (step1 (options->installable opts manifest + (manifest-transaction))) + (step2 (options->removable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) (build-and-use-profile store profile new #:bootstrap? bootstrap? diff --git a/tests/packages.scm b/tests/packages.scm index daceea5d62..456e691962 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -49,6 +49,7 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) + #:use-module (ice-9 vlist) #:use-module (ice-9 regex) #:use-module (ice-9 match)) @@ -83,6 +84,34 @@ (and (hidden-package? (hidden-package (dummy-package "foo"))) (not (hidden-package? (dummy-package "foo"))))) +(test-assert "transaction-upgrade-entry, zero upgrades" + (let* ((old (dummy-package "foo" (version "1"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const vlist-null)) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + +(test-assert "transaction-upgrade-entry, one upgrade" + (let* ((old (dummy-package "foo" (version "1"))) + (new (dummy-package "foo" (version "2"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const (vhash-cons "foo" (list "2" new) vlist-null))) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "foo" "2" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 03763d6473bcd6c7a84bcc3a6aa7bc2d1ee1e44f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 23:05:26 +0200 Subject: profiles: Export accessors. * guix/profiles.scm (manifest-pattern-name, manifest-pattern-version) (manifest-pattern-output): Export. --- guix/profiles.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index ac2fa051b2..4a2ba1c2f4 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -67,6 +67,9 @@ manifest-pattern manifest-pattern? + manifest-pattern-name + manifest-pattern-version + manifest-pattern-output manifest-remove manifest-add -- cgit v1.2.3 From 01afdab89c6a91f4cd05d3c4f4ff95a0402703eb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Sep 2016 23:14:07 +0200 Subject: packages: Add 'package-superseded' and associated support. This provides a way to mark a package as superseded by another one. Upgrades replace superseded packages with their replacement. * guix/packages.scm (package-superseded, deprecated-package): New procedures. * gnu/packages.scm (%find-package): Check for 'package-superseded'. * guix/scripts/package.scm (transaction-upgrade-entry)[supersede]: New procedure. Call it when 'package-superseded' is true. * tests/guix-build.sh: Add test for a superseded package. * tests/packages.scm ("package-superseded") ("transaction-upgrade-entry, superseded package"): New tests. --- gnu/packages.scm | 9 ++++++++- guix/packages.scm | 14 ++++++++++++++ guix/scripts/package.scm | 46 +++++++++++++++++++++++++++++++--------------- tests/guix-build.sh | 6 ++++++ tests/packages.scm | 30 ++++++++++++++++++++++++++++++ 5 files changed, 89 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/gnu/packages.scm b/gnu/packages.scm index 68a9eef2ad..5d60423a3a 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -305,7 +305,14 @@ return its return value." (when fallback? (warning (_ "deprecated NAME-VERSION syntax; \ use NAME@VERSION instead~%"))) - pkg) + + (match (package-superseded pkg) + ((? package? new) + (info (_ "package '~a' has been superseded by '~a'~%") + (package-name pkg) (package-name new)) + new) + (#f + pkg))) (_ (if version (leave (_ "~A: package not found for version ~a~%") name version) diff --git a/guix/packages.scm b/guix/packages.scm index d544c34cf8..afbafc70a7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -83,6 +83,8 @@ package-location hidden-package hidden-package? + package-superseded + deprecated-package package-field-location package-direct-sources @@ -306,6 +308,18 @@ user interfaces, ignores." interfaces." (assoc-ref (package-properties p) 'hidden?)) +(define (package-superseded p) + "Return the package the supersedes P, or #f if P is still current." + (assoc-ref (package-properties p) 'superseded)) + +(define (deprecated-package old-name p) + "Return a package called OLD-NAME and marked as superseded by P, a package +object." + (package + (inherit p) + (name old-name) + (properties `((superseded . ,p))))) + (define (package-field-location package field) "Return the source code location of the definition of FIELD for PACKAGE, or #f if it could not be determined." diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index dc5fcba922..b87aee0be9 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -264,25 +264,41 @@ synopsis or description matches all of REGEXPS." (define (transaction-upgrade-entry entry transaction) "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a ." + (define (supersede old new) + (info (_ "package '~a' has been superseded by '~a'~%") + (manifest-entry-name old) (package-name new)) + (manifest-transaction-install-entry + (package->manifest-entry new (manifest-entry-output old)) + (manifest-transaction-remove-pattern + (manifest-pattern + (name (manifest-entry-name old)) + (version (manifest-entry-version old)) + (output (manifest-entry-output old))) + transaction))) + (match entry (($ name version output (? string? path)) (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - (if (string=? path candidate-path) - transaction - (manifest-transaction-install-entry - (package->manifest-entry pkg output) - transaction)))))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))))) (#f transaction))))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 6d4f97019a..9e9788bca0 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -93,6 +93,9 @@ cat > "$module_dir/foo.scm"<package "foo") + (and (eq? new (specification->package "foo")) + (eq? new (specification->package+output "foo"))))))) + (test-assert "transaction-upgrade-entry, zero upgrades" (let* ((old (dummy-package "foo" (version "1"))) (tx (mock ((gnu packages) find-newest-available-packages @@ -112,6 +121,27 @@ (eq? item new))) (null? (manifest-transaction-remove tx))))) +(test-assert "transaction-upgrade-entry, superseded package" + (let* ((old (dummy-package "foo" (version "1"))) + (new (dummy-package "bar" (version "2"))) + (dep (deprecated-package "foo" new)) + (tx (mock ((gnu packages) find-newest-available-packages + (const (vhash-cons "foo" (list "2" dep) vlist-null))) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ "bar" "2" "out" item)) + (eq? item new))) + (match (manifest-transaction-remove tx) + (((? manifest-pattern? pattern)) + (and (string=? (manifest-pattern-name pattern) "foo") + (string=? (manifest-pattern-version pattern) "1") + (string=? (manifest-pattern-output pattern) "out"))))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From 392a4e122350367c4b4ac331db5ec28360c7f38c Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 6 Sep 2016 08:28:33 +0200 Subject: guix hash: Add --exclude-vcs option. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/hash.scm (show-help): Add help text for --exclude-vcs option. (%options): Add --exclude-vcs option. (guix-hash): Handle exclude-vcs option. * doc/guix.texi ("Invoking guix hash"): Update doc. * tests/guix-hash.sh: Add test. Co-authored-by: Ludovic Courtès --- doc/guix.texi | 10 +++++++--- guix/scripts/hash.scm | 25 ++++++++++++++++++++----- tests/guix-hash.sh | 16 ++++++++++++++++ 3 files changed, 43 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 59bc5d8ee0..655dcfa277 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4678,7 +4678,7 @@ The general syntax is: guix hash @var{option} @var{file} @end example -@command{guix hash} has the following option: +@command{guix hash} has the following options: @table @code @@ -4706,6 +4706,11 @@ hash (@pxref{Invoking guix archive}). @c FIXME: Replace xref above with xref to an ``Archive'' section when @c it exists. +@item --exclude-vcs +@itemx -x +When combined with @option{--recursive}, exclude version control system +directories (@file{.bzr}, @file{.git}, @file{.hg}, etc.) + @vindex git-fetch As an example, here is how you would compute the hash of a Git checkout, which is useful when using the @code{git-fetch} method (@pxref{origin @@ -4714,8 +4719,7 @@ Reference}): @example $ git clone http://example.org/foo.git $ cd foo -$ rm -rf .git -$ guix hash -r . +$ guix hash -rx . @end example @end table diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index d44095377b..a57602ab51 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov +;;; Copyright © 2016 Jan Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,6 +49,8 @@ Return the cryptographic hash of FILE. Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) + (format #t (_ " + -x, --exclude-vcs exclude version control directories")) (format #t (_ " -f, --format=FMT write the hash in the given format")) (format #t (_ " @@ -62,7 +65,10 @@ and 'hexadecimal' can be used as well).\n")) (define %options ;; Specification of the command-line options. - (list (option '(#\f "format") #t #f + (list (option '(#\x "exclude-vcs") #f #f + (lambda (opt name arg result) + (alist-cons 'exclude-vcs? #t result))) + (option '(#\f "format") #t #f (lambda (opt name arg result) (define fmt-proc (match arg @@ -81,7 +87,6 @@ and 'hexadecimal' can be used as well).\n")) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive? #t result))) - (option '(#\h "help") #f #f (lambda args (show-help) @@ -107,13 +112,23 @@ and 'hexadecimal' can be used as well).\n")) (alist-cons 'argument arg result)) %default-options)) + (define (vcs-file? file stat) + (case (stat:type stat) + ((directory) + (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + (else + #f))) + (let* ((opts (parse-options)) (args (filter-map (match-lambda (('argument . value) value) (_ #f)) (reverse opts))) - (fmt (assq-ref opts 'format))) + (fmt (assq-ref opts 'format)) + (select? (if (assq-ref opts 'exclude-vcs?) + (negate vcs-file?) + (const #t)))) (define (file-hash file) ;; Compute the hash of FILE. @@ -121,7 +136,7 @@ and 'hexadecimal' can be used as well).\n")) (with-error-handling (if (assoc-ref opts 'recursive?) (let-values (((port get-hash) (open-sha256-port))) - (write-file file port) + (write-file file port #:select? select?) (flush-output-port port) (get-hash)) (call-with-input-file file port-sha256)))) diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 23df01d417..44213d51af 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2013, 2014 Ludovic Courtès +# Copyright © 2016 Jan Nieuwenhuizen # # This file is part of GNU Guix. # @@ -46,3 +47,18 @@ then false; else true; fi # the archive format doesn't support. if guix hash -r /dev/null then false; else true; fi + +# Adding a .git directory +mkdir "$tmpdir/.git" +touch "$tmpdir/.git/foo" + +# ...changes the hash +test `guix hash -r $tmpdir` = 0a50z04zyzf7pidwxv0nwbj82pgzbrhdy9562kncnvkcfvb48m59 + +# ...but remains the same when using `-x' +test `guix hash -r $tmpdir -x` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p + +# Without '-r', this should fail. +if guix hash "$tmpdir" +then false; else true; fi + -- cgit v1.2.3 From b5fed903c44b27c61935a51ee1b4b866500f53c2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Sep 2016 16:50:34 +0200 Subject: gexp: Remove outdated comment. * guix/gexp.scm (lower-references): Remove outdated "XXX" comment. --- guix/gexp.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 302879fb42..b33a3f89db 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -429,8 +429,6 @@ corresponding derivation." "Based on LST, a list of output names and packages, return a list of output names and file names suitable for the #:allowed-references argument to 'derivation'." - ;; XXX: Currently outputs other than "out" are not supported, and things - ;; other than packages aren't either. (with-monad %store-monad (define lower (match-lambda -- cgit v1.2.3 From ebdfd776f4504c456d383ee8afa59fc6fdfc6756 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Sep 2016 22:43:41 +0200 Subject: gexp: Compilers can now provide an "expander". * guix/gexp.scm ()[expand]: New field. (default-expander, lookup-expander): New procedures. (define-gexp-compiler): Add second pattern to allow for the definition of both a compiler and an expander. (gexp->sexp)[reference->sexp]: Call 'lookup-expander' and use its result. --- guix/gexp.scm | 74 +++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 52 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b33a3f89db..8d380ec95b 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -126,27 +126,46 @@ ;; Compiler for a type of objects that may be introduced in a gexp. (define-record-type - (gexp-compiler predicate lower) + (gexp-compiler predicate lower expand) gexp-compiler? (predicate gexp-compiler-predicate) - (lower gexp-compiler-lower)) + (lower gexp-compiler-lower) + (expand gexp-compiler-expand)) ;#f | DRV -> M sexp (define %gexp-compilers ;; List of . '()) +(define (default-expander thing obj output) + "This is the default expander for \"things\" that appear in gexps. It +returns its output file name of OBJ's OUTPUT." + (match obj + ((? derivation? drv) + (derivation->output-path drv output)) + ((? string? file) + file))) + (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." (set! %gexp-compilers (cons compiler %gexp-compilers))) (define (lookup-compiler object) - "Search a compiler for OBJECT. Upon success, return the three argument + "Search for a compiler for OBJECT. Upon success, return the three argument procedure to lower it; otherwise return #f." (any (match-lambda (($ predicate lower) (and (predicate object) lower))) %gexp-compilers)) +(define (lookup-expander object) + "Search for an expander for OBJECT. Upon success, return the three argument +procedure to expand it; otherwise return #f." + (or (any (match-lambda + (($ predicate _ expand) + (and (predicate object) expand))) + %gexp-compilers) + default-expander)) + (define* (lower-object obj #:optional (system (%current-system)) #:key target) @@ -157,19 +176,33 @@ OBJ must be an object that has an associated gexp compiler, such as a (let ((lower (lookup-compiler obj))) (lower obj system target))) -(define-syntax-rule (define-gexp-compiler (name (param predicate) - system target) - body ...) - "Define NAME as a compiler for objects matching PREDICATE encountered in -gexps. BODY must return a derivation for PARAM, an object that matches -PREDICATE, for SYSTEM and TARGET (the latter of which is #f except when -cross-compiling.)" - (begin - (define name - (gexp-compiler predicate - (lambda (param system target) - body ...))) - (register-compiler! name))) +(define-syntax define-gexp-compiler + (syntax-rules (=> compiler expander) + "Define NAME as a compiler for objects matching PREDICATE encountered in +gexps. + +In the simplest form of the macro, BODY must return a derivation for PARAM, an +object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is +#f except when cross-compiling.) + +The more elaborate form allows you to specify an expander: + + (define-gexp-compiler something something? + compiler => (lambda (param system target) ...) + expander => (lambda (param drv output) ...)) + +The expander specifies how an object is converted to its sexp representation." + ((_ (name (param predicate) system target) body ...) + (define-gexp-compiler name predicate + compiler => (lambda (param system target) body ...) + expander => default-expander)) + ((_ name predicate + compiler => compile + expander => expand) + (begin + (define name + (gexp-compiler predicate compile expand)) + (register-compiler! name))))) (define-gexp-compiler (derivation-compiler (drv derivation?) system target) ;; Derivations are the lowest-level representation, so this is the identity @@ -704,15 +737,12 @@ and in the current monad setting (system type, etc.)" (or n? native?))) refs))) (($ (? struct? thing) output n?) - (let ((target (if (or n? native?) #f target))) + (let ((target (if (or n? native?) #f target)) + (expand (lookup-expander thing))) (mlet %store-monad ((obj (lower-object thing system #:target target))) ;; OBJ must be either a derivation or a store file name. - (return (match obj - ((? derivation? drv) - (derivation->output-path drv output)) - ((? string? file) - file)))))) + (return (expand thing obj output))))) (($ x) (return x)) (x -- cgit v1.2.3 From a9e5e92f940381e3a4ee828c6d8ff22a73067e17 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 9 Sep 2016 22:46:36 +0200 Subject: gexp: Add 'file-append'. * guix/gexp.scm (): New record type. (file-append): New procedure. (file-append-compiler): New gexp compiler. * tests/gexp.scm ("file-append", "file-append, output") ("file-append, nested", "gexp->file + file-append"): New tests. * doc/guix.texi (G-Expressions): Use it in 'nscd' and 'list-files' examples. Document 'file-append'. --- doc/guix.texi | 35 +++++++++++++++++++++++++++++++---- guix/gexp.scm | 29 +++++++++++++++++++++++++++++ tests/gexp.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 113 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 3923627c79..6d3361878b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3985,7 +3985,7 @@ The @code{local-file}, @code{plain-file}, @code{computed-file}, these objects lead to a file in the store. Consider this G-expression: @example -#~(system* (string-append #$glibc "/sbin/nscd") "-f" +#~(system* #$(file-append glibc "/sbin/nscd") "-f" #$(local-file "/tmp/my-nscd.conf")) @end example @@ -4044,7 +4044,7 @@ command: (use-modules (guix gexp) (gnu packages base)) (gexp->script "list-files" - #~(execl (string-append #$coreutils "/bin/ls") + #~(execl #$(file-append coreutils "/bin/ls") "ls")) @end example @@ -4055,8 +4055,7 @@ executable file @file{/gnu/store/@dots{}-list-files} along these lines: @example #!/gnu/store/@dots{}-guile-2.0.11/bin/guile -ds !# -(execl (string-append "/gnu/store/@dots{}-coreutils-8.22"/bin/ls") - "ls") +(execl "/gnu/store/@dots{}-coreutils-8.22"/bin/ls" "ls") @end example @end deffn @@ -4126,6 +4125,34 @@ as in: This is the declarative counterpart of @code{text-file*}. @end deffn +@deffn {Scheme Procedure} file-append @var{obj} @var{suffix} @dots{} +Return a file-like object that expands to the concatenation of @var{obj} +and @var{suffix}, where @var{obj} is a lowerable object and each +@var{suffix} is a string. + +As an example, consider this gexp: + +@example +(gexp->script "run-uname" + #~(system* #$(file-append coreutils + "/bin/uname"))) +@end example + +The same effect could be achieved with: + +@example +(gexp->script "run-uname" + #~(system* (string-append #$coreutils + "/bin/uname"))) +@end example + +There is one difference though: in the @code{file-append} case, the +resulting script contains the absolute file name as a string, whereas in +the second case, the resulting script contains a @code{(string-append +@dots{})} expression to construct the file name @emph{at run time}. +@end deffn + + Of course, in addition to gexps embedded in ``host'' code, there are also modules containing build tools. To make it clear that they are meant to be used in the build stratum, these modules are kept in the diff --git a/guix/gexp.scm b/guix/gexp.scm index 8d380ec95b..7e2ecf6c33 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -63,6 +63,11 @@ scheme-file-name scheme-file-gexp + file-append + file-append? + file-append-base + file-append-suffix + gexp->derivation gexp->file gexp->script @@ -368,6 +373,30 @@ This is the declarative counterpart of 'gexp->file'." (($ name gexp) (gexp->file name gexp)))) +;; Appending SUFFIX to BASE's output file name. +(define-record-type + (%file-append base suffix) + file-append? + (base file-append-base) ; | | ... + (suffix file-append-suffix)) ;list of strings + +(define (file-append base . suffix) + "Return a object that expands to the concatenation of BASE and +SUFFIX." + (%file-append base suffix)) + +(define-gexp-compiler file-append-compiler file-append? + compiler => (lambda (obj system target) + (match obj + (($ base _) + (lower-object base system #:target target)))) + expander => (lambda (obj lowered output) + (match obj + (($ base suffix) + (let* ((expand (lookup-expander base)) + (base (expand base lowered output))) + (string-append base (string-concatenate suffix))))))) + ;;; ;;; Inputs & outputs. diff --git a/tests/gexp.scm b/tests/gexp.scm index 03a64fa6bb..214e7a5302 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -207,6 +207,47 @@ (e3 `(display ,txt))) (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp)))))) +(test-assert "file-append" + (let* ((drv (package-derivation %store %bootstrap-guile)) + (fa (file-append %bootstrap-guile "/bin/guile")) + (exp #~(here we go #$fa))) + (and (match (gexp->sexp* exp) + (('here 'we 'go (? string? result)) + (string=? result + (string-append (derivation->output-path drv) + "/bin/guile")))) + (match (gexp-inputs exp) + (((thing "out")) + (eq? thing fa)))))) + +(test-assert "file-append, output" + (let* ((drv (package-derivation %store glibc)) + (fa (file-append glibc "/lib" "/debug")) + (exp #~(foo #$fa:debug))) + (and (match (gexp->sexp* exp) + (('foo (? string? result)) + (string=? result + (string-append (derivation->output-path drv "debug") + "/lib/debug")))) + (match (gexp-inputs exp) + (((thing "debug")) + (eq? thing fa)))))) + +(test-assert "file-append, nested" + (let* ((drv (package-derivation %store glibc)) + (dir (file-append glibc "/bin")) + (slash (file-append dir "/")) + (file (file-append slash "getent")) + (exp #~(foo #$file))) + (and (match (gexp->sexp* exp) + (('foo (? string? result)) + (string=? result + (string-append (derivation->output-path drv) + "/bin/getent")))) + (match (gexp-inputs exp) + (((thing "out")) + (eq? thing file)))))) + (test-assert "ungexp + ungexp-native" (let* ((exp (gexp (list (ungexp-native %bootstrap-guile) (ungexp coreutils) @@ -338,6 +379,18 @@ (return (and (equal? sexp (call-with-input-file out read)) (equal? (list guile) refs))))) +(test-assertm "gexp->file + file-append" + (mlet* %store-monad ((exp -> #~#$(file-append %bootstrap-guile + "/bin/guile")) + (guile (package-file %bootstrap-guile)) + (drv (gexp->file "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (refs ((store-lift references) out))) + (return (and (equal? (string-append guile "/bin/guile") + (call-with-input-file out read)) + (equal? (list guile) refs))))) + (test-assertm "gexp->derivation" (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) (exp -> (gexp -- cgit v1.2.3 From 1cdecf24f5a7d98c9564a12a2932a015cfc31b9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 10 Sep 2016 11:57:37 +0200 Subject: gexp: Store compilers in a hash table for O(1) lookup. * guix/gexp.scm ()[predicate]: Remove. [type]: New field. (%gexp-compilers): Turn into a hash table. (register-compiler!, lookup-compiler, lookup-expander): Adjust accordingly. (define-gexp-compiler): Replace 'predicate' by 'record-type'. (derivation-compiler, local-file-compiler, plain-file-compiler) (computed-file-compiler, program-file-compiler, scheme-file-compiler) (file-append-compiler): Adjust accordingly. * guix/packages.scm (package-compiler, origin-compiler): Likewise. --- guix/gexp.scm | 48 ++++++++++++++++++++++-------------------------- guix/packages.scm | 4 ++-- 2 files changed, 24 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 7e2ecf6c33..05178a5ecc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -131,15 +131,15 @@ ;; Compiler for a type of objects that may be introduced in a gexp. (define-record-type - (gexp-compiler predicate lower expand) + (gexp-compiler type lower expand) gexp-compiler? - (predicate gexp-compiler-predicate) + (type gexp-compiler-type) ;record type descriptor (lower gexp-compiler-lower) - (expand gexp-compiler-expand)) ;#f | DRV -> M sexp + (expand gexp-compiler-expand)) ;#f | DRV -> sexp (define %gexp-compilers - ;; List of . - '()) + ;; 'eq?' mapping of record type descriptor to . + (make-hash-table 20)) (define (default-expander thing obj output) "This is the default expander for \"things\" that appear in gexps. It @@ -152,24 +152,20 @@ returns its output file name of OBJ's OUTPUT." (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." - (set! %gexp-compilers (cons compiler %gexp-compilers))) + (hashq-set! %gexp-compilers + (gexp-compiler-type compiler) compiler)) (define (lookup-compiler object) "Search for a compiler for OBJECT. Upon success, return the three argument procedure to lower it; otherwise return #f." - (any (match-lambda - (($ predicate lower) - (and (predicate object) lower))) - %gexp-compilers)) + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-lower)) (define (lookup-expander object) "Search for an expander for OBJECT. Upon success, return the three argument procedure to expand it; otherwise return #f." - (or (any (match-lambda - (($ predicate _ expand) - (and (predicate object) expand))) - %gexp-compilers) - default-expander)) + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-expand)) (define* (lower-object obj #:optional (system (%current-system)) @@ -197,19 +193,19 @@ The more elaborate form allows you to specify an expander: expander => (lambda (param drv output) ...)) The expander specifies how an object is converted to its sexp representation." - ((_ (name (param predicate) system target) body ...) - (define-gexp-compiler name predicate + ((_ (name (param record-type) system target) body ...) + (define-gexp-compiler name record-type compiler => (lambda (param system target) body ...) expander => default-expander)) - ((_ name predicate + ((_ name record-type compiler => compile expander => expand) (begin (define name - (gexp-compiler predicate compile expand)) + (gexp-compiler record-type compile expand)) (register-compiler! name))))) -(define-gexp-compiler (derivation-compiler (drv derivation?) system target) +(define-gexp-compiler (derivation-compiler (drv ) system target) ;; Derivations are the lowest-level representation, so this is the identity ;; compiler. (with-monad %store-monad @@ -275,7 +271,7 @@ This is the declarative counterpart of the 'interned-file' monadic procedure." 'system-error' exception is raised if FILE could not be found." (force (%local-file-absolute-file-name file))) -(define-gexp-compiler (local-file-compiler (file local-file?) system target) +(define-gexp-compiler (local-file-compiler (file ) system target) ;; "Compile" FILE by adding it to the store. (match file (($ file (= force absolute) name recursive? select?) @@ -302,7 +298,7 @@ This is the declarative counterpart of 'text-file'." ;; them in a declarative context. (%plain-file name content '())) -(define-gexp-compiler (plain-file-compiler (file plain-file?) system target) +(define-gexp-compiler (plain-file-compiler (file ) system target) ;; "Compile" FILE by adding it to the store. (match file (($ name content references) @@ -324,7 +320,7 @@ to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." (%computed-file name gexp options)) -(define-gexp-compiler (computed-file-compiler (file computed-file?) +(define-gexp-compiler (computed-file-compiler (file ) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. @@ -346,7 +342,7 @@ GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." (%program-file name gexp guile)) -(define-gexp-compiler (program-file-compiler (file program-file?) +(define-gexp-compiler (program-file-compiler (file ) system target) ;; Compile FILE by returning a derivation that builds the script. (match file @@ -366,7 +362,7 @@ This is the declarative counterpart of 'gexp->script'." This is the declarative counterpart of 'gexp->file'." (%scheme-file name gexp)) -(define-gexp-compiler (scheme-file-compiler (file scheme-file?) +(define-gexp-compiler (scheme-file-compiler (file ) system target) ;; Compile FILE by returning a derivation that builds the file. (match file @@ -385,7 +381,7 @@ This is the declarative counterpart of 'gexp->file'." SUFFIX." (%file-append base suffix)) -(define-gexp-compiler file-append-compiler file-append? +(define-gexp-compiler file-append-compiler compiler => (lambda (obj system target) (match obj (($ base _) diff --git a/guix/packages.scm b/guix/packages.scm index afbafc70a7..2264c5acef 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1179,7 +1179,7 @@ cross-compilation target triplet." (define package->cross-derivation (store-lift package-cross-derivation)) -(define-gexp-compiler (package-compiler (package package?) system target) +(define-gexp-compiler (package-compiler (package ) system target) ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for ;; TARGET. This is used when referring to a package from within a gexp. (if target @@ -1210,7 +1210,7 @@ cross-compilation target triplet." #:modules modules #:guile-for-build guile))))) -(define-gexp-compiler (origin-compiler (origin origin?) system target) +(define-gexp-compiler (origin-compiler (origin ) system target) ;; Compile ORIGIN to a derivation for SYSTEM. This is used when referring ;; to an origin from within a gexp. (origin->derivation origin system)) -- cgit v1.2.3 From e465d9e19087ab150f7e31f21c09e4a147b93b36 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 20 Sep 2016 17:51:39 +0900 Subject: ui: Do not shadow '_' where it's used as a literal syntax match. Fixes compilation with Guile 2.1. Reported by Mu Lei. * guix/ui.scm (report-load-error) (warn-about-load-error, read/eval-package-expression): Use 'rest' instead of '_' as the pattern variable name. * gnu/packages.scm (%find-package): Likewise. * guix/scripts/build.scm (transform-package-inputs): Likewise. * guix/scripts/hash.scm (guix-hash): Likewise. * guix/scripts/import/gnu.scm (%options, guix-import-gnu): Likewise. * guix/scripts/import/nix.scm (guix-import-nix): Likewise. * guix/scripts/offload.scm (build-machines): Likewise. * guix/scripts/refresh.scm (%options): Likewise. * guix/scripts/substitute.scm (narinfo-signature->canonical-sexp): Likewise. --- gnu/packages.scm | 2 +- guix/scripts/build.scm | 2 +- guix/scripts/hash.scm | 2 +- guix/scripts/import/gnu.scm | 6 +++--- guix/scripts/import/nix.scm | 4 ++-- guix/scripts/offload.scm | 4 ++-- guix/scripts/refresh.scm | 2 +- guix/scripts/substitute.scm | 2 +- guix/ui.scm | 8 ++++---- 9 files changed, 16 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/gnu/packages.scm b/gnu/packages.scm index 5d60423a3a..f55c294a18 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -313,7 +313,7 @@ use NAME@VERSION instead~%"))) new) (#f pkg))) - (_ + (x (if version (leave (_ "~A: package not found for version ~a~%") name version) (if (not fallback?) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 86b95b4075..a9f649d2ee 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -195,7 +195,7 @@ of \"guile\"." ((old new) (cons (specification->package old) (specification->package new))) - (_ + (x (leave (_ "invalid replacement specification: ~s~%") spec)))) replacement-specs)) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index a57602ab51..a6eced92fb 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -149,5 +149,5 @@ and 'hexadecimal' can be used as well).\n")) (lambda args (leave (_ "~a~%") (strerror (system-error-errno args)))))) - (_ + (x (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/import/gnu.scm b/guix/scripts/import/gnu.scm index 92bd8305ea..66861f5837 100644 --- a/guix/scripts/import/gnu.scm +++ b/guix/scripts/import/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès +;;; Copyright © 2014, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,7 +68,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) ((or "interactive" "always" "never") (alist-cons 'key-download (string->symbol arg) result)) - (_ + (x (leave (_ "unsupported policy: ~a~%") arg))))) %standard-import-options)) @@ -99,7 +99,7 @@ Return a package declaration template for PACKAGE, a GNU package.\n")) (with-error-handling (gnu->guix-package name #:key-download (assoc-ref opts 'key-download)))) - (_ + (x (leave (_ "wrong number of arguments~%")))))) ;;; gnu.scm ends here diff --git a/guix/scripts/import/nix.scm b/guix/scripts/import/nix.scm index dba053b313..05e6e4b85d 100644 --- a/guix/scripts/import/nix.scm +++ b/guix/scripts/import/nix.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2012, 2013, 2016 Ludovic Courtès ;;; Copyright © 2014 David Thompson ;;; ;;; This file is part of GNU Guix. @@ -86,5 +86,5 @@ Import and convert the Nix expression ATTRIBUTE of NIXPKGS.\n")) (format #t ";; converted from ~a:~a~%~%" (location-file loc) (location-line loc)) expr)) - (_ + (x (leave (_ "wrong number of arguments~%")))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 7db0c9d610..b278f1e313 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -118,7 +118,7 @@ determined." (primitive-load file)))) (lambda args (match args - (('system-error . _) + (('system-error . rest) (let ((err (system-error-errno args))) ;; Silently ignore missing file since this is a common case. (if (= ENOENT err) @@ -129,7 +129,7 @@ determined." (let ((loc (source-properties->location properties))) (leave (_ "~a: ~a~%") (location->string loc) message))) - (_ + (x (leave (_ "failed to load machine file '~a': ~s~%") file args)))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index b00ac98c96..84e2a8f2a6 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -105,7 +105,7 @@ ((or "interactive" "always" "never") (alist-cons 'key-download (string->symbol arg) result)) - (_ + (x (leave (_ "unsupported policy: ~a~%") arg))))) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8827c45fb8..21e0613a8a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -300,7 +300,7 @@ Otherwise return #f." (define (narinfo-signature->canonical-sexp str) "Return the value of a narinfo's 'Signature' field as a canonical sexp." (match (string-split str #\;) - ((version _ sig) + ((version host-name sig) (let ((maybe-number (string->number version))) (cond ((not (number? maybe-number)) (leave (_ "signature version must be a number: ~s~%") diff --git a/guix/ui.scm b/guix/ui.scm index 452d16308e..eb85df3b18 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -247,7 +247,7 @@ messages." "Report the failure to load FILE, a user-provided Scheme file. ARGS is the list of arguments received by the 'throw' handler." (match args - (('system-error . _) + (('system-error . rest) (let ((err (system-error-errno args))) (report-error (_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) @@ -264,7 +264,7 @@ ARGS is the list of arguments received by the 'throw' handler." "Report the failure to load FILE, a user-provided Scheme file, without exiting. ARGS is the list of arguments received by the 'throw' handler." (match args - (('system-error . _) + (('system-error . rest) (let ((err (system-error-errno args))) (warning (_ "failed to load '~a': ~a~%") file (strerror err)))) (('syntax-error proc message properties form . rest) @@ -409,7 +409,7 @@ interpreted." ("ZB" (expt 10 21)) ("YB" (expt 10 24)) ("" 1) - (_ + (x (leave (_ "unknown unit: ~a~%") unit))))))) (define (call-with-error-handling thunk) @@ -535,7 +535,7 @@ similar." error." (match (read/eval str) ((? package? p) p) - (_ + (x (leave (_ "expression ~s does not evaluate to a package~%") str)))) -- cgit v1.2.3 From 0f65f54ebd76324653fd5506a7dab42ee44d9255 Mon Sep 17 00:00:00 2001 From: Carlos Sánchez de La Lama Date: Wed, 14 Sep 2016 16:13:24 +0200 Subject: system: grub.cfg uses correct file names when store is not in root partition. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by csanchezdll@gmail.com (Carlos Sánchez de La Lama). * guix/scripts/system.scm (previous-grub-entries): Get the initrd file name from PARAMS. * gnu/system.scm (operating-system-grub.cfg): Use 'operating-system-initrd-file' to retrieve the initrd file name. * gnu/system/grub.scm (strip-mount-point): New procedure. (grub-configuration-file)[entry->gexp]: Call 'strip-mount-point' for LINUX and INITRD. Co-authored-by: Ludovic Courtès --- gnu/system.scm | 3 ++- gnu/system/grub.scm | 30 +++++++++++++++++++++++------- guix/scripts/system.scm | 9 +++++---- 3 files changed, 30 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/gnu/system.scm b/gnu/system.scm index bf79bf1c27..38ae8f1771 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -727,6 +727,7 @@ listed in OS. The C library expects to find it under (store-fs -> (operating-system-store-file-system os)) (label -> (kernel->grub-label (operating-system-kernel os))) (kernel -> (operating-system-kernel-file os)) + (initrd (operating-system-initrd-file os)) (root-device -> (if (eq? 'uuid (file-system-title root-fs)) (uuid->string (file-system-device root-fs)) (file-system-device root-fs))) @@ -739,7 +740,7 @@ listed in OS. The C library expects to find it under #~(string-append "--load=" #$system "/boot") (operating-system-kernel-arguments os))) - (initrd (file-append system "/initrd")))))) + (initrd initrd))))) (grub-configuration-file (operating-system-bootloader os) store-fs entries #:old-entries old-entries))) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index 4592747083..3d294284e4 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -62,6 +62,17 @@ ;;; ;;; Code: +(define (strip-mount-point fs file) + "Strip the mount point of FS from FILE, which is a gexp or other lowerable +object denoting a file name." + (let ((mount-point (file-system-mount-point fs))) + (if (string=? mount-point "/") + file + #~(let ((file #$file)) + (if (string-prefix? #$mount-point file) + (substring #$file #$(string-length mount-point)) + file))))) + (define-record-type* grub-image make-grub-image grub-image? @@ -183,7 +194,8 @@ the store is. SYSTEM must be the target system string---e.g., (symbol->string (assoc-ref colors 'bg))))) (define font-file - #~(string-append #$grub "/share/grub/unicode.pf2")) + (strip-mount-point root-fs + (file-append grub "/share/grub/unicode.pf2"))) (mlet* %store-monad ((image (grub-background-image config))) (return (and image @@ -209,7 +221,7 @@ fi~%" #$(grub-root-search root-fs font-file) #$font-file - #$image + #$(strip-mount-point root-fs image) #$(theme-colors grub-theme-color-normal) #$(theme-colors grub-theme-color-highlight)))))) @@ -249,15 +261,19 @@ corresponding to old generations of the system." (define entry->gexp (match-lambda (($ label linux arguments initrd) - #~(format port "menuentry ~s { + ;; Use the right file names for LINUX and STORE-FS in case STORE-FS is + ;; not the "/" file system. + (let ((linux (strip-mount-point store-fs linux)) + (initrd (strip-mount-point store-fs initrd))) + #~(format port "menuentry ~s { ~a linux ~a ~a initrd ~a }~%" - #$label - #$(grub-root-search store-fs linux) - #$linux (string-join (list #$@arguments)) - #$initrd)))) + #$label + #$(grub-root-search store-fs linux) + #$linux (string-join (list #$@arguments)) + #$initrd))))) (mlet %store-monad ((sugar (eye-candy config store-fs system #~port))) (define builder diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 953c6243ed..a2cd97ac1f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -383,7 +383,8 @@ it atomically, and then run OS's activation script." (uuid->string root) root)) (kernel (boot-parameters-kernel params)) - (kernel-arguments (boot-parameters-kernel-arguments params))) + (kernel-arguments (boot-parameters-kernel-arguments params)) + (initrd (boot-parameters-initrd params))) (menu-entry (label (string-append label " (#" (number->string number) ", " @@ -391,10 +392,10 @@ it atomically, and then run OS's activation script." (linux kernel) (linux-arguments (cons* (string-append "--root=" root-device) - #~(string-append "--system=" #$system) - #~(string-append "--load=" #$system "/boot") + (string-append "--system=" system) + (string-append "--load=" system "/boot") kernel-arguments)) - (initrd #~(string-append #$system "/initrd")))))) + (initrd initrd))))) (let* ((numbers (generation-numbers profile)) (systems (map (cut generation-file-name profile <>) -- cgit v1.2.3 From 2c9f4786c967d2e5090cef2a18bebf8d840e9428 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 22 Sep 2016 22:25:12 +0200 Subject: profiles: manifest-lookup-package: Optionally match version prefix. * guix/profiles.scm (manifest-lookup-package): Optionally filter store item matches by version prefix. --- guix/profiles.scm | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 4a2ba1c2f4..78deeb7977 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -472,21 +472,30 @@ replace it." (cons (gexp-input thing output) deps))) (manifest-entries manifest))) -(define (manifest-lookup-package manifest name) +(define* (manifest-lookup-package manifest name #:optional version) "Return as a monadic value the first package or store path referenced by -MANIFEST that named NAME, or #f if not found." +MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f +if not found." ;; Return as a monadic value the package or store path referenced by the ;; manifest ENTRY, or #f if not referenced. (define (entry-lookup-package entry) (define (find-among-inputs inputs) (find (lambda (input) (and (package? input) - (equal? name (package-name input)))) + (equal? name (package-name input)) + (if version + (string-prefix? version (package-version input)) + #t))) inputs)) (define (find-among-store-items items) (find (lambda (item) - (equal? name (package-name->name+version - (store-path-package-name item)))) + (let-values (((pkg-name pkg-version) + (package-name->name+version + (store-path-package-name item)))) + (and (equal? name pkg-name) + (if version + (string-prefix? version pkg-version) + #t)))) items)) ;; TODO: Factorize. -- cgit v1.2.3 From 7ddc178093a4e705c9221ef2758eeeb9af7284f8 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 22 Sep 2016 22:27:06 +0200 Subject: profiles: Build GTK+ input module cache. * guix/profiles.scm (gtk-im-modules): New procedure. (%default-profile-hooks): Add it. --- guix/profiles.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 78deeb7977..e7319a8a10 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Sou Bunnbu +;;; Copyright © 2016 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -723,6 +724,66 @@ creates the GTK+ 'icon-theme.cache' file for each theme." #:substitutable? #f) (return #f)))) +(define (gtk-im-modules manifest) + "Return a derivation that builds the cache files for input method modules +for both major versions of GTK+." + + (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3")) + (gtk+-2 (manifest-lookup-package manifest "gtk+" "2"))) + + (define (build gtk gtk-version) + (let ((major (string-take gtk-version 1))) + (with-imported-modules '((guix build utils) + (guix build union) + (guix build profiles) + (guix search-paths) + (guix records)) + #~(begin + (use-modules (guix build utils) + (guix build union) + (guix build profiles) + (ice-9 popen) + (srfi srfi-1) + (srfi srfi-26)) + + (let* ((prefix (string-append "/lib/gtk-" #$major ".0/" + #$gtk-version)) + (query (string-append #$gtk "/bin/gtk-query-immodules-" + #$major ".0")) + (destdir (string-append #$output prefix)) + (moddirs (cons (string-append #$gtk prefix "/immodules") + (filter file-exists? + (map (cut string-append <> prefix "/immodules") + '#$(manifest-inputs manifest))))) + (modules (append-map (cut find-files <> "\\.so$") + moddirs))) + + ;; Generate a new immodules cache file. + (mkdir-p (string-append #$output prefix)) + (let ((pipe (apply open-pipe* OPEN_READ query modules)) + (outfile (string-append #$output prefix + "/immodules-gtk" #$major ".cache"))) + (dynamic-wind + (const #t) + (lambda () + (call-with-output-file outfile + (lambda (out) + (while (not (eof-object? (peek-char pipe))) + (write-char (read-char pipe) out)))) + #t) + (lambda () + (close-pipe pipe))))))))) + + ;; Don't run the hook when there's nothing to do. + (let ((gexp #~(begin + #$(if gtk+ (build gtk+ "3.0.0") #t) + #$(if gtk+-2 (build gtk+-2 "2.10.0") #t)))) + (if (or gtk+ gtk+-2) + (gexp->derivation "gtk-im-modules" gexp + #:local-build? #t + #:substitutable? #f) + (return #f))))) + (define (xdg-desktop-database manifest) "Return a derivation that builds the @file{mimeinfo.cache} database from desktop files. It's used to query what applications can handle a given @@ -844,6 +905,7 @@ files for the truetype fonts of the @var{manifest} entries." ghc-package-cache-file ca-certificate-bundle gtk-icon-themes + gtk-im-modules xdg-desktop-database xdg-mime-database)) -- cgit v1.2.3 From 3c185b24f593c982aeb33996324fa6878c6ed21b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Sep 2016 11:20:40 +0200 Subject: Add missing exports. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Taylan Ulrich Bayırlı/Kammer at . * gnu/system/file-systems.scm (%tty-gid): Export. * guix/build-system/python.scm (default-python, default-python2): Export. --- gnu/system/file-systems.scm | 1 + guix/build-system/python.scm | 2 ++ 2 files changed, 3 insertions(+) (limited to 'guix') diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 0dc472e3c7..b51d57f079 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -47,6 +47,7 @@ %binary-format-file-system %shared-memory-file-system %pseudo-terminal-file-system + %tty-gid %immutable-store %control-groups %elogind-file-systems diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 705943eb73..adeceb4a89 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -33,6 +33,8 @@ #:export (%python-build-system-modules package-with-python2 strip-python2-variant + default-python + default-python2 python-build python-build-system pypi-uri)) -- cgit v1.2.3 From 8a54c0ec694ad6e22b155d167552b8fd0914e82d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 27 Sep 2016 11:44:56 +0200 Subject: guix build: Gracefully handle packages without source for '-S'. Fixes . Reported by Ricardo Wurmus . * guix/scripts/build.scm (options->derivations): Gracefully handle (package-source p) = #f. --- guix/scripts/build.scm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index a9f649d2ee..b64138ec0e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -595,8 +595,16 @@ build." (#f (list (package->derivation store p system))) (#t - (let ((s (package-source p))) - (list (package-source-derivation store s)))) + (match (package-source p) + (#f + (format (current-error-port) + (_ "~a: warning: \ +package '~a' has no source~%") + (location->string (package-location p)) + (package-name p)) + '()) + (s + (list (package-source-derivation store s))))) (proc (map (cut package-source-derivation store <>) (proc p)))))) -- cgit v1.2.3 From fbe9c1012820ab72f022a6ec958c35b431ae7a74 Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:25:31 +0200 Subject: import: Reorder imports in (guix import utils). * guix/import/utils.scm (define-module): Reorder imports alphabetically. --- guix/import/utils.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 93cd0f0fa5..4ec3b67f4e 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -17,14 +17,15 @@ ;;; along with GNU Guix. If not, see . (define-module (guix import utils) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-1) - #:use-module (guix hash) #:use-module (guix base32) + #:use-module ((guix build download) #:prefix build:) + #:use-module (guix hash) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix utils) - #:use-module ((guix build download) #:prefix build:) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (json) + #:use-module (srfi srfi-1) #:export (factorize-uri hash-table->alist -- cgit v1.2.3 From 263ac57fc22680395453bed34eaae8e63ea85bbb Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:30:17 +0200 Subject: import: Move string->license to importers. * guix/import/gem.scm (string->license): Move from (guix import utils). * guix/import/pypi.scm (string->license): Move from (guix import utils). --- guix/import/gem.scm | 13 ++++++++++++- guix/import/pypi.scm | 13 ++++++++++++- guix/import/utils.scm | 9 --------- 3 files changed, 24 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/import/gem.scm b/guix/import/gem.scm index fc06b0d748..3d0c190656 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -29,7 +29,7 @@ #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module (guix licenses) + #:use-module ((guix licenses) #:prefix license:) #:use-module (guix base32) #:use-module (guix build-system ruby) #:export (gem->guix-package @@ -155,6 +155,17 @@ package on RubyGems." ;; e.g. "https://rubygems.org/downloads/hashery-2.1.1.gem" (substring source-url 31 (string-rindex source-url #\-)))) +(define (string->license str) + "Convert the string STR into a license object." + (match str + ("GNU LGPL" license:lgpl2.0) + ("GPL" license:gpl3) + ((or "BSD" "BSD License") license:bsd-3) + ((or "MIT" "MIT license" "Expat license") license:expat) + ("Public domain" license:public-domain) + ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) + (_ #f))) + (define (gem-package? package) "Return true if PACKAGE is a gem package from RubyGems." diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 343445aa22..8aeffb2326 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -41,7 +41,7 @@ #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module (guix licenses) + #:use-module ((guix licenses) #:prefix license:) #:use-module (guix build-system python) #:use-module (gnu packages python) #:export (guix-package->pypi-name @@ -294,6 +294,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (make-pypi-sexp name version release wheel home-page synopsis description license)))))) +(define (string->license str) + "Convert the string STR into a license object." + (match str + ("GNU LGPL" license:lgpl2.0) + ("GPL" license:gpl3) + ((or "BSD" "BSD License") license:bsd-3) + ((or "MIT" "MIT license" "Expat license") license:expat) + ("Public domain" license:public-domain) + ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) + (_ #f))) + (define (pypi-package? package) "Return true if PACKAGE is a Python package from PyPI." diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 4ec3b67f4e..69e623a67f 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -35,7 +35,6 @@ url-fetch guix-hash-url - string->license license->symbol snake-case @@ -110,15 +109,7 @@ recursively apply the procedure to the sub-list." "Return the hash of FILENAME in nix-base32 format." (bytevector->nix-base32-string (file-sha256 filename))) -(define (string->license str) - "Convert the string STR into a license object." (match str - ("GNU LGPL" license:lgpl2.0) - ("GPL" license:gpl3) - ((or "BSD" "BSD License") license:bsd-3) - ((or "MIT" "MIT license" "Expat license") license:expat) - ("Public domain" license:public-domain) - ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) (_ #f))) (define (license->symbol license) -- cgit v1.2.3 From 59b2034787909cf7efa4e8d672a815b466d7d09d Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:33:46 +0200 Subject: import: utils: Add spdx-string->license. * guix/import/utils.scm (spdx-string->license): New variable. * guix/licenses.scm (agpl1, fdl1.2+): New variables. --- guix/import/utils.scm | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/licenses.scm | 12 ++++++++- 2 files changed, 81 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 69e623a67f..ce0ba99fc0 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès +;;; Copyright © 2016 Jelle Licht ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ url-fetch guix-hash-url + spdx-string->license license->symbol snake-case @@ -109,7 +111,75 @@ recursively apply the procedure to the sub-list." "Return the hash of FILENAME in nix-base32 format." (bytevector->nix-base32-string (file-sha256 filename))) +(define (spdx-string->license str) + "Convert STR, a SPDX formatted license identifier, to a license object. + Return #f if STR does not match any known identifiers." + ;; https://spdx.org/licenses/ + ;; The psfl, gfl1.0, nmap, repoze + ;; licenses doesn't have SPDX identifiers (match str + ("AGPL-1.0" 'license:agpl-1.0) + ("AGPL-3.0" 'license:agpl-3.0) + ("Apache-1.1" 'license:asl1.1) + ("Apache-2.0" 'license:asl2.0) + ("BSL-1.0" 'license:boost1.0) + ("BSD-2-Clause-FreeBSD" 'license:bsd-2) + ("BSD-3-Clause" 'license:bsd-3) + ("BSD-4-Clause" 'license:bsd-4) + ("CC0-1.0" 'license:cc0) + ("CC-BY-2.0" 'license:cc-by2.0) + ("CC-BY-3.0" 'license:cc-by3.0) + ("CC-BY-SA-2.0" 'license:cc-by-sa2.0) + ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) + ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) + ("CDDL-1.0" 'license:cddl1.0) + ("CECILL-C" 'license:cecill-c) + ("Artistic-2.0" 'license:artistic2.0) + ("ClArtistic" 'license:clarified-artistic) + ("CPL-1.0" 'license:cpl1.0) + ("EPL-1.0" 'license:epl1.0) + ("MIT" 'license:expat) + ("FTL" 'license:freetype) + ("GFDL-1.1" 'license:fdl1.1+) + ("GFDL-1.2" 'license:fdl1.2+) + ("GFDL-1.3" 'license:fdl1.3+) + ("Giftware" 'license:giftware) + ("GPL-1.0" 'license:gpl1) + ("GPL-1.0+" 'license:gpl1+) + ("GPL-2.0" 'license:gpl2) + ("GPL-2.0+" 'license:gpl2+) + ("GPL-3.0" 'license:gpl3) + ("GPL-3.0+" 'license:gpl3+) + ("ISC" 'license:isc) + ("IJG" 'license:ijg) + ("Imlib2" 'license:imlib2) + ("IPA" 'license:ipa) + ("IPL-1.0" 'license:ibmpl1.0) + ("LGPL-2.0" 'license:lgpl2.0) + ("LGPL-2.0+" 'license:lgpl2.0+) + ("LGPL-2.1" 'license:lgpl2.1) + ("LGPL-2.1+" 'license:lgpl2.1+) + ("LGPL-3.0" 'license:lgpl3.0) + ("LGPL-3.0+" 'license:lgpl3.0+) + ("MPL-1.0" 'license:mpl1.0) + ("MPL-1.1" 'license:mpl1.1) + ("MPL-2.0" 'license:mpl2.0) + ("MS-PL" 'license:ms-pl) + ("NCSA" 'license:ncsa) + ("OpenSSL" 'license:openssl) + ("OLDAP-2.8" 'license:openldap2.8) + ("CUA-OPL-1.0" 'license:opl1.0) + ("QPL-1.0" 'license:qpl) + ("Ruby" 'license:ruby) + ("SGI-B-2.0" 'license:sgifreeb2.0) + ("OFL-1.1" 'license:silofl1.1) + ("Sleepycat" 'license:sleepycat) + ("TCL" 'license:tcl/tk) + ("Unlicense" 'license:unlicense) + ("Vim" 'license:vim) + ("X11" 'license:x11) + ("ZPL-2.1" 'license:zpl2.1) + ("Zlib" 'license:zlib) (_ #f))) (define (license->symbol license) diff --git a/guix/licenses.scm b/guix/licenses.scm index 265f048278..8a98b0960a 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -27,7 +27,7 @@ (define-module (guix licenses) #:use-module (srfi srfi-9) #:export (license? license-name license-uri license-comment - agpl3 agpl3+ + agpl1 agpl3 agpl3+ asl1.1 asl2.0 boost1.0 bsd-2 bsd-3 bsd-4 @@ -91,6 +91,11 @@ ;;; ;;; Code: +(define agpl1 + (license "AGPL 1" + "https://gnu.org/licenses/agpl.html" + "https://gnu.org/licenses/why-affero-gpl.html")) + (define agpl3 (license "AGPL 3" "https://gnu.org/licenses/agpl.html" @@ -271,6 +276,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.gnu.org/licenses/fdl-1.1" "https://www.gnu.org/licenses/license-list#FDL")) +(define fdl1.2+ + (license "FDL 1.2+" + "https://www.gnu.org/licenses/fdl-1.2" + "https://www.gnu.org/licenses/license-list#FDL")) + (define fdl1.3+ (license "FDL 1.3+" "https://www.gnu.org/licenses/fdl.html" -- cgit v1.2.3 From 11e296ef3092de1e5b659822d4dad4465abad34f Mon Sep 17 00:00:00 2001 From: David Craven Date: Thu, 22 Sep 2016 11:35:13 +0200 Subject: import: utils: Refactor license->symbol. * guix/import/utils.scm (license->symbol): Work for all licenses. * tests/import-utils.scm (license->symbol): Add test. --- guix/import/utils.scm | 14 +++++--------- tests/import-utils.scm | 5 +++++ 2 files changed, 10 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index ce0ba99fc0..e4059ca114 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht +;;; Copyright © 2016 David Craven ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,15 +186,10 @@ recursively apply the procedure to the sub-list." (define (license->symbol license) "Convert license to a symbol representing the variable the object is bound to in the (guix licenses) module, or #f if there is no such known license." - ;; TODO: Traverse list public variables in (guix licenses) instead so we - ;; don't have to maintain a list manualy. - (assoc-ref `((,license:lgpl2.0 . license:lgpl2.0) - (,license:gpl3 . license:gpl3) - (,license:bsd-3 . license:bsd-3) - (,license:expat . license:expat) - (,license:public-domain . license:public-domain) - (,license:asl2.0 . license:asl2.0)) - license)) + (define licenses + (module-map (lambda (sym var) `(,(variable-ref var) . ,sym)) + (resolve-interface '(guix licenses) #:prefix 'license:))) + (assoc-ref licenses license)) (define (snake-case str) "Return a downcased version of the string STR where underscores are replaced diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 3b11875c4a..8d44b9e0e2 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -20,6 +20,7 @@ (define-module (test-import-utils) #:use-module (guix tests) #:use-module (guix import utils) + #:use-module ((guix licenses) #:prefix license:) #:use-module (srfi srfi-64)) (test-begin "import-utils") @@ -33,4 +34,8 @@ "This package provides a function to establish world peace" (beautify-description "A function to establish world peace")) +(test-equal "license->symbol" + 'license:lgpl2.0 + (license->symbol license:lgpl2.0)) + (test-end "import-utils") -- cgit v1.2.3