add port-try-file-lock?' and port-file-unlock'

collects/scribblings/reference/file-ports.scrbl

@@ -297,6 +297,41 @@ the current output port (see @racket[current-output-port]) using
   (lambda () (read-string 5)))
 ]}
 
+
+@defproc[(port-try-file-lock? [port file-stream-port?]
+                              [mode (or/c 'shared 'exclusive)])
+         boolean?]{
+
+Attempts to acquire a lock on the file using the current platform's 
+facilities for file locking. Multiple
+processes can acquire a @racket['shared] lock on a file, but at most
+one process can hold an @racket['exclusive] lock, and @racket['shared]
+and @racket['exclusive] locks are mutually exclusive.
+
+The result is @racket[#t] if the requested lock is acquired,
+@racket[#f] otherwise. When a lock is acquired, it is held until
+either it is released with @racket[port-file-unlock] or the port is closed
+(perhaps because the process terminates).
+
+Depending on the platform, locks may be merely advisory (i.e., locks
+affect only the ability of processes to acquire locks) or they may
+correspond to mandatory read and write locks, where @racket['shared]
+locks correspond to read locks and @racket['exclusive] locks
+correspond to write locks. Specifically, locks are mandatory under
+Windows and advisory on other platforms.
+
+Typically, locking is supported only for file ports, and attempting to
+acquire a lock with other kinds of file-stream ports raises an
+@racket[exn:fail:filesystem] exception.}
+
+
+@defproc[(port-file-unlock [port file-stream-port?])
+         void?]{
+
+Releases a lock held by the current process on the file of
+@racket[port].}
+
+
 @defproc[(port-file-identity [port file-stream-port?]) exact-positive-integer?]{
 
 @index['("inode")]{Returns} a number that represents

collects/tests/racket/file.rktl

@@ -676,6 +676,21 @@
 (close-output-port test-file)
 (check-test-file "tmp2")
 
+(let ([p (open-input-file "tmp2")])
+  (test #t port-try-file-lock? p 'shared)
+  (let ([p2 (open-input-file "tmp2")])
+    (test #t port-try-file-lock? p2 'shared)
+    (test (void) port-file-unlock p2)
+    (close-input-port p2))
+  (let ([p3 (open-input-file "tmp2")])
+    (test #f port-try-file-lock? p3 'exclusive)
+    (test (void) port-file-unlock p)
+    (test #t port-try-file-lock? p3 'exclusive)
+    (test #f port-try-file-lock? p 'shared)
+    (close-input-port p3))
+  (test #t port-try-file-lock? p 'exclusive)
+  (close-input-port p))
+
 (define ui (make-input-port 'name (lambda (s) (bytes-set! s 0 (char->integer #\")) 1) #f void))
 (test "" read ui)
 (arity-test (port-read-handler ui) 1 2)

src/racket/src/port.c

@@ -41,6 +41,7 @@
 # include <fcntl.h>
 # include <sys/types.h>
 # include <sys/time.h>
+# include <sys/file.h>
 # ifdef BSTRING_INCLUDE
 #  include <bstring.h>
 # endif
@@ -4690,6 +4691,117 @@ scheme_file_buffer(int argc, Scheme_Object *argv[])
   }
 }
 
+static int try_lock(int fd, int writer, int *_errid)
+{
+#ifdef UNIX_FILE_SYSTEM
+  {
+    int ok;
+
+    do {
+      ok = flock(fd, (writer ? LOCK_EX : LOCK_SH) | LOCK_NB);
+    } while ((ok == -1) && (errno == EINTR));
+
+    if (ok == 0)
+      return 1;
+
+    if (errno == EWOULDBLOCK) {
+      *_errid = 0;
+      return 0;
+    }
+    
+    *_errid = errno;
+    return 0;
+  }
+#endif
+#ifdef WINDOWS_FILE_HANDLES
+  *_errid = 5;
+  return 0;
+#endif
+}
+
+static void check_already_closed(const char *name, Scheme_Object *p)
+{
+  int is_closed;
+  if (SCHEME_INPUT_PORTP(p)) {
+    is_closed = scheme_input_port_record(p)->closed;
+  } else {
+    is_closed = scheme_output_port_record(p)->closed;
+  }
+  if (is_closed) {
+    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
+                     "%s: port is closed: %V",
+                     name, 
+                     p);
+  }
+}
+
+Scheme_Object *scheme_file_try_lock(int argc, Scheme_Object **argv)
+{
+  intptr_t fd;
+  int writer = 0, errid;
+
+  if (!scheme_get_port_file_descriptor(argv[0], &fd))
+    scheme_wrong_type("port-try-file-lock?", "file-stream-port", 0, argc, argv);
+
+  if (SCHEME_SYMBOLP(argv[1]) && !SCHEME_SYM_WEIRDP(argv[1])) {
+    if (!strcmp(SCHEME_SYM_VAL(argv[1]), "exclusive"))
+      writer = 1;
+    else if (!strcmp(SCHEME_SYM_VAL(argv[1]), "shared"))
+      writer = 0;
+    else
+      writer = -1;
+  } else
+    writer = -1;
+
+  if (writer == -1)
+    scheme_wrong_type("port-try-file-lock?", "'shared or 'exclusive", 1, argc, argv);
+
+  check_already_closed("port-try-file-lock?", argv[0]);
+
+  if (try_lock(fd, writer, &errid))
+    return scheme_true;
+  
+  if (errid) {
+    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                     "port-try-file-lock?: error getting file %s lock (%E)",
+                     (writer ? "exclusive" : "shared"),
+                     errid);
+  }
+   
+  return scheme_false;
+}
+
+Scheme_Object *scheme_file_unlock(int argc, Scheme_Object **argv)
+{
+  int ok, errid;
+  intptr_t fd;
+
+  if (!scheme_get_port_file_descriptor(argv[0], &fd))
+    scheme_wrong_type("port-file-unlock", "file-stream-port", 0, argc, argv);
+
+  check_already_closed("port-file-unlock", argv[0]);
+
+#ifdef UNIX_FILE_SYSTEM
+  do {
+    ok = flock(fd, LOCK_UN);
+  } while ((ok == -1) && (errno == EINTR));
+  ok = !ok;
+  errid = errno;
+#endif
+#ifdef WINDOWS_FILE_HANDLES
+  ok = 0;
+  errid = 5;
+#endif
+
+  if (!ok) {
+    scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
+                     "port-file-unlock: error unlocking file (%E)",
+                     errid);
+  }
+
+  return scheme_void;
+}
+
 /*========================================================================*/
 /*                          FILE input ports                              */
 /*========================================================================*/

src/racket/src/portfun.c

@@ -314,6 +314,8 @@ scheme_init_port_fun(Scheme_Env *env)
   GLOBAL_NONCM_PRIM("flush-output",                   flush_output,                   0, 1, env);
   GLOBAL_NONCM_PRIM("file-position",                  scheme_file_position,           1, 2, env);
   GLOBAL_NONCM_PRIM("file-stream-buffer-mode",        scheme_file_buffer,             1, 2, env);
+  GLOBAL_NONCM_PRIM("port-try-file-lock?",            scheme_file_try_lock,           2, 2, env);
+  GLOBAL_NONCM_PRIM("port-file-unlock",               scheme_file_unlock,             1, 1, env);
   GLOBAL_NONCM_PRIM("port-file-identity",             scheme_file_identity,           1, 1, env);
   GLOBAL_NONCM_PRIM("port-count-lines!",              port_count_lines,               1, 1, env);
           

src/racket/src/schminc.h

@@ -13,7 +13,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1015
+#define EXPECTED_PRIM_COUNT 1017
 #define EXPECTED_UNSAFE_COUNT 76
 #define EXPECTED_FLFXNUM_COUNT 68
 #define EXPECTED_FUTURES_COUNT 5

src/racket/src/schpriv.h

@@ -3422,6 +3422,8 @@ Scheme_Object *scheme_do_open_output_file(char *name, int offset, int argc, Sche
 Scheme_Object *scheme_file_position(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_buffer(int argc, Scheme_Object *argv[]);
 Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[]);
+Scheme_Object *scheme_file_try_lock(int argc, Scheme_Object **argv);
+Scheme_Object *scheme_file_unlock(int argc, Scheme_Object **argv);
 
 void scheme_reserve_file_descriptor(void);
 void scheme_release_file_descriptor(void);

src/racket/src/schvers.h

@@ -13,12 +13,12 @@
    consistently.)
 */
 
-#define MZSCHEME_VERSION "5.0.99.5"
+#define MZSCHEME_VERSION "5.0.99.6"
 
 #define MZSCHEME_VERSION_X 5
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 99
-#define MZSCHEME_VERSION_W 5
+#define MZSCHEME_VERSION_W 6
 
 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
 #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)