diff --git a/pkgs/racket-doc/scribblings/reference/filesystem.scrbl b/pkgs/racket-doc/scribblings/reference/filesystem.scrbl index 87ac4fdfbd..5c31f4c9c7 100644 --- a/pkgs/racket-doc/scribblings/reference/filesystem.scrbl +++ b/pkgs/racket-doc/scribblings/reference/filesystem.scrbl @@ -1240,14 +1240,17 @@ needed.} @defproc[(call-with-atomic-output-file [file path-string?] [proc ([port output-port?] [tmp-path path?] . -> . any)] - [#:security-guard security-guard (or/c #f security-guard?) #f]) + [#:security-guard security-guard (or/c #f security-guard?) #f] + [#:rename-fail-handler rename-fail-handler (or/c #f (exn:fail:filesystem? path> . -> . any)) #f]) any]{ Opens a temporary file for writing in the same directory as @racket[file], calls @racket[proc] to write to the temporary file, and -then atomically moves the temporary file in place of @racket[file]. -The atomic move simply uses @racket[rename-file-or-directory] on Unix -and Mac OS, but it uses an extra rename step (see below) on Windows +then atomically (except on Windows) moves the temporary file in place of @racket[file]. +The move simply uses @racket[rename-file-or-directory] on Unix +and Mac OS, and it uses @racket[rename-file-or-directory] on Windows +if @racket[rename-fail-handler] is provided; otherwise, on Windows, +the moves uses an extra rename step (see below) on Windows to avoid problems due to concurrent readers of @racket[file]. The @racket[proc] function is called with an output port for the @@ -1259,11 +1262,24 @@ temporary files on exceptions. Windows prevents programs from deleting or replacing files that are open, but it allows renaming of open files. Therefore, on Windows, -@racket[call-with-atomic-output-file] creates a second temporary file -@racket[_extra-tmp-file], renames @racket[file] to +@racket[call-with-atomic-output-file] by default creates a second +temporary file @racket[_extra-tmp-file], renames @racket[file] to @racket[_extra-tmp-file], renames the temporary file written by @racket[proc] to @racket[file], and finally deletes -@racket[_extra-tmp-file].} +@racket[_extra-tmp-file]. Since that process is not atomic, however, +@racket[rename-file-or-directory] is used if +@racket[rename-fail-handler] is provided, where +@racket[rename-file-or-directory] has some chance of being atomic, +since that the source and destination of the moves will be in the same +directory; any filesystem exception while attempting to rename the +file is send to @racket[rename-fail-handler], which can +re-@racket[raise] the exception or simply return to try again, perhaps +after a delay. In addition to a filesystem exception, the +@racket[rename-fail-handler] procedure also receives the temporary +file path to be moved to @racket[path]. The +@racket[rename-fail-handler] argument is used only on Windows. + +@history[#:changed "7.1.0.6" @elem{Added the @racket[#:rename-fail-handler] argument.}]} @defproc[(get-preference [name symbol?] diff --git a/racket/collects/compiler/private/cm-minimal.rkt b/racket/collects/compiler/private/cm-minimal.rkt index d7cc96e2fc..08ffdc63f0 100644 --- a/racket/collects/compiler/private/cm-minimal.rkt +++ b/racket/collects/compiler/private/cm-minimal.rkt @@ -173,7 +173,14 @@ ;; Attempt to delete, but give up if it doesn't work: (with-handlers ([exn:fail:filesystem? void]) (when noisy? (trace-printf "deleting ~a" path)) - (with-compiler-security-guard (delete-file path)))) + (with-compiler-security-guard (delete-file* path)))) + +(define (delete-file* path) + (if (eq? 'windows (system-type)) + ;; Using `delete-directory/files` tries deleting by first moving + ;; to the temporary folder: + (delete-directory/files path #:must-exist? #f) + (delete-file path))) (define (compilation-failure path->mode roots path zo-name keep-zo-name date-path reason) (unless (equal? zo-name keep-zo-name) @@ -185,7 +192,29 @@ (call-with-atomic-output-file path #:security-guard (pick-security-guard) - proc)) + proc + ;; On Windows, if some other process/place is reading the file, then + ;; an atomic move cannot succeed. Pause and try again, up to a point, + ;; then give up on atomicity. + #:rename-fail-handler (let ([amt 0.01]) + (lambda (exn tmp-path) + (cond + [(and amt + (eq? 'windows (system-type)) + (exn:fail:filesystem:errno? exn) + (let ([errno (exn:fail:filesystem:errno-errno exn)]) + (and (eq? 'windows (cdr errno)) + (eqv? (car errno) 5)))) ; ERROR_ACCESS_DENIED + (cond + [(< amt 0.5) + (sleep amt) + (set! amt (* 2 amt))] + [else + ;; Give up an atomicity + (try-delete-file path) + ;; And give up on trying to handle errors + (set! amt #f)])] + [else (raise exn)]))))) (define-syntax-rule (with-compiler-security-guard expr) @@ -1047,7 +1076,7 @@ (define to-delete (path-add-extension (get-compilation-path path->mode roots path) #".zo")) (when (file-exists? to-delete) (trace-printf "deleting: ~s" to-delete) - (with-compiler-security-guard (delete-file to-delete))))] + (with-compiler-security-guard (delete-file* to-delete))))] [(if cp->m (not (equal? (current-path->mode) cp->m)) (let ([current-cfp (use-compiled-file-paths)]) diff --git a/racket/collects/racket/file.rkt b/racket/collects/racket/file.rkt index a9501e043c..dede15faf8 100644 --- a/racket/collects/racket/file.rkt +++ b/racket/collects/racket/file.rkt @@ -235,7 +235,8 @@ ;; the file is reliably deleted if there's a break. (define (call-with-atomic-output-file path proc - #:security-guard [guard #f]) + #:security-guard [guard #f] + #:rename-fail-handler [rename-fail-handler #f]) (unless (path-string? path) (raise-argument-error 'call-with-atomic-output-file "path-string?" path)) (unless (and (procedure? proc) @@ -244,6 +245,10 @@ (unless (or (not guard) (security-guard? guard)) (raise-argument-error 'call-with-atomic-output-file "(or/c #f security-guard?)" guard)) + (unless (or (not rename-fail-handler) + (procedure? rename-fail-handler) + (procedure-arity-includes? rename-fail-handler 2)) + (raise-argument-error 'call-with-atomic-output-file "(or/c #f (procedure-arity-includes/c 2))" rename-fail-handler)) (define (try-delete-file path [noisy? #t]) ;; Attempt to delete, but give up if it doesn't work: (with-handlers ([exn:fail:filesystem? void]) @@ -268,13 +273,28 @@ (lambda () (parameterize ([current-security-guard (or guard (current-security-guard))]) (if ok? - (if (eq? (system-type) 'windows) - (let ([tmp-path2 (make-temporary-file "tmp~a" #f (path-only path))]) - (with-handlers ([exn:fail:filesystem? void]) - (rename-file-or-directory path tmp-path2 #t)) - (rename-file-or-directory tmp-path path #t) - (try-delete-file tmp-path2)) - (rename-file-or-directory tmp-path path #t)) + (with-handlers ([void (lambda (exn) + (try-delete-file tmp-path) + (raise exn))]) + (if (eq? (system-type) 'windows) + (cond + [rename-fail-handler + (let loop () + (with-handlers* ([exn:fail:filesystem? + (lambda (exn) + (call-with-break-parameterization + bp + (lambda () (rename-fail-handler exn tmp-path))) + (loop))]) + (rename-file-or-directory tmp-path path #t) + void))] + [else + (let ([tmp-path2 (make-temporary-file "tmp~a" #f (path-only path))]) + (with-handlers ([exn:fail:filesystem? void]) + (rename-file-or-directory path tmp-path2 #t)) + (rename-file-or-directory tmp-path path #t) + (try-delete-file tmp-path2))]) + (rename-file-or-directory tmp-path path #t))) (try-delete-file tmp-path))))))) (define (with-pref-params thunk)