diff --git a/collects/racket/file.rkt b/collects/racket/file.rkt index 4420d9a2e0..1417c92835 100644 --- a/collects/racket/file.rkt +++ b/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) + (bytes->path-element + (bytes-append + (if (eq? 'windows (system-type)) + #"_" + #".") + #"LOCK" + (path-element->bytes name)))) (define make-lock-file-name (case-lambda - [(path) (let-values ([(dir name dir?) (split-path path)]) - (make-lock-file-name dir name))] + [(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 - (bytes->path-element - (bytes-append - (if (eq? 'windows (system-type)) - #"_" - #".") - #"LOCK" - (path-element->bytes name))))])) + (make-pathless-lock-file-name name))])) (define (preferences-lock-file-mode) (case (system-type) diff --git a/collects/racket/path.rkt b/collects/racket/path.rkt index f047a1ebf0..ce33f3ee2c 100644 --- a/collects/racket/path.rkt +++ b/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)))) diff --git a/collects/scribblings/reference/filesystem.scrbl b/collects/scribblings/reference/filesystem.scrbl index 84493ba2a0..2f61b7c510 100644 --- a/collects/scribblings/reference/filesystem.scrbl +++ b/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?])]{ -Creates a lock filename by prepending @racket["_LOCK"] on windows or @racket[".LOCK"] on all other platforms -to the file portion of the path. + +@defproc*[([(make-lock-file-name [path (or path-string? path-for-some-system?)]) + 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 diff --git a/collects/scribblings/reference/paths.scrbl b/collects/scribblings/reference/paths.scrbl index 87778b94d3..cccfcc356d 100644 --- a/collects/scribblings/reference/paths.scrbl +++ b/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?)]{ diff --git a/collects/tests/racket/file.rktl b/collects/tests/racket/file.rktl index 1f97dfb00f..cdeffec036 100644 --- a/collects/tests/racket/file.rktl +++ b/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 diff --git a/collects/tests/racket/filelib.rktl b/collects/tests/racket/filelib.rktl index bd0367ca98..ee5b14b4ac 100644 --- a/collects/tests/racket/filelib.rktl +++ b/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)