add POSIX lock/unlock methods to aio objects

3 files changed, 123 insertions, 0 deletions

diff --git a/jim-aio.c b/jim-aio.c
index 4663afb..7619e3d 100644
--- a/jim-aio.c
+++ b/jim-aio.c
@@ -1159,6 +1159,43 @@ static int aio_cmd_verify(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
 }
 #endif /* JIM_BOOTSTRAP */
 
+static int aio_cmd_lock(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+    AioFile *af = Jim_CmdPrivData(interp);
+    struct flock fl = { F_WRLCK, SEEK_SET, 0, 0 };
+
+    switch (fcntl(af->fd, F_SETLK, &fl))
+    {
+        case 0:
+            Jim_SetResultInt(interp, 1);
+            break;
+        case -1:
+            if (errno == EACCES || errno == EAGAIN)
+                Jim_SetResultInt(interp, 0);
+            else
+            {
+                Jim_SetResultFormatted(interp, "lock failed: %s",
+                    strerror(errno));
+                return JIM_ERR;
+            }
+            break;
+        default:
+            Jim_SetResultInt(interp, 0);
+            break;
+    }
+
+    return JIM_OK;
+}
+
+static int aio_cmd_unlock(Jim_Interp *interp, int argc, Jim_Obj *const *argv)
+{
+    AioFile *af = Jim_CmdPrivData(interp);
+    struct flock fl = { F_UNLCK, SEEK_SET, 0, 0 };
+
+    Jim_SetResultInt(interp, fcntl(af->fd, F_SETLK, &fl) == 0);
+    return JIM_OK;
+}
+
 static const jim_subcmd_type aio_command_table[] = {
     {   "read",
         "?-nonewline? ?len?",
@@ -1333,6 +1370,20 @@ static const jim_subcmd_type aio_command_table[] = {
         /* Description: Verifies the certificate of a SSL/TLS channel */
     },
 #endif /* JIM_BOOTSTRAP */
+    {   "lock",
+	NULL,
+        aio_cmd_lock,
+        0,
+        0,
+        /* Description: Attempt to get a lock. */
+    },
+    {   "unlock",
+        NULL,
+        aio_cmd_unlock,
+        0,
+        0,
+        /* Description: Relase a lock. */
+    },
     { NULL }
 };
 
diff --git a/jim_tcl.txt b/jim_tcl.txt
index 5c6e206..97dc83e 100644
--- a/jim_tcl.txt
+++ b/jim_tcl.txt
@@ -58,6 +58,7 @@ Changes between 0.76 and 0.77
 3. Added `zlib`
 4. Added support for boolean constants in `expr`
 5. `string is` now supports 'boolean' class
+6. Add support for `aio lock` and `aio unlock`
 
 Changes between 0.75 and 0.76
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -4522,6 +4523,14 @@ aio
 +$handle *isatty*+::
     Returns 1 if the stream is a tty device.
 
++$handle *lock*+::
+    Apply a POSIX lock to the open file associated with the handle using
+    fcntl(2).
+    The handle must be open for write access.
+    Returns 1 if the lock was successfully obtained, 0 otherwise.
+    An error occurs if the handle is not suitable for locking (e.g.
+    if it is not open for write)
+
 +$handle *ndelay ?0|1?*+::
     Set O_NDELAY (if arg). Returns current/new setting.
     Note that in general ANSI I/O interacts badly with non-blocking I/O.
@@ -4558,6 +4567,9 @@ aio
 +$handle *ssl* *?-server cert priv?*+::
     Initiates a SSL/TLS session and returns a new stream
 
++$handle *unlock*+::
+    Release a POSIX lock previously acquired by `aio lock`.
+
 +$handle *verify*+::
     Verifies the certificate of a SSL/TLS stream peer
 
diff --git a/tests/lock.test b/tests/lock.test
new file mode 100644
index 0000000..2fe6ee4
--- /dev/null
+++ b/tests/lock.test
@@ -0,0 +1,60 @@
+# This test file covers POSIX file locking
+#
+# This file contains a collection of tests for one or more of the Tcl built-in
+# commands. Sourcing this file into Tcl runs the tests and generates output
+# for errors.  No output means no errors were found.
+#
+# Copyright (c) 2003-2009 Donal K. Fellows
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+source [file dirname [info script]]/testing.tcl
+
+set fh [open locktest.file w]
+
+test lock-1.1 {grab lock} {
+	$fh lock
+} 1
+
+test lock-1.2 {grab lock again} {
+	$fh lock
+} 1
+
+test lock-1.j {release lock} {
+	$fh unlock
+} 1
+
+test lock-1.4 {release lock again} {
+	$fh unlock
+} 1
+
+test lock-1.5 {grab lock from sub-process} {
+	switch [set pid [os.fork]] {
+	    -1 { error "Fork error." }
+	    0 {
+		# Child process
+		$fh lock
+		sleep 2
+		puts $fh [$fh unlock]
+		exit
+	    }
+	    default {
+		sleep 1
+		set stat [$fh lock]
+		set stat
+	    }
+	}
+} 0
+
+# fcntl() allows unlock on non-held lock so unlock will always return 1
+#set x [os.wait $pid]
+#test lock-1.6 {check unlock in child process} {
+#	$fh seek 0 start
+#	$fh read 1
+#} 1
+
+$fh close
+file delete locktest.file
+
+testreport
+