diff --git a/collects/compiler/cm.ss b/collects/compiler/cm.ss index aecd9aa8ea..409c323eaf 100644 --- a/collects/compiler/cm.ss +++ b/collects/compiler/cm.ss @@ -3,6 +3,7 @@ syntax/modresolve setup/main-collects scheme/file + unstable/file scheme/list scheme/path) @@ -117,19 +118,30 @@ (trace-printf "failure")) ;; with-compile-output : path (output-port -> alpha) -> alpha -;; Open path for writing, and arranges to delete path if there's +;; Open a temporary path for writing, automatically renames after, +;; and arranges to delete path if there's ;; an exception. Breaks are managed so that the port is reliably ;; closed and the file is reliably deleted if there's a break (define (with-compile-output path proc) - (let ([bp (current-break-parameterization)]) - (with-handlers ([void (lambda (exn) (try-delete-file path) (raise exn))]) - (let ([out (open-output-file path #:exists 'truncate/replace)]) - (dynamic-wind - void - (lambda () - (call-with-break-parameterization bp (lambda () (proc out)))) - (lambda () - (close-output-port out))))))) + (let ([bp (current-break-parameterization)] + [tmp-path (make-temporary-file "tmp~a" #f (path-only path))] + [ok? #f]) + (dynamic-wind + void + (lambda () + (begin0 + (let ([out (open-output-file tmp-path #:exists 'truncate/replace)]) + (dynamic-wind + void + (lambda () + (call-with-break-parameterization bp (lambda () (proc out tmp-path)))) + (lambda () + (close-output-port out)))) + (set! ok? #t))) + (lambda () + (if ok? + (rename-file-or-directory/ignore-exists-exn tmp-path path) + (try-delete-file tmp-path)))))) (define (write-deps code mode path external-deps reader-deps) (let ([dep-path (path-add-suffix (get-compilation-path mode path) #".dep")] @@ -137,7 +149,7 @@ reader-deps))] [external-deps (remove-duplicates external-deps)]) (with-compile-output dep-path - (lambda (op) + (lambda (op tmp-path) (write `(,(version) ,@(map path->main-collects-relative deps) ,@(map (lambda (x) @@ -239,9 +251,9 @@ ;; Write the code and dependencies: (when code - (make-directory* code-dir) + (make-directory*/ignore-exists-exn code-dir) (with-compile-output zo-name - (lambda (out) + (lambda (out tmp-name) (with-handlers ([exn:fail? (lambda (ex) (close-output-port out) @@ -258,7 +270,7 @@ (close-output-port out) ;; Note that we check time and write .deps before returning from ;; with-compile-output... - (verify-times path zo-name) + (verify-times path tmp-name) (write-deps code mode path external-deps reader-deps))))) (define depth (make-parameter 0)) diff --git a/collects/mzlib/compile.ss b/collects/mzlib/compile.ss index db8ecc77c1..f2dfd47b06 100644 --- a/collects/mzlib/compile.ss +++ b/collects/mzlib/compile.ss @@ -1,14 +1,15 @@ #lang scheme/base (require scheme/function scheme/path - scheme/file) + scheme/file + unstable/file) (provide compile-file) (define compile-file (case-lambda [(src) (define cdir (build-path (path-only src) "compiled")) - (make-directory* cdir) + (make-directory*/ignore-exists-exn cdir) (compile-file src (build-path cdir (path-add-suffix (file-name-from-path src) #".zo")))] [(src dest) (compile-file src dest values)] @@ -55,7 +56,7 @@ (close-output-port out))))) (lambda () (if ok? - (rename-file-or-directory temp-filename dest) + (rename-file-or-directory/ignore-exists-exn temp-filename dest) (with-handlers ([exn:fail:filesystem? void]) (delete-file temp-filename)))))) (lambda () (close-input-port in))) diff --git a/collects/unstable/file.ss b/collects/unstable/file.ss new file mode 100644 index 0000000000..2086f3ac69 --- /dev/null +++ b/collects/unstable/file.ss @@ -0,0 +1,24 @@ +#lang scheme/base +; Responsible: Jay McCarthy +(require scheme/contract) + +(define (exn:fail:filesystem:exists? x) + (and (exn:fail:filesystem? x) + (regexp-match #rx"exists" (exn-message x)))) + +(define (make-directory*/ignore-exists-exn dir) + (let-values ([(base name dir?) (split-path dir)]) + (when (and (path? base) + (not (directory-exists? base))) + (make-directory*/ignore-exists-exn base)) + (unless (directory-exists? dir) + (with-handlers ([exn:fail:filesystem:exists? void]) + (make-directory dir))))) + +(define (rename-file-or-directory/ignore-exists-exn from to) + (with-handlers ([exn:fail:filesystem:exists? void]) + (rename-file-or-directory from to))) + +(provide/contract + [make-directory*/ignore-exists-exn (path-string? . -> . void)] + [rename-file-or-directory/ignore-exists-exn (path-string? path-string? . -> . void)]) \ No newline at end of file diff --git a/collects/unstable/scribblings/file.scrbl b/collects/unstable/scribblings/file.scrbl new file mode 100644 index 0000000000..b7ccc34408 --- /dev/null +++ b/collects/unstable/scribblings/file.scrbl @@ -0,0 +1,24 @@ +#lang scribble/doc +@(require scribble/base + scribble/manual + "utils.ss" + (for-label unstable/file + scheme/file + scheme/contract + scheme/base)) + +@title[#:tag "file"]{Filesystem} + +@defmodule[unstable/file] + +@unstable[@author+email["Jay McCarthy" "jay@plt-scheme.org"]] + +@defproc[(make-directory*/ignore-exists-exn [pth path-string?]) + void]{ + Like @scheme[make-directory*], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create directories. +} + +@defproc[(rename-file-or-directory/ignore-exists-exn [from path-string?] [to path-string?]) + void]{ + Like @scheme[rename-file-or-directory], except it ignores errors when the path already exists. Useful to deal with race conditions on processes that create files. +} \ No newline at end of file diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 89937631b4..c2b86387dc 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -74,6 +74,7 @@ Keep documentation and tests up to date. @include-section["bytes.scrbl"] @include-section["contract.scrbl"] @include-section["exn.scrbl"] +@include-section["file.scrbl"] @include-section["list.scrbl"] @include-section["net.scrbl"] @include-section["path.scrbl"]