summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/python.scm2
-rw-r--r--guix/build/ant-build-system.scm2
-rw-r--r--guix/build/syscalls.scm180
-rw-r--r--guix/gexp.scm131
-rw-r--r--guix/gnupg.scm4
-rw-r--r--guix/import/gem.scm13
-rw-r--r--guix/import/pypi.scm13
-rw-r--r--guix/import/utils.scm104
-rw-r--r--guix/licenses.scm12
-rw-r--r--guix/modules.scm155
-rw-r--r--guix/packages.scm18
-rw-r--r--guix/profiles.scm111
-rw-r--r--guix/scripts/build.scm14
-rw-r--r--guix/scripts/hash.scm27
-rw-r--r--guix/scripts/import/gnu.scm6
-rw-r--r--guix/scripts/import/nix.scm4
-rw-r--r--guix/scripts/offload.scm4
-rw-r--r--guix/scripts/package.scm139
-rw-r--r--guix/scripts/refresh.scm2
-rwxr-xr-xguix/scripts/substitute.scm2
-rw-r--r--guix/scripts/system.scm9
-rw-r--r--guix/ui.scm12
22 files changed, 721 insertions, 243 deletions
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))
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)
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index c663899160..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,13 +282,14 @@ 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))))
+ ;; 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 ()
@@ -327,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"
@@ -400,18 +414,18 @@ may be a bitwise-or of the MS_* <sys/mount.h> 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))
@@ -425,8 +439,8 @@ error."
#:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
constants from <sys/mount.h>."
- (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))
@@ -450,8 +464,8 @@ constants from <sys/mount.h>."
(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))
@@ -461,8 +475,7 @@ constants from <sys/mount.h>."
(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))
@@ -498,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))
@@ -512,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))
@@ -565,9 +576,9 @@ fdatasync(2) on the underlying file descriptor."
(lambda (file)
"Return a <file-system> 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"
@@ -610,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))
@@ -631,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))
@@ -643,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))
@@ -716,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))))))
@@ -856,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.
@@ -896,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
@@ -926,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"
@@ -942,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"
@@ -957,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"
@@ -1075,9 +1085,10 @@ return the list of resulting <interface> objects."
(lambda ()
"Return a list of <interface> 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)))
@@ -1180,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 <termios> 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"
@@ -1205,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))
@@ -1237,10 +1246,9 @@ produced by 'tcsetattr-action'; see tcsetattr(3) for details."
"Return a <window-size> 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"
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 302879fb42..05178a5ecc 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
@@ -126,26 +131,41 @@
;; Compiler for a type of objects that may be introduced in a gexp.
(define-record-type <gexp-compiler>
- (gexp-compiler predicate lower)
+ (gexp-compiler type lower expand)
gexp-compiler?
- (predicate gexp-compiler-predicate)
- (lower gexp-compiler-lower))
+ (type gexp-compiler-type) ;record type descriptor
+ (lower gexp-compiler-lower)
+ (expand gexp-compiler-expand)) ;#f | DRV -> sexp
(define %gexp-compilers
- ;; List of <gexp-compiler>.
- '())
+ ;; 'eq?' mapping of record type descriptor to <gexp-compiler>.
+ (make-hash-table 20))
+
+(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)))
+ (hashq-set! %gexp-compilers
+ (gexp-compiler-type compiler) compiler))
(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
- (($ <gexp-compiler> 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."
+ (and=> (hashq-ref %gexp-compilers (struct-vtable object))
+ gexp-compiler-expand))
(define* (lower-object obj
#:optional (system (%current-system))
@@ -157,21 +177,35 @@ 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-gexp-compiler (derivation-compiler (drv derivation?) system target)
+(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 record-type) system target) body ...)
+ (define-gexp-compiler name record-type
+ compiler => (lambda (param system target) body ...)
+ expander => default-expander))
+ ((_ name record-type
+ compiler => compile
+ expander => expand)
+ (begin
+ (define name
+ (gexp-compiler record-type 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
;; compiler.
(with-monad %store-monad
@@ -237,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 <local-file>) system target)
;; "Compile" FILE by adding it to the store.
(match file
(($ <local-file> file (= force absolute) name recursive? select?)
@@ -264,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 <plain-file>) system target)
;; "Compile" FILE by adding it to the store.
(match file
(($ <plain-file> name content references)
@@ -286,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 <computed-file>)
system target)
;; Compile FILE by returning a derivation whose build expression is its
;; gexp.
@@ -308,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 <program-file>)
system target)
;; Compile FILE by returning a derivation that builds the script.
(match file
@@ -328,13 +362,37 @@ 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 <scheme-file>)
system target)
;; Compile FILE by returning a derivation that builds the file.
(match file
(($ <scheme-file> name gexp)
(gexp->file name gexp))))
+;; Appending SUFFIX to BASE's output file name.
+(define-record-type <file-append>
+ (%file-append base suffix)
+ file-append?
+ (base file-append-base) ;<package> | <derivation> | ...
+ (suffix file-append-suffix)) ;list of strings
+
+(define (file-append base . suffix)
+ "Return a <file-append> 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
+ (($ <file-append> base _)
+ (lower-object base system #:target target))))
+ expander => (lambda (obj lowered output)
+ (match obj
+ (($ <file-append> base suffix)
+ (let* ((expand (lookup-expander base))
+ (base (expand base lowered output)))
+ (string-append base (string-concatenate suffix)))))))
+
;;;
;;; Inputs & outputs.
@@ -429,8 +487,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
@@ -706,15 +762,12 @@ and in the current monad setting (system type, etc.)"
(or n? native?)))
refs)))
(($ <gexp-input> (? 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)))))
(($ <gexp-input> x)
(return x))
(x
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 <ludo@gnu.org>
+;;; Copyright © 2010, 2011, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;;
;;; 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
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 93cd0f0fa5..e4059ca114 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -1,5 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;; Copyright © 2016 David Craven <david@craven.ch>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,14 +19,15 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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
@@ -34,7 +37,7 @@
url-fetch
guix-hash-url
- string->license
+ spdx-string->license
license->symbol
snake-case
@@ -109,29 +112,84 @@ 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."
+(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
- ("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)
+ ("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)
"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/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"
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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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/guix/packages.scm b/guix/packages.scm
index 52204b1e09..88b21f709d 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -84,6 +84,8 @@
package-location
hidden-package
hidden-package?
+ package-superseded
+ deprecated-package
package-field-location
package-direct-sources
@@ -307,6 +309,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."
@@ -1168,7 +1182,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 <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
@@ -1199,7 +1213,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 <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))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 169c700f19..d162f6241b 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -67,6 +68,9 @@
manifest-pattern
manifest-pattern?
+ manifest-pattern-name
+ manifest-pattern-version
+ manifest-pattern-output
manifest-remove
manifest-add
@@ -78,6 +82,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 +390,28 @@ no match.."
(remove manifest-transaction-remove ; list of <manifest-pattern>
(default '())))
+(define (manifest-transaction-install-entry entry transaction)
+ "Augment TRANSACTION's set of installed packages with ENTRY, a
+<manifest-entry>."
+ (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
+ (($ <manifest-transaction> () ()) #t)
+ (($ <manifest-transaction> _ _) #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 +453,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)
@@ -444,21 +473,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.
@@ -695,6 +733,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
@@ -816,6 +914,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))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 86b95b4075..b64138ec0e 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))
@@ -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))))))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index d44095377b..a6eced92fb 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -49,6 +50,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 (_ "
-r, --recursive compute the hash on FILE recursively"))
@@ -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))))
@@ -134,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 <ludo@gnu.org>
+;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;;
;;; 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/package.scm b/guix/scripts/package.scm
index fd42cdb36e..b87aee0be9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -261,19 +261,46 @@ 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 (transaction-upgrade-entry entry transaction)
+ "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a
+<manifest-entry>."
+ (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
+ (($ <manifest-entry> name version output (? string? path))
+ (match (vhash-assoc name (find-newest-available-packages))
+ ((_ candidate-version pkg . rest)
+ (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)))))
;;;
@@ -553,24 +580,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 (match-lambda
- (($ <manifest-entry> 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))
- (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
@@ -587,23 +610,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
@@ -814,16 +843,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/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/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 <>)
diff --git a/guix/ui.scm b/guix/ui.scm
index 906b349845..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))))
@@ -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.
generated by cgit v1.2.3 (git 2.25.4) at 2024-11-09 01:41:11 +0000