This repository has been archived by the owner on Mar 30, 2023. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 4
/
file.rkt
123 lines (94 loc) · 3.61 KB
/
file.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
#lang racket/base
; Extend file system operations
(provide (all-defined-out)
(all-from-out racket/file))
(require file/glob
racket/file
racket/format
racket/function
racket/generator
racket/port
racket/sequence
"codec.rkt"
"message.rkt"
"path.rkt"
"subprogram.rkt"
"url.rkt")
(define+provide-message $path-not-found (pattern wrt))
; Use module-level cache because filesystem-root-list may take a while
; on Windows.
(define filesystem-root-list/cached
(let ([cache #f])
(λ ()
(unless cache
(set! cache (filesystem-root-list)))
cache)))
(define-subprogram (path-matching variant [wrt (current-directory)])
(with-handlers ([exn? (λ (e) ($fail ($path-not-found variant wrt)))])
(sequence-ref (in-paths variant wrt) 0)))
(define (in-paths variant [wrt (current-directory)])
(sequence-filter (cond [(or (regexp? variant)
(pregexp? variant)
(byte-pregexp? variant)
(byte-regexp? variant))
(curry regexp-match? variant)]
[(string? variant)
(λ (p)
(parameterize ([current-directory wrt])
(glob-match? variant p)))])
(in-directory wrt)))
(define (delete-file* path)
(when (or (file-exists? path) (link-exists? path))
(delete-file path)))
(define (in-matching-files patterns start-dir)
(in-generator
(for ([path (in-directory start-dir (negate link-exists?))])
(define rel-path (find-relative-path start-dir path))
(when (and (file-exists? rel-path)
(ormap (λ (p) (regexp-match? p rel-path)) patterns))
(yield rel-path)))))
(define (make-link/clobber to link-path)
(make-directory* (or (path-only link-path) (current-directory)))
(when (link-exists? link-path)
(delete-file link-path))
(make-file-or-directory-link to link-path))
(define (delete-directory/files/empty-parents path)
(delete-directory/files path)
(define cpath (path->complete-path path))
(let loop ([current (simplify-path cpath)] [next (../ cpath)])
(if (or (equal? current next)
(not (directory-empty? next)))
(void)
(begin (delete-directory next)
(loop next (../ next))))))
(define (directory-empty? path)
(null? (directory-list path)))
(define (something-exists? path)
(or (file-exists? path)
(directory-exists? path)
(link-exists? path)))
(define (linked? link-path path)
(and (link-exists? link-path)
(something-exists? path)
(equal? (file-or-directory-identity link-path)
(file-or-directory-identity path))))
(define (file-link-exists? path)
(and (link-exists? path)
(file-exists? path)))
(define (call-with-temporary-directory f #:cd? [cd? #t] #:base [base #f])
(when base (make-directory* base))
(define tmp-dir (make-temporary-file "rktdir~a" 'directory base))
(dynamic-wind void
(λ () (parameterize ([current-directory (if cd? tmp-dir (current-directory))])
(f tmp-dir)))
(λ ()
(when (directory-exists? tmp-dir)
(delete-directory/files tmp-dir)))))
(define (call-with-temporary-file proc)
(define tmp (make-temporary-file "~a"))
(dynamic-wind void
(λ () (proc tmp))
(λ () (delete-file tmp))))
(define-syntax-rule (with-temporary-directory body ...)
(call-with-temporary-directory
(λ (tmp-dir) body ...)))