fix make-lock-file-name'; add path-element?'

collects/racket/file.rkt

@@ -1,4 +1,5 @@
 #lang racket/base
+(require "path.rkt")
 
 (provide delete-directory/files
          copy-directory/files
@@ -154,20 +155,31 @@
     (unless (eq? table (weak-box-value pref-cache))
       (set! pref-cache (make-weak-box table)))))
 
-
+(define (make-pathless-lock-file-name name)
-(define make-lock-file-name
-  (case-lambda
-   [(path) (let-values ([(dir name dir?) (split-path path)])
-             (make-lock-file-name dir name))]
-   [(dir name)
-    (build-path dir
   (bytes->path-element
    (bytes-append
     (if (eq? 'windows (system-type))
         #"_"
         #".")
     #"LOCK"
-                  (path-element->bytes name))))]))
+    (path-element->bytes name))))
+
+(define make-lock-file-name
+  (case-lambda
+   [(path)
+    (unless (path-string? path)
+      (raise-type-error 'make-lock-file-name "path string" path))
+    (let-values ([(dir name dir?) (split-path path)])
+      (if (eq? dir 'relative)
+          (make-pathless-lock-file-name name)
+          (make-lock-file-name dir name)))]
+   [(dir name)
+    (unless (path-string? dir)
+      (raise-type-error 'make-lock-file-name "path string" dir))
+    (unless (path-element? name)
+      (raise-type-error 'make-lock-file-name "path element" name))
+    (build-path dir
+                (make-pathless-lock-file-name name))]))
 
 (define (preferences-lock-file-mode)
   (case (system-type)

collects/racket/path.rkt

@@ -8,7 +8,8 @@
          file-name-from-path
          path-only
          some-system-path->string
-         string->some-system-path)
+         string->some-system-path
+         path-element?)
 
 (define (simple-form-path p)
   (unless (path-string? p)
@@ -184,4 +185,7 @@
     (raise-type-error 'string->some-system-path "'unix or 'windows" kind))
   (bytes->path (string->bytes/utf-8 path) kind))
 
-
+(define (path-element? path)
+  (and (path-for-some-system? path)
+       (let-values ([(base name d?) (split-path path)])
+         (eq? base 'relative))))

collects/scribblings/reference/filesystem.scrbl

@@ -1094,10 +1094,15 @@ in the sense of @racket[port-try-file-lock?].
     (lambda () (printf "Shouldn't ger here eithere\n"))
     #:get-lock-file (lambda () (make-lock-file-name filename)))]
 
-@defproc*[([(make-lock-file-name [path path-string?]) path-string?]
+
-           [(make-lock-file-name [dir path-string?] [name path-string?]) path-string?])]{
+@defproc*[([(make-lock-file-name [path (or path-string? path-for-some-system?)]) 
-Creates a lock filename by prepending @racket["_LOCK"] on windows or @racket[".LOCK"] on all other platforms
+            path?]
-to the file portion of the path.
+           [(make-lock-file-name [dir (or path-string? path-for-some-system?)] 
+                                 [name path-element?]) 
+            path?])]{
+
+Creates a lock filename by prepending @racket["_LOCK"] on Windows or
+@racket[".LOCK"] on other platforms to the file portion of the path.
 
 @examples[
   #:eval file-eval

collects/scribblings/reference/paths.scrbl

@@ -152,7 +152,7 @@ other path is deconstructed with @racket[split-path] and
 elements is necessary.}
 
 
-@defproc[(path-element->string [path path?]) string?]{
+@defproc[(path-element->string [path path-element?]) string?]{
 
 Like @racket[path->string], except that trailing path separators are
 removed (as by @racket[split-path]). On Windows, any
@@ -168,7 +168,7 @@ The @racket[path-element->string] procedure is generally the best
 choice for presenting a pathless file or directory name to a user.}
 
 
-@defproc[(path-element->bytes [path path-string?]) bytes?]{
+@defproc[(path-element->bytes [path path-element?]) bytes?]{
 
 Like @racket[path->bytes], except that any encoding prefix is removed,
 etc., as for @racket[path-element->string].
@@ -563,6 +563,16 @@ An error is signaled by @racket[normalize-path] if the input
 path contains an embedded path for a non-existent directory,
 or if an infinite cycle of soft links is detected.}
 
+
+@defproc[(path-element? [path any/c]) boolean?]{
+
+Returns @racket[#t] if @racket[path] is a path value for some
+platform (see @racket[path-for-some-system?]) such that
+@racket[split-path] applied to @racket[path] would return
+@racket['relative] as its first result and a path as its second
+result. Otherwise, the result is @racket[#f].}
+
+
 @defproc[(path-only [path (or/c path-string? path-for-some-system?)])
          (or/c #f path-for-some-system?)]{
 

collects/tests/racket/file.rktl

@@ -1302,30 +1302,6 @@
 		 '(close-input-port r2))))
   (tcp-close l))
 
-;;----------------------------------------------------------------------
-;; File Locks
-(define tempfile (make-temporary-file))
-(err/rt-test (call-with-file-lock/timeout 10 'shared (lambda () #t) (lambda () #f)))
-(err/rt-test (call-with-file-lock/timeout tempfile 'bogus (lambda () #t) (lambda () #f)))
-(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda (x) #t) (lambda () #f)))
-(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda (x) #f)))
-
-(test #t call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f))
-(test #t call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda () #f))
-
-(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
-    (call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
-  (lambda () 'uhoh)))
-(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
-    (call-with-file-lock/timeout tempfile 'shared (lambda () #f) (lambda () (error))))
-  (lambda () 'uhon)))
-(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda ()
-    (call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
-  (lambda () 'uhoh)))
-(test #t call-with-file-lock/timeout tempfile 'shared (lambda ()
-    (call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f)))
-  (lambda () 'uhoh))
-
 ;;----------------------------------------------------------------------
 ;; TCP
 

collects/tests/racket/filelib.rktl

@@ -132,5 +132,46 @@
 	(delete-file "filelib-link")
 
 	'done))))
+;; ----------------------------------------
+
+;;----------------------------------------------------------------------
+;; File Locks
+(define tempfile (make-temporary-file))
+(err/rt-test (call-with-file-lock/timeout 10 'shared (lambda () #t) (lambda () #f)))
+(err/rt-test (call-with-file-lock/timeout tempfile 'bogus (lambda () #t) (lambda () #f)))
+(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda (x) #t) (lambda () #f)))
+(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda (x) #f)))
+
+(test #t call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f))
+(test #t call-with-file-lock/timeout tempfile 'exclusive (lambda () #t) (lambda () #f))
+
+(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
+    (call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
+  (lambda () 'uhoh)))
+(err/rt-test (call-with-file-lock/timeout tempfile 'exclusive (lambda ()
+    (call-with-file-lock/timeout tempfile 'shared (lambda () #f) (lambda () (error))))
+  (lambda () 'uhon)))
+(err/rt-test (call-with-file-lock/timeout tempfile 'shared (lambda ()
+    (call-with-file-lock/timeout tempfile 'exclusive (lambda () #f) (lambda () (error))))
+  (lambda () 'uhoh)))
+(test #t call-with-file-lock/timeout tempfile 'shared (lambda ()
+    (call-with-file-lock/timeout tempfile 'shared (lambda () #t) (lambda () #f)))
+  (lambda () 'uhoh))
+
+(test (string->path (if (eq? (system-type) 'windows) "_LOCKstuff" ".LOCKstuff"))
+      make-lock-file-name
+      "stuff")
+(test (string->path (if (eq? (system-type) 'windows) "_LOCKstuff" ".LOCKstuff"))
+      make-lock-file-name
+      "stuff")
+(test (build-path "dir" (if (eq? (system-type) 'windows) "_LOCKstuff" ".LOCKstuff"))
+      make-lock-file-name
+      "dir/stuff")
+(test (build-path "dir" (if (eq? (system-type) 'windows) "_LOCKstuff" ".LOCKstuff"))
+      make-lock-file-name
+      "dir"
+      (string->path "stuff"))
+
+;; ----------------------------------------
 
 (report-errs)