summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMathieu Othacehe <m.othacehe@gmail.com>2017-04-06 08:55:44 +0200
committerLudovic Courtès <ludo@gnu.org>2017-04-07 23:30:39 +0200
commitf91fcd9c42298e826026bc4eb3c6094a35722599 (patch)
tree699608be12f229a33c2f99ebb68d8ffd82be09bd
parentcf47a8a51dfbc9b6358da29b2d4f150ef732d163 (diff)
downloadpatches-f91fcd9c42298e826026bc4eb3c6094a35722599.tar
patches-f91fcd9c42298e826026bc4eb3c6094a35722599.tar.gz
syscalls: Allow mount and umount use from static Guile.
* guix/build/syscalls.scm (mount): Use Guile core mount if called from static Guile, otherwise use FFI based mount implementation. (umount): Ditto. This allows to use (guix build syscalls) from a module independently of calling context. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
-rw-r--r--guix/build/syscalls.scm86
1 files changed, 48 insertions, 38 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 5aae1530f4..4bcb2a871c 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -462,47 +462,57 @@ the returned procedure is called."
(define UMOUNT_NOFOLLOW 8)
(define mount
- (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
- (lambda* (source target type #:optional (flags 0) options
- #:key (update-mtab? #f))
- "Mount device SOURCE on TARGET as a file system TYPE. Optionally, FLAGS
-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-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))
- (list err)))
- (when update-mtab?
- (augment-mtab source target type options))))))
+ ;; If called from the statically linked Guile, use Guile core 'mount'.
+ ;; 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))
+ "Mount device SOURCE on TARGET as a file system TYPE.
+Optionally, FLAGS 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-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))
+ (list err)))
+ (when update-mtab?
+ (augment-mtab source target type options)))))))
(define 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_*
+ ;; If called from the statically linked Guile, use Guile core 'umount'.
+ ;; Otherwise, use an FFI binding to define 'umount'.
+ ;; XXX: '#:update-mtab?' is not implemented by core '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>."
- (let-values (((ret err)
- (proc (string->pointer target) flags)))
- (unless (zero? ret)
- (throw 'system-error "umount" "~S: ~A"
- (list target (strerror err))
- (list err)))
- (when update-mtab?
- (remove-from-mtab target))))))
+ (let-values (((ret err)
+ (proc (string->pointer target) flags)))
+ (unless (zero? ret)
+ (throw 'system-error "umount" "~S: ~A"
+ (list target (strerror err))
+ (list err)))
+ (when update-mtab?
+ (remove-from-mtab target)))))))
(define (mount-points)
"Return the mounts points for currently mounted file systems."