suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix `in-directory' to properly propagate filesystem errors

Browse Source
This commit is contained in:
Matthew Flatt 2012-08-31 11:12:21 -06:00
parent eed93825ab
commit 9cfcf8911c
2 changed files with 22 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/racket/private/for.rkt
View File

@ -1840,6 +1840,8 @@
(lambda () (read-char p*)))
eof)]])))
(define in-directory-tag (make-continuation-prompt-tag 'in-directory))
(define in-directory
(case-lambda
[(dir)
@ -1852,7 +1854,7 @@
(define (reply v)
(let/cc k
(abort-current-continuation
(default-continuation-prompt-tag)
in-directory-tag
(lambda () (cons (lambda () v) k)))))
(let loop ([dir (path->complete-path (or dir (current-directory)))]
[prefix dir])
@ -1862,14 +1864,16 @@
(reply p)
(when (directory-exists? fp)
(loop fp p)))))
(reply eof))))])
(reply eof))
in-directory-tag))])
(make-do-sequence
(lambda ()
(values
(lambda (gen) ((car gen)))
(lambda (gen) (call-with-continuation-prompt
(lambda ()
((cdr gen)))))
((cdr gen)))
in-directory-tag))
(make-gen)
(lambda (gen) (not (eof-object? ((car gen)))))
(lambda (val) #t)

15
collects/tests/racket/file.rktl
View File

@ -1529,6 +1529,21 @@
(err/rt-test (udp-connect! early-udp "localhost" 40000) (net-reject? 'udp-connect! "localhost" 40000 'client))
(err/rt-test (udp-send-to early-udp "localhost" 40000 #"hi") (net-reject? 'udp-send-to "localhost" 40000 'client))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check that `in-directory' fails properly on filesystem errors
(let ()
(define tmp (build-path (build-path (find-system-path 'temp-dir))
(format "in-dir-tmp-dir~a" (random 1000))))
(define sub (build-path tmp "sub"))
(make-directory* tmp)
(make-directory* sub)
(file-or-directory-permissions sub #o000)
(file-or-directory-permissions sub)
(err/rt-test (for ([v (in-directory sub)]) v) exn:fail:filesystem?)
(delete-directory sub)
(delete-directory/files tmp))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)