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

syscalls: Use define-as-needed for mount and umount. 

* guix/build/syscalls.scm (mount): Use define-as-needed macro
and remove from export list.
(umount): Ditto.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Mathieu Othacehe 2017-04-10 19:18:11 +02:00 committed by Ludovic Courtès
parent 8336df0668
commit 7df4d3465d
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 37 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
guix/build/syscalls.scm
View File

@ -45,8 +45,6 @@
MNT_EXPIRE MNT_EXPIRE
UMOUNT_NOFOLLOW UMOUNT_NOFOLLOW
restart-on-EINTR restart-on-EINTR
mount
umount
mount-points mount-points
swapon swapon
swapoff swapoff
@ -492,58 +490,50 @@ the returned procedure is called."
(define MNT_EXPIRE 4) (define MNT_EXPIRE 4)
(define UMOUNT_NOFOLLOW 8) (define UMOUNT_NOFOLLOW 8)
(define mount (define-as-needed (mount source target type
;; If called from the statically linked Guile, use Guile core 'mount'. #:optional (flags 0) options
;; Otherwise, use an FFI binding to define 'mount'.
;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
(if (module-defined? the-scm-module 'mount)
(module-ref the-scm-module 'mount)
(let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(lambda* (source target type #:optional (flags 0) options
#:key (update-mtab? #f)) #:key (update-mtab? #f))
"Mount device SOURCE on TARGET as a file system TYPE. "Mount device SOURCE on TARGET as a file system TYPE.
Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h> Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h>
constants, and OPTIONS may be a string. When FLAGS contains constants, and OPTIONS may be a string. When FLAGS contains
MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true, MS_REMOUNT, SOURCE and TYPE are ignored. When UPDATE-MTAB? is true,
update /etc/mtab. Raise a 'system-error' exception on error." update /etc/mtab. Raise a 'system-error' exception on error."
(let-values (((ret err) ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
(proc (if source (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
(string->pointer source) (let-values (((ret err)
%null-pointer) (proc (if source
(string->pointer target) (string->pointer source)
(if type %null-pointer)
(string->pointer type) (string->pointer target)
%null-pointer) (if type
flags (string->pointer type)
(if options %null-pointer)
(string->pointer options) flags
%null-pointer)))) (if options
(unless (zero? ret) (string->pointer options)
(throw 'system-error "mount" "mount ~S on ~S: ~A" %null-pointer))))
(list source target (strerror err)) (unless (zero? ret)
(list err))) (throw 'system-error "mount" "mount ~S on ~S: ~A"
(when update-mtab? (list source target (strerror err))
(augment-mtab source target type options))))))) (list err)))
(when update-mtab?
(augment-mtab source target type options)))))
(define umount (define-as-needed (umount target
;; If called from the statically linked Guile, use Guile core 'umount'. #:optional (flags 0)
;; Otherwise, use an FFI binding to define 'umount'. #:key (update-mtab? #f))
;; XXX: '#:update-mtab?' is not implemented by core 'umount'. "Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
(if (module-defined? the-scm-module 'umount)
(module-ref the-scm-module 'umount)
(let ((proc (syscall->procedure int "umount2" `(* ,int))))
(lambda* (target #:optional (flags 0)
#:key (update-mtab? #f))
"Unmount TARGET. Optionally FLAGS may be one of the MNT_* or UMOUNT_*
constants from <sys/mount.h>." constants from <sys/mount.h>."
(let-values (((ret err) ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
(proc (string->pointer target) flags))) (let ((proc (syscall->procedure int "umount2" `(* ,int))))
(unless (zero? ret) (let-values (((ret err)
(throw 'system-error "umount" "~S: ~A" (proc (string->pointer target) flags)))
(list target (strerror err)) (unless (zero? ret)
(list err))) (throw 'system-error "umount" "~S: ~A"
(when update-mtab? (list target (strerror err))
(remove-from-mtab target))))))) (list err)))
(when update-mtab?
(remove-from-mtab target)))))
(define (mount-points) (define (mount-points)
"Return the mounts points for currently mounted file systems." "Return the mounts points for currently mounted file systems."