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/build') 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 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/build') 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 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/build') 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