[prev in list] [next in list] [prev in thread] [next in thread]
List: sbcl-commits
Subject: [Sbcl-commits] CVS: sbcl/contrib/sb-posix constants.lisp, 1.40,
From: Richard M Kreuter <kreuter () users ! sourceforge ! net>
Date: 2008-02-27 17:33:48
Message-ID: E1JUQA8-00006J-E7 () sc8-pr-cvs8 ! sourceforge ! net
[Download RAW message or body]
Update of /cvsroot/sbcl/sbcl/contrib/sb-posix
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv32421/contrib/sb-posix
Modified Files:
constants.lisp defpackage.lisp interface.lisp posix-tests.lisp
sb-posix.texinfo
Log Message:
1.0.15.2: Add binding to fcntl's struct flock in SB-POSIX.
File by file breakdown:
* contrib/sb-posix/constants.lisp
Add an internal ALIEN-FLOCK structure.
* contrib/sb-posix/defpackage.lisp
Export the FLOCK class the accessors.
* contrib/sb-posix/interface.lisp
Define a FLOCK "protocol class", add a path through FCNTL that accepts
FLOCK instances.
* sb-posix/posix-tests.lisp
Test two uses of exclusive (F_WRLCK) locks.
* contrib/sb-posix/sb-posix.texinfo
Add documentation for the FLOCK class to the manual.
Index: constants.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/constants.lisp,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -d -r1.40 -r1.41
--- constants.lisp 30 Dec 2007 05:32:29 -0000 1.40
+++ constants.lisp 27 Feb 2008 17:33:45 -0000 1.41
@@ -358,6 +358,17 @@
(:integer f-setlkw "F_SETLKW" nil t)
(:integer f-getown "F_GETOWN" nil t)
(:integer f-setown "F_SETOWN" nil t)
+ (:integer f-rdlck "F_RDLCK" nil t)
+ (:integer f-wrlck "F_WRLCK" nil t)
+ (:integer f-unlck "F_UNLCK" nil t)
+
+ (:structure alien-flock
+ ("struct flock"
+ (short type "short" "l_type")
+ (short whence "short" "l_whence")
+ (off-t start "off_t" "l_start")
+ (off-t len "off_t" "l_len")
+ (pid-t pid "pid_t" "l_pid")))
;; lockf()
(:integer f-lock "F_LOCK" nil t)
Index: defpackage.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/defpackage.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- defpackage.lisp 6 Oct 2007 16:53:53 -0000 1.11
+++ defpackage.lisp 27 Feb 2008 17:33:45 -0000 1.12
@@ -14,7 +14,9 @@
#:stat-mode #:stat-ino #:stat-dev #:stat-nlink #:stat-uid
#:stat-gid #:stat-size #:stat-atime #:stat-mtime #:stat-ctime
#:termios-iflag #:termios-oflag #:termios-cflag
- #:termios-lflag #:termios-cc #:timeval-sec #:timeval-usec))
+ #:termios-lflag #:termios-cc #:timeval-sec #:timeval-usec
+ #:flock-type #:flock-whence #:flock-start #:flock-len
+ #:flock-pid))
#+win32
(load-shared-object "msvcrt.dll")
Index: interface.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/interface.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- interface.lisp 3 Feb 2008 01:20:43 -0000 1.50
+++ interface.lisp 27 Feb 2008 17:33:45 -0000 1.51
@@ -290,11 +290,32 @@
(define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
(fd file-descriptor) (cmd int)
(arg alien-pointer-to-anything-or-nil))
+ (define-protocol-class flock alien-flock ()
+ ((type :initarg :type :accessor flock-type
+ :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+ (whence :initarg :whence :accessor flock-whence
+ :documentation "Flag for starting offset.")
+ (start :initarg :start :accessor flock-start
+ :documentation "Relative offset in bytes.")
+ (len :initarg :len :accessor flock-len
+ :documentation "Size; if 0 then until EOF.")
+ ;; Note: PID isn't initable, and is read-only. But other stuff in
+ ;; SB-POSIX right now loses when a protocol-class slot is unbound,
+ ;; so we initialize it to 0.
+ (pid :initform 0 :reader flock-pid
+ :documentation
+ "Process ID of the process holding the lock; returned with F_GETLK."))
+ (:documentation "Class representing locks used in fcntl(2)."))
(define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
(if argp
(etypecase arg
((alien int) (fcntl-with-int-arg fd cmd arg))
- ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
+ ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))
+ (flock (with-alien-flock a-flock ()
+ (flock-to-alien arg a-flock)
+ (let ((r (fcntl-with-pointer-arg fd cmd a-flock)))
+ (alien-to-flock a-flock arg)
+ r))))
(fcntl-without-arg fd cmd)))
;; uid, gid
Index: posix-tests.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/posix-tests.lisp,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -d -r1.36 -r1.37
--- posix-tests.lisp 3 Feb 2008 20:05:54 -0000 1.36
+++ posix-tests.lisp 27 Feb 2008 17:33:45 -0000 1.37
@@ -428,6 +428,71 @@
sb-posix::o-nonblock)))
t)
+(deftest fcntl.flock.1
+ (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (let ((flock (make-instance 'sb-posix:flock
+ :type sb-posix:f-wrlck
+ :whence sb-posix:seek-set
+ :start 0 :len 10))
+ (pathname "fcntl.flock.1")
+ kid-status)
+ (catch 'test
+ (with-open-file (f pathname :direction :output)
+ (write-line "1234567890" f)
+ (assert (zerop (sb-posix:fcntl f sb-posix:f-setlk flock)))
+ (let ((pid (sb-posix:fork)))
+ (if (zerop pid)
+ (progn
+ (multiple-value-bind (nope error)
+ (ignore-errors (sb-posix:fcntl f sb-posix:f-setlk flock))
+ (sb-ext:quit
+ :unix-status
+ (cond ((not (null nope)) 1)
+ ((= (sb-posix:syscall-errno error) sb-posix:eagain)
+ 42)
+ (t 86))
+ :recklessly-p t #| don't delete the file |#)))
+ (progn
+ (setf kid-status
+ (sb-posix:wexitstatus
+ (nth-value
+ 1 (sb-posix:waitpid pid 0))))
+ (throw 'test nil))))))
+ kid-status))
+ 42)
+
+
+(deftest fcntl.flock.2
+ (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
+ (let ((flock (make-instance 'sb-posix:flock
+ :type sb-posix:f-wrlck
+ :whence sb-posix:seek-set
+ :start 0 :len 10))
+ (pathname "fcntl.flock.2")
+ kid-status)
+ (catch 'test
+ (with-open-file (f pathname :direction :output)
+ (write-line "1234567890" f)
+ (assert (zerop (sb-posix:fcntl f sb-posix:f-setlk flock)))
+ (let ((ppid (sb-posix:getpid))
+ (pid (sb-posix:fork)))
+ (if (zerop pid)
+ (let ((r (sb-posix:fcntl f sb-posix:f-getlk flock)))
+ (sb-ext:quit
+ :unix-status
+ (cond ((not (zerop r)) 1)
+ ((= (sb-posix:flock-pid flock) ppid) 42)
+ (t 86))
+ :recklessly-p t #| don't delete the file |#))
+ (progn
+ (setf kid-status
+ (sb-posix:wexitstatus
+ (nth-value
+ 1 (sb-posix:waitpid pid 0))))
+ (throw 'test nil))))))
+ kid-status))
+ 42)
+
(deftest opendir.1
(let ((dir (sb-posix:opendir "/")))
(unwind-protect (sb-alien:null-alien dir)
Index: sb-posix.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/sb-posix.texinfo,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- sb-posix.texinfo 30 Nov 2007 02:16:27 -0000 1.3
+++ sb-posix.texinfo 27 Feb 2008 17:33:45 -0000 1.4
@@ -213,6 +213,10 @@
slots for those structures.
@itemize
+
+@item flock
+@include class-sb-posix-flock.texinfo
+
@item passwd
@include class-sb-posix-passwd.texinfo
-------------------------------------------------------------------------
This SF.net email is sponsored by: Microsoft
Defy all challenges. Microsoft(R) Visual Studio 2008.
http://clk.atdmt.com/MRT/go/vse0120000070mrt/direct/01/
_______________________________________________
Sbcl-commits mailing list
Sbcl-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/sbcl-commits
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic