nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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'.
This commit is contained in:
Ludovic Courtès 2016-09-06 09:17:57 +02:00
parent fea1422e27
commit 26ffb69399
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 92 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

177
guix/build/syscalls.scm
View File

@ -24,12 +24,12 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-11)
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:export (errno #:export (MS_RDONLY
MS_RDONLY
MS_NOSUID MS_NOSUID
MS_NODEV MS_NODEV
MS_NOEXEC MS_NOEXEC
@ -282,14 +282,14 @@ given TYPES. READ uses WRAP-FIELDS to return its value."
;;; ;;;
(define %libc-errno-pointer (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 (let ((errno-loc (false-if-exception
(dynamic-func "__errno_location" (dynamic-link))))) (dynamic-func "__errno_location" (dynamic-link)))))
(and errno-loc (and errno-loc
(let ((proc (pointer->procedure '* errno-loc '()))) (let ((proc (pointer->procedure '* errno-loc '())))
(proc))))) (proc)))))
(define errno (define errno ;for Guile < 2.0.12
(if %libc-errno-pointer (if %libc-errno-pointer
(let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int)))) (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
(lambda () (lambda ()
@ -328,13 +328,26 @@ given TYPES. READ uses WRAP-FIELDS to return its value."
(call-with-restart-on-EINTR (lambda () expr))) (call-with-restart-on-EINTR (lambda () expr)))
(define (syscall->procedure return-type name argument-types) (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 If an error occurs while creating the binding, defer the error report until
the returned procedure is called." the returned procedure is called."
(catch #t (catch #t
(lambda () (lambda ()
(let ((ptr (dynamic-func name (dynamic-link)))) (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 args
(lambda _ (lambda _
(error (format #f "~a: syscall->procedure failed: ~s" (error (format #f "~a: syscall->procedure failed: ~s"
@ -401,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 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 UPDATE-MTAB? is true, update /etc/mtab. Raise a 'system-error' exception on
error." error."
(let ((ret (proc (if source (let-values (((ret err)
(string->pointer source) (proc (if source
%null-pointer) (string->pointer source)
(string->pointer target) %null-pointer)
(if type (string->pointer target)
(string->pointer type) (if type
%null-pointer) (string->pointer type)
flags %null-pointer)
(if options flags
(string->pointer options) (if options
%null-pointer))) (string->pointer options)
(err (errno))) %null-pointer))))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "mount" "mount ~S on ~S: ~A" (throw 'system-error "mount" "mount ~S on ~S: ~A"
(list source target (strerror err)) (list source target (strerror err))
@ -426,8 +439,8 @@ error."
#:key (update-mtab? #f)) #:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_* "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
constants from <sys/mount.h>." constants from <sys/mount.h>."
(let ((ret (proc (string->pointer target) flags)) (let-values (((ret err)
(err (errno))) (proc (string->pointer target) flags)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "umount" "~S: ~A" (throw 'system-error "umount" "~S: ~A"
(list target (strerror err)) (list target (strerror err))
@ -451,8 +464,8 @@ constants from <sys/mount.h>."
(let ((proc (syscall->procedure int "swapon" (list '* int)))) (let ((proc (syscall->procedure int "swapon" (list '* int))))
(lambda* (device #:optional (flags 0)) (lambda* (device #:optional (flags 0))
"Use the block special device at DEVICE for swapping." "Use the block special device at DEVICE for swapping."
(let ((ret (proc (string->pointer device) flags)) (let-values (((ret err)
(err (errno))) (proc (string->pointer device) flags)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "swapon" "~S: ~A" (throw 'system-error "swapon" "~S: ~A"
(list device (strerror err)) (list device (strerror err))
@ -462,8 +475,7 @@ constants from <sys/mount.h>."
(let ((proc (syscall->procedure int "swapoff" '(*)))) (let ((proc (syscall->procedure int "swapoff" '(*))))
(lambda (device) (lambda (device)
"Stop using block special device DEVICE for swapping." "Stop using block special device DEVICE for swapping."
(let ((ret (proc (string->pointer device))) (let-values (((ret err) (proc (string->pointer device))))
(err (errno)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "swapoff" "~S: ~A" (throw 'system-error "swapoff" "~S: ~A"
(list device (strerror err)) (list device (strerror err))
@ -499,8 +511,7 @@ user-land process."
(lambda (tmpl) (lambda (tmpl)
"Create a new unique directory in the file system using the template "Create a new unique directory in the file system using the template
string TMPL and return its file name. TMPL must end with 'XXXXXX'." string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(let ((result (proc (string->pointer tmpl))) (let-values (((result err) (proc (string->pointer tmpl))))
(err (errno)))
(when (null-pointer? result) (when (null-pointer? result)
(throw 'system-error "mkdtemp!" "~S: ~A" (throw 'system-error "mkdtemp!" "~S: ~A"
(list tmpl (strerror err)) (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 "Flush buffered output of PORT, an output file port, and then call
fdatasync(2) on the underlying file descriptor." fdatasync(2) on the underlying file descriptor."
(force-output port) (force-output port)
(let* ((fd (fileno port)) (let*-values (((fd) (fileno port))
(ret (proc fd)) ((ret err) (proc fd)))
(err (errno)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "fdatasync" "~S: ~A" (throw 'system-error "fdatasync" "~S: ~A"
(list fd (strerror err)) (list fd (strerror err))
@ -566,9 +576,9 @@ fdatasync(2) on the underlying file descriptor."
(lambda (file) (lambda (file)
"Return a <file-system> data structure describing the file system "Return a <file-system> data structure describing the file system
mounted at FILE." mounted at FILE."
(let* ((stat (make-bytevector sizeof-statfs)) (let*-values (((stat) (make-bytevector sizeof-statfs))
(ret (proc (string->pointer file) (bytevector->pointer stat))) ((ret err) (proc (string->pointer file)
(err (errno))) (bytevector->pointer stat))))
(if (zero? ret) (if (zero? ret)
(read-statfs stat) (read-statfs stat)
(throw 'system-error "statfs" "~A: ~A" (throw 'system-error "statfs" "~A: ~A"
@ -611,11 +621,11 @@ mounted at FILE."
"Create a new child process by duplicating the current parent process. "Create a new child process by duplicating the current parent process.
Unlike the fork system call, clone accepts FLAGS that specify which resources Unlike the fork system call, clone accepts FLAGS that specify which resources
are shared between the parent and child processes." are shared between the parent and child processes."
(let ((ret (proc syscall-id flags (let-values (((ret err)
%null-pointer ;child stack (proc syscall-id flags
%null-pointer %null-pointer ;ptid & ctid %null-pointer ;child stack
%null-pointer)) ;unused %null-pointer %null-pointer ;ptid & ctid
(err (errno))) %null-pointer))) ;unused
(if (= ret -1) (if (= ret -1)
(throw 'system-error "clone" "~d: ~A" (throw 'system-error "clone" "~d: ~A"
(list flags (strerror err)) (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 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 which type of namespace the current process may be reassociated with, or 0 if
there is no such limitation." there is no such limitation."
(let ((ret (proc fdes nstype)) (let-values (((ret err) (proc fdes nstype)))
(err (errno)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "setns" "~d ~d: ~A" (throw 'system-error "setns" "~d ~d: ~A"
(list fdes nstype (strerror err)) (list fdes nstype (strerror err))
@ -644,9 +653,9 @@ there is no such limitation."
(lambda (new-root put-old) (lambda (new-root put-old)
"Change the root file system to NEW-ROOT and move the current root file "Change the root file system to NEW-ROOT and move the current root file
system to PUT-OLD." system to PUT-OLD."
(let ((ret (proc (string->pointer new-root) (let-values (((ret err)
(string->pointer put-old))) (proc (string->pointer new-root)
(err (errno))) (string->pointer put-old))))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "pivot_root" "~S ~S: ~A" (throw 'system-error "pivot_root" "~S ~S: ~A"
(list new-root put-old (strerror err)) (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 ;; XXX: 'fcntl' is a vararg function, but here we happily use the
;; standard ABI; crossing fingers. ;; standard ABI; crossing fingers.
(let ((ret (proc fd (let-values (((ret err)
(if wait? (proc fd
F_SETLKW ; lock & wait (if wait?
F_SETLK) ; non-blocking attempt F_SETLKW ;lock & wait
(bytevector->pointer bv))) F_SETLK) ;non-blocking attempt
(err (errno))) (bytevector->pointer bv))))
(unless (zero? ret) (unless (zero? ret)
;; Presumably we got EAGAIN or so. ;; Presumably we got EAGAIN or so.
(throw 'flock-error err)))))) (throw 'flock-error err))))))
@ -857,19 +866,19 @@ to interfaces that are currently up."
(len (* ifreq-struct-size 10)) (len (* ifreq-struct-size 10))
(reqs (make-bytevector len)) (reqs (make-bytevector len))
(conf (make-c-struct ifconf-struct (conf (make-c-struct ifconf-struct
(list len (bytevector->pointer reqs)))) (list len (bytevector->pointer reqs)))))
(ret (%ioctl (fileno sock) SIOCGIFCONF conf)) (let-values (((ret err)
(err (errno))) (%ioctl (fileno sock) SIOCGIFCONF conf)))
(when close? (when close?
(close-port sock)) (close-port sock))
(if (zero? ret) (if (zero? ret)
(bytevector->string-list reqs ifreq-struct-size (bytevector->string-list reqs ifreq-struct-size
(match (parse-c-struct conf ifconf-struct) (match (parse-c-struct conf ifconf-struct)
((len . _) len))) ((len . _) len)))
(throw 'system-error "network-interface-list" (throw 'system-error "network-interface-list"
"network-interface-list: ~A" "network-interface-list: ~A"
(list (strerror err)) (list (strerror err))
(list err))))) (list err))))))
(define %interface-line (define %interface-line
;; Regexp matching an interface line in Linux's /proc/net/dev. ;; Regexp matching an interface line in Linux's /proc/net/dev.
@ -897,9 +906,9 @@ interface NAME."
(let ((req (make-bytevector ifreq-struct-size))) (let ((req (make-bytevector ifreq-struct-size)))
(bytevector-copy! (string->utf8 name) 0 req 0 (bytevector-copy! (string->utf8 name) 0 req 0
(min (string-length name) (- IF_NAMESIZE 1))) (min (string-length name) (- IF_NAMESIZE 1)))
(let* ((ret (%ioctl (fileno socket) SIOCGIFFLAGS (let-values (((ret err)
(bytevector->pointer req))) (%ioctl (fileno socket) SIOCGIFFLAGS
(err (errno))) (bytevector->pointer req))))
(if (zero? ret) (if (zero? ret)
;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of
@ -927,9 +936,9 @@ interface NAME."
;; Set the 'ifr_flags' field. ;; Set the 'ifr_flags' field.
(bytevector-uint-set! req IF_NAMESIZE flags (native-endianness) (bytevector-uint-set! req IF_NAMESIZE flags (native-endianness)
(sizeof short)) (sizeof short))
(let* ((ret (%ioctl (fileno socket) SIOCSIFFLAGS (let-values (((ret err)
(bytevector->pointer req))) (%ioctl (fileno socket) SIOCSIFFLAGS
(err (errno))) (bytevector->pointer req))))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "set-network-interface-flags" (throw 'system-error "set-network-interface-flags"
"set-network-interface-flags on ~A: ~A" "set-network-interface-flags on ~A: ~A"
@ -943,9 +952,9 @@ interface NAME."
(min (string-length name) (- IF_NAMESIZE 1))) (min (string-length name) (- IF_NAMESIZE 1)))
;; Set the 'ifr_addr' field. ;; Set the 'ifr_addr' field.
(write-socket-address! sockaddr req IF_NAMESIZE) (write-socket-address! sockaddr req IF_NAMESIZE)
(let* ((ret (%ioctl (fileno socket) SIOCSIFADDR (let-values (((ret err)
(bytevector->pointer req))) (%ioctl (fileno socket) SIOCSIFADDR
(err (errno))) (bytevector->pointer req))))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "set-network-interface-address" (throw 'system-error "set-network-interface-address"
"set-network-interface-address on ~A: ~A" "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))) (let ((req (make-bytevector ifreq-struct-size)))
(bytevector-copy! (string->utf8 name) 0 req 0 (bytevector-copy! (string->utf8 name) 0 req 0
(min (string-length name) (- IF_NAMESIZE 1))) (min (string-length name) (- IF_NAMESIZE 1)))
(let* ((ret (%ioctl (fileno socket) SIOCGIFADDR (let-values (((ret err)
(bytevector->pointer req))) (%ioctl (fileno socket) SIOCGIFADDR
(err (errno))) (bytevector->pointer req))))
(if (zero? ret) (if (zero? ret)
(read-socket-address req IF_NAMESIZE) (read-socket-address req IF_NAMESIZE)
(throw 'system-error "network-interface-address" (throw 'system-error "network-interface-address"
@ -1076,9 +1085,10 @@ return the list of resulting <interface> objects."
(lambda () (lambda ()
"Return a list of <interface> objects, each denoting a configured "Return a list of <interface> objects, each denoting a configured
network interface. This is implemented using the 'getifaddrs' libc function." network interface. This is implemented using the 'getifaddrs' libc function."
(let* ((ptr (bytevector->pointer (make-bytevector (sizeof* '*)))) (let*-values (((ptr)
(ret (proc ptr)) (bytevector->pointer (make-bytevector (sizeof* '*))))
(err (errno))) ((ret err)
(proc ptr)))
(if (zero? ret) (if (zero? ret)
(let* ((ptr (dereference-pointer ptr)) (let* ((ptr (dereference-pointer ptr))
(result (unfold-interface-list 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 '*)))) (let ((proc (syscall->procedure int "tcgetattr" (list int '*))))
(lambda (fd) (lambda (fd)
"Return the <termios> structure for the tty at FD." "Return the <termios> structure for the tty at FD."
(let* ((bv (make-bytevector sizeof-termios)) (let*-values (((bv) (make-bytevector sizeof-termios))
(ret (proc fd (bytevector->pointer bv))) ((ret err) (proc fd (bytevector->pointer bv))))
(err (errno)))
(if (zero? ret) (if (zero? ret)
(read-termios bv) (read-termios bv)
(throw 'system-error "tcgetattr" "~A" (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 (match/write input-flags output-flags control-flags local-flags
line-discipline control-chars input-speed output-speed)) line-discipline control-chars input-speed output-speed))
(let ((ret (proc fd actions (bytevector->pointer bv))) (let-values (((ret err) (proc fd actions (bytevector->pointer bv))))
(err (errno)))
(unless (zero? ret) (unless (zero? ret)
(throw 'system-error "tcgetattr" "~A" (throw 'system-error "tcgetattr" "~A"
(list (strerror err)) (list (strerror err))
@ -1238,10 +1246,9 @@ produced by 'tcsetattr-action'; see tcsetattr(3) for details."
"Return a <window-size> structure describing the terminal at PORT, or raise "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 a 'system-error' if PORT is not backed by a terminal. This procedure
corresponds to the TIOCGWINSZ ioctl." corresponds to the TIOCGWINSZ ioctl."
(let* ((size (make-bytevector sizeof-winsize)) (let*-values (((size) (make-bytevector sizeof-winsize))
(ret (%ioctl (fileno port) TIOCGWINSZ ((ret err) (%ioctl (fileno port) TIOCGWINSZ
(bytevector->pointer size))) (bytevector->pointer size))))
(err (errno)))
(if (zero? ret) (if (zero? ret)
(read-winsize size) (read-winsize size)
(throw 'system-error "terminal-window-size" "~A" (throw 'system-error "terminal-window-size" "~A"