source: project/release/4/directory-utils/tags/1.1.0/directory-utils.scm @ 35369

Last change on this file since 35369 was 35369, checked in by kon, 9 months ago

rel 1.1.0

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