From: Richard M Kreuter <kreuter@users.sourceforge.net>
Date: Wed, 27 Feb 2008 17:33:45 +0000 (+0000)
Subject: 1.0.15.2: Add binding to fcntl's struct flock in SB-POSIX.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9fb8bf2eb2c91cbda313edaa3362ff8b221ab81d;p=sbcl.git

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.
---

diff --git a/NEWS b/NEWS
index e473069..cbff7b1 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,7 @@
 ;;;; -*- coding: utf-8; -*-
+changes in sbcl-1.0.16 relative to 1.0.15:
+  * enhancement: add support for fcntl's struct flock to SB-POSIX.
+
 changes in sbcl-1.0.15 relative to sbcl-1.0.14:
   * enhancement: cleaner backtraces for interactive interrupts, as
     well as other cases where the interesting frames used to be
diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp
index 0243a85..271baf6 100644
--- a/contrib/sb-posix/constants.lisp
+++ b/contrib/sb-posix/constants.lisp
@@ -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)
diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp
index 91ee3c3..59567f5 100644
--- a/contrib/sb-posix/defpackage.lisp
+++ b/contrib/sb-posix/defpackage.lisp
@@ -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")
diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 5704d3f..2e2bde6 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -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
diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp
index 3b9b171..5c4d01c 100644
--- a/contrib/sb-posix/posix-tests.lisp
+++ b/contrib/sb-posix/posix-tests.lisp
@@ -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)
diff --git a/contrib/sb-posix/sb-posix.texinfo b/contrib/sb-posix/sb-posix.texinfo
index 061c36a..95fd8be 100644
--- a/contrib/sb-posix/sb-posix.texinfo
+++ b/contrib/sb-posix/sb-posix.texinfo
@@ -213,6 +213,10 @@ objects corresponding to supported POSIX structures, and the supported
 slots for those structures.
 
 @itemize
+
+@item flock
+@include class-sb-posix-flock.texinfo
+
 @item passwd
 @include class-sb-posix-passwd.texinfo
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 35162a0..e6246d1 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.15.1"
+"1.0.15.2"