155 lines
4.6 KiB
Scheme
155 lines
4.6 KiB
Scheme
;;; Scsh
|
|
;;; Posix advisory record-locking for file descriptors.
|
|
;;; These procs may only be applied to integer file descriptors;
|
|
;;; they may not be applied to ports.
|
|
;;; Copyright (c) 1995 by David Albertz and Olin Shivers.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; C syscall interface
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(foreign-init-name "flock")
|
|
|
|
|
|
(foreign-source
|
|
"#include <sys/types.h>"
|
|
"#include <unistd.h>"
|
|
"#include <fcntl.h>"
|
|
""
|
|
"extern int errno;"
|
|
""
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"flock1.h\""
|
|
""
|
|
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"" "")
|
|
|
|
(define-foreign %set-lock (set_lock (integer fd)
|
|
(integer cmd)
|
|
(integer type)
|
|
(integer whence)
|
|
(integer start)
|
|
(integer len))
|
|
(to-scheme integer errno_or_false))
|
|
|
|
(define-foreign %get-lock (get_lock (integer fd)
|
|
(integer cmd)
|
|
(integer type)
|
|
(integer whence)
|
|
(integer start)
|
|
(integer len))
|
|
(to-scheme integer errno_or_false)
|
|
integer ; lock type
|
|
integer ; whence
|
|
integer ; start
|
|
integer ; len
|
|
integer) ; pid
|
|
|
|
|
|
;;; The LOCK record type
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record %lock-region
|
|
exclusive?
|
|
start ; integer
|
|
len ; Positive integer or #f
|
|
whence ; seek/set, seek/delta, or seek/end.
|
|
proc ; Process holding lock
|
|
)
|
|
|
|
(define lock-region? %lock-region?)
|
|
(define lock-region:exclusive? %lock-region:exclusive?)
|
|
(define lock-region:whence %lock-region:whence)
|
|
(define lock-region:start %lock-region:start)
|
|
(define lock-region:len %lock-region:len)
|
|
(define lock-region:proc %lock-region:proc)
|
|
(define set-lock-region:exclusive? set-%lock-region:exclusive?)
|
|
(define set-lock-region:whence set-%lock-region:whence)
|
|
(define set-lock-region:start set-%lock-region:start)
|
|
(define set-lock-region:len set-%lock-region:len)
|
|
(define set-lock-region:proc set-%lock-region:proc)
|
|
|
|
;;; Backwards compatibility for one or two releases.
|
|
(define lock-region:pid
|
|
(deprecated-proc (lambda (lr)
|
|
(cond ((lock-region:proc lr) => proc:pid)
|
|
(else #f)))
|
|
'lock-region:pid
|
|
"Use lock-region:proc instead."))
|
|
|
|
(define (make-lock-region exclusive? start len . maybe-whence)
|
|
(let ((whence (:optional maybe-whence seek/set)))
|
|
(make-%lock-region exclusive? start len whence #f)))
|
|
|
|
|
|
;;; Internal middleman routine
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (call-lock-region proc cmd fdes lock)
|
|
(check-arg lock-region? lock proc)
|
|
(let ((lock-type (if (lock-region:exclusive? lock) lock/write lock/read)))
|
|
(proc fdes cmd lock-type
|
|
(lock-region:whence lock)
|
|
(lock-region:start lock)
|
|
(lock-region:len lock))))
|
|
|
|
|
|
;;; The main routines
|
|
;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-errno-syscall (lock-region fdes lock)
|
|
(lambda (fdes lock)
|
|
(call-lock-region %set-lock fcntl/set-record-lock fdes lock)))
|
|
|
|
;;; Return true/false indicating success/failure.
|
|
|
|
(define (lock-region/no-block fdes lock)
|
|
(cond ((call-lock-region %set-lock fcntl/set-record-lock-no-block fdes lock)
|
|
=> (lambda (errno)
|
|
(cond ((or (= errno errno/again) (= errno errno/acces)) #f)
|
|
((= errno errno/intr) (lock-region/no-block fdes lock))
|
|
(else (errno-error errno lock-region/no-block fdes lock)))))
|
|
(else #t)))
|
|
|
|
|
|
;;; Return first lock that conflicts w/LOCK; if none, return #f.
|
|
|
|
(define (get-lock-region fdes lock)
|
|
(receive (err type whence start len pid)
|
|
(call-lock-region %get-lock fcntl/get-record-lock fdes lock)
|
|
(cond ((not err)
|
|
(and (not (= type lock/release))
|
|
(make-%lock-region (= type lock/write) start len whence
|
|
(pid->proc pid 'create))))
|
|
((= err errno/intr) (get-lock-region fdes lock))
|
|
(else (errno-error err get-lock-region fdes lock)))))
|
|
|
|
|
|
(define-errno-syscall (unlock-region fdes lock)
|
|
(lambda (fdes lock)
|
|
(%set-lock fdes fcntl/set-record-lock lock/release
|
|
(lock-region:whence lock)
|
|
(lock-region:start lock)
|
|
(lock-region:len lock))))
|
|
|
|
|
|
;;; Locks with dynamic extent -- with and without sugar
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Throwing out frees the lock. Don't throw back in.
|
|
|
|
(define (with-region-lock* fd lock thunk)
|
|
(let ((returned? #f))
|
|
(dynamic-wind (lambda ()
|
|
(if returned?
|
|
(error "Can't throw back into a with-region-lock" lock)
|
|
(lock-region fd lock)))
|
|
thunk
|
|
(lambda ()
|
|
(unlock-region fd lock)
|
|
(set! returned? #t)))))
|
|
|
|
(define-syntax with-region-lock
|
|
(syntax-rules ()
|
|
((with-region-lock fd lock body ...)
|
|
(with-region-lock* fd lock (lambda () body ...)))))
|