source: project/release/5/directory-utils/trunk/directory-utils.scm @ 38963

Last change on this file since 38963 was 38963, checked in by Kon Lovett, 2 months ago

add -strict-types, remove redundant -local, update test runner, fix find-*-pathnames argument handling (match doc)

File size: 8.6 KB
Line 
1;;;; directory-utils.scm
2;;;; Kon Lovett, Aug '10
3
4;; Issues
5;;
6;; - Need a routine that provides filename and stat info to the fold func.
7;; stat info: Posix + platform specific:
8;; Windows Hidden attribute ...
9;; macOS birthtime ...
10
11(module directory-utils
12
13(;export
14  pathname? check-pathname error-pathname
15  filename? check-filename error-filename
16  check-directory error-directory
17  ;
18  dot-filename-prefix?
19  dot-pathname? dot-filename?
20  remove-dotfiles
21  ;
22  directory-fold
23  ;
24  directory-utility-stack
25  push-directory
26  pop-directory
27  pop-toplevel-directory
28  ;
29  create-pathname-directory
30  make-program-filename
31  make-shell-filename
32  file-exists-in-directory?
33  find-file-pathnames
34  find-program-pathnames
35  which-command-pathnames
36  which-command-pathname)
37
38(import scheme)
39(import (chicken process-context))
40(import (chicken base))
41(import (chicken type))
42(import (only (chicken keyword) get-keyword))
43(import (only (chicken process-context) current-directory change-directory))
44(import (only (chicken string) string-split))
45(import (only (chicken pathname)
46  make-pathname
47  pathname-directory pathname-extension pathname-file
48  decompose-pathname decompose-directory))
49(import (only (chicken file) file-exists? directory create-directory))
50(import (only (chicken file posix) directory?))
51(import (only (srfi 1) concatenate fold append! filter-map remove any))
52(import (only (srfi 13) string-null? string-prefix?))
53(import (only miscmacros until))
54(import (only moremacros define-warning-parameter))
55(import (only type-errors warning-argument-type)) ;BUG for define-warning-parameter
56(import (only list-utils not-null? ensure-list))
57(import (only stack make-stack stack? stack-empty? stack-push! stack-pop!))
58(import (only type-checks define-check+error-type check-procedure))
59
60;; Helpers
61
62;;
63
64(define-type stack (struct stack#stack))
65
66(define-type optional-list (or boolean list))
67
68(define-type filename string)
69(define-type extension string)
70(define-type basename string)
71(define-type pathname string)
72
73(: dot-filename-prefix? (filename -> boolean))
74;NOTE do not type these as 'predicate', ex: (: filename? (* -> boolean : filename))
75;since the compiler will treat a literal ".." as meeting the criteria at compile time!
76(: pathname? (* --> boolean))
77(: filename? (* --> boolean))
78(: dot-filename? (* --> boolean))
79(: dot-pathname? (* --> boolean))
80(: remove-dotfiles ((list-of pathname) --> (list-of pathname)))
81(: directory-fold (procedure * pathname #!rest -> *))
82(: directory-utility-stack (#!optional stack -> stack))
83(: ignored-directory? (pathname --> boolean))
84(: push-directory ((or boolean pathname) #!optional stack -> void))
85(: pop-directory (#!optional stack -> void))
86(: pop-toplevel-directory (#!optional stack -> void))
87(: create-pathname-directory (pathname -> boolean))
88(: make-program-filename (basename --> filename))
89(: make-shell-filename (basename -> filename))
90(: file-exists-in-directory? (filename #!rest (list pathname) -> (or boolean pathname)))
91(: find-file-pathnames-in-directory (filename pathname -> (list-of pathname)))
92(: find-file-pathnames (filename #!rest -> (or boolean (list-of pathname))))
93(: find-program-pathnames (filename #!rest (list-of pathname) -> optional-list))
94(: which-command-pathnames (filename #!rest (list string) -> optional-list))
95(: which-command-pathname (filename #!rest (list string) -> optional-list))
96
97(: *find-file-pathnames (filename (list-of pathname) -> (or boolean (list-of pathname))))
98(: *find-program-pathnames (filename (list-of pathname) -> (or boolean (list-of pathname))))
99
100;;
101
102(define (->boolean obj)
103  (and obj #t) )
104
105(cond-expand
106  (windows  (define-constant PATH-DELIMITER ";"))
107  (else     (define-constant PATH-DELIMITER ":")))
108
109(define +dot-directory+ (make-pathname "." #f))
110
111;;
112
113;no . or .. since directoryname
114(define (dot-filename-prefix? str)
115  (and
116    (string-prefix? "." str)
117    #+unix
118    (not (or (string=? "." str) (string=? ".." str)))) )
119
120;;
121
122(define (ensure-list-of args)
123  ;ensure-list is a macro!
124  (concatenate (map (lambda (x) (ensure-list x)) args)) )
125
126;;
127
128(define-check+error-type directory)
129
130;; A null pathname or only extension is not a pathname, here at least
131
132; detecting only an extension is impossible with string pathnames
133
134(define (pathname? obj)
135  (and
136    (string? obj)
137    (receive (dir fil ext) (decompose-pathname obj)
138      (->boolean (or dir fil)))) )
139
140(define-check+error-type pathname)
141
142;; Just a filename, no directory
143
144(define (filename? obj)
145  (and
146    (string? obj)
147    (receive (dir fil ext) (decompose-pathname obj)
148      (not dir))) )
149
150(define-check+error-type filename)
151
152;;
153
154(define (dot-filename? obj)
155  (and
156    (filename? obj)
157    (dot-filename-prefix? obj)) )
158
159;; Is any pathname component is a dot-filename?
160
161(define (dot-pathname? obj)
162  (and
163    (string? obj)
164    (let-values (
165      ((dir fil ext) (decompose-pathname obj)) )
166      (or
167        (dot-filename-prefix? fil)
168        (let-values (
169          ((org dir elts) (decompose-directory dir)) )
170          (and
171            elts
172            (any dot-filename-prefix? elts)))))) )
173
174;; Remove dot files from a directory list
175
176(define (remove-dotfiles files)
177        (remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )
178
179;;
180
181(define (directory-fold func ident dir . opts)
182  (let (
183    (show-dotfiles? (get-keyword #:dotfiles? opts (lambda () #f))) )
184    (fold
185      (check-procedure 'directory-fold func)
186      ident
187      (directory (check-directory 'directory-fold dir) show-dotfiles?)) ) )
188
189;; Directory Stack
190
191(define-warning-parameter directory-utility-stack (make-stack) stack)
192
193;;
194
195(define (ignored-directory? dir)
196  (or
197    (string-null? dir)
198    (string=? +dot-directory+ (make-pathname dir #f))) )
199
200(define (push-directory dir #!optional (dirstack (directory-utility-stack)))
201  (stack-push! dirstack (current-directory))
202  ;don't cd unless necessary
203  (when (and dir (not (ignored-directory? dir)))
204    (change-directory dir) ) )
205
206(define (pop-directory #!optional (dirstack (directory-utility-stack)))
207  (unless (stack-empty? dirstack)
208    (change-directory (stack-pop! dirstack)) ) )
209
210(define (pop-toplevel-directory #!optional (dirstack (directory-utility-stack)))
211  (until (stack-empty? dirstack)
212    (pop-directory dirstack) ) )
213
214;; Ensure the directory for the specified path exists.
215
216(define (create-pathname-directory pn)
217  (->boolean
218    (create-directory
219      (pathname-directory (check-pathname 'create-pathname-directory pn))
220      #t)) )
221
222;; Platform specific program filename.
223
224(define (make-program-filename bn)
225  (cond-expand
226    (windows
227      (if (pathname-extension bn) bn
228        (make-pathname #f bn "exe")) )
229    (else
230      bn ) ) )
231
232(define (make-shell-filename bn)
233  (cond-expand
234    (windows
235      (if (pathname-extension bn) bn
236        (make-pathname #f bn "bat")) )
237    (else
238      (if (pathname-extension bn) bn
239        (make-pathname #f bn "sh")) ) ) )
240
241;; Pathname if file exists in directory.
242
243(define (file-exists-in-directory? fil . opts)
244  (let (
245    (dir (optional opts #f)) )
246    (let (
247      (path (make-pathname dir fil)) )
248      (and (file-exists? path) path) ) ) )
249
250;; List of all found pathnames.
251
252(define (find-file-pathnames-in-directory fil dir)
253  (filter-map
254    (cut file-exists-in-directory? fil <>)
255    (ensure-list dir)) )
256
257(define (*find-file-pathnames fil dirs)
258  (let loop (
259    (dirs dirs)
260    (paths '()) )
261    (if (null? dirs) (not-null? paths)
262      (loop
263        (cdr dirs)
264        (append!
265          paths
266          (find-file-pathnames-in-directory fil (car dirs))))) ) )
267
268(define (find-file-pathnames fil . dirs)
269  (*find-file-pathnames fil (ensure-list-of dirs)) )
270
271;; All found program pathname in directories.
272
273(define (*find-program-pathnames cmd dirs)
274  (cond-expand
275    (windows
276      (if (pathname-extension cmd) (*find-file-pathnames cmd dirs)
277        (let (
278          (founds
279            (append!
280              (or (*find-file-pathnames (make-program-filename cmd) dirs) '())
281              (or (*find-file-pathnames (make-shell-filename cmd) dirs) '()))) )
282          (not-null? founds))) )
283    (else
284      (*find-file-pathnames (make-program-filename cmd) dirs) ) ) )
285
286(define (find-program-pathnames cmd . dirs)
287  (*find-program-pathnames cmd (ensure-list-of dirs)) )
288
289;; All found program pathname in path.
290
291(define (which-command-pathnames cmd . opts)
292  (let (
293    (varnam (optional opts "PATH")) )
294    (and-let* (
295      (path (get-environment-variable varnam)) )
296      (*find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) ) )
297
298;; First found program pathname in path.
299
300(define (which-command-pathname cmd . opts)
301  (let (
302    (varnam (optional opts "PATH")) )
303    (and-let* (
304      (ps (which-command-pathnames cmd varnam))
305      ((not (null? ps))) )
306      (car ps) ) ) )
307
308) ;directory-utils
Note: See TracBrowser for help on using the repository browser.