Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Avoiding a race condition in synchronized-rewrite-file.

Browse source
This commit is contained in:
Alex Shinn 2015-05-02 22:35:51 +09:00
parent 0df0dc3e2b
commit c7d64a19c4
1 changed files with 18 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lib/chibi/snow/fort.scm
View file

@ -126,22 +126,21 @@
(define (file-lock-loop port-or-fd mode) (define (file-lock-loop port-or-fd mode)
(let lp () (let lp ()
(let ((res (file-lock port-or-fd mode)))
(cond (cond
(res) ((file-lock port-or-fd mode))
((memv (errno) '(11 35)) (thread-sleep! 0.01) (lp)) ((memv (errno) '(11 35)) (thread-sleep! 0.01) (lp))
(else (error "couldn't lock file" (integer->error-string))))))) (else (error "couldn't lock file" (integer->error-string))))))
(define (call-with-locked-file path proc . o) (define (call-with-locked-file path proc . o)
(let ((fd (open path open/read-write (if (pair? o) (car o) #o644)))) (let ((fd (open path
(+ open/create open/read-write)
(if (pair? o) (car o) #o644))))
(file-lock-loop fd (+ lock/exclusive lock/non-blocking)) (file-lock-loop fd (+ lock/exclusive lock/non-blocking))
(exception-protect (proc fd) (file-lock fd lock/unlock)))) (exception-protect (proc fd) (file-lock fd lock/unlock))))
;; Rewrites file in place with the result of (proc orig-contents), ;; Rewrites file in place with the result of (proc orig-contents),
;; synchronized with file-lock. ;; synchronized with file-lock.
(define (synchronized-rewrite-text-file path proc . o) (define (synchronized-rewrite-text-file path proc . o)
(cond
((file-exists? path)
(call-with-locked-file (call-with-locked-file
path path
(lambda (fd) (lambda (fd)
@ -153,9 +152,6 @@
(file-truncate out (string-size res)) (file-truncate out (string-size res))
(close-output-port out) (close-output-port out)
res)))) res))))
(else
(call-with-output-file path
(lambda (out) (display (proc (if (pair? o) (car o) "")) out))))))
(define (synchronized-rewrite-sexp-file path proc . o) (define (synchronized-rewrite-sexp-file path proc . o)
(apply synchronized-rewrite-text-file (apply synchronized-rewrite-text-file