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 @@ (define-module (guix build syscalls) #: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 @@ (define* (read bv #:optional (offset 0)) ;;; (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 @@ (define-syntax-rule (restart-on-EINTR expr) (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 @@ (define mount 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 @@ (define umount #: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 @@ (define swapon (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 @@ (define swapoff (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 @@ (define mkdtemp! (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 @@ (define fdatasync "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 @@ (define statfs (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 @@ (define clone "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 @@ (define setns 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 @@ (define pivot-root (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 @@ (define bv ;; 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 @@ (define* (network-interface-names #:optional sock) (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 @@ (define (network-interface-flags socket 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 @@ (define (set-network-interface-flags socket name flags) ;; 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 @@ (define (set-network-interface-address socket name sockaddr) (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 @@ (define (network-interface-address socket 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) 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 @@ (define network-interfaces (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 @@ (define tcgetattr (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 @@ (define bv (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 @@ (define* (terminal-window-size #:optional (port (current-output-port))) "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