Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +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

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

@ -126,36 +126,32 @@
(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 ((file-lock port-or-fd mode))
(res) ((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 (call-with-locked-file
((file-exists? path) path
(call-with-locked-file (lambda (fd)
path (let* ((str (port->string (open-input-file-descriptor fd)))
(lambda (fd) (res (proc str))
(let* ((str (port->string (open-input-file-descriptor fd))) (out (open-output-file-descriptor fd)))
(res (proc str)) (set-file-position! out seek/set 0)
(out (open-output-file-descriptor fd))) (display res out)
(set-file-position! out seek/set 0) (file-truncate out (string-size res))
(display res out) (close-output-port out)
(file-truncate out (string-size res)) res))))
(close-output-port out)
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