source: project/release/3/filepath/trunk/filepath.scm @ 12296

Last change on this file since 12296 was 12296, checked in by Ivan Raikov, 13 years ago

Name corrections.

File size: 25.0 KB
Line 
1;;
2;; A library for manipulating file paths in a cross platform way on
3;; both Windows and Unix.
4;;
5;; Based on the Haskell FilePath library by Neil Mitchell.
6;; http://www-users.cs.york.ac.uk/~ndm/filepath
7;;
8;; Copyright 2008 Ivan Raikov.
9;;
10;;
11;;  Redistribution and use in source and binary forms, with or without
12;;  modification, are permitted provided that the following conditions
13;;  are met:
14;;
15;;  - Redistributions of source code must retain the above copyright
16;;  notice, this list of conditions and the following disclaimer.
17;;
18;;  - Redistributions in binary form must reproduce the above
19;;  copyright notice, this list of conditions and the following
20;;  disclaimer in the documentation and/or other materials provided
21;;  with the distribution.
22;;
23;;  - Neither name of the copyright holders nor the names of its
24;;  contributors may be used to endorse or promote products derived
25;;  from this software without specific prior written permission.
26;;
27;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
28;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
29;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
30;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
31;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
32;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
33;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
34;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
35;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
36;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
37;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
38;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
39;;  POSSIBILITY OF SUCH DAMAGE.
40;;
41
42(require-extension syntax-case)
43(require-extension matchable)
44(require-extension srfi-1)
45(require-extension srfi-4)
46
47(define-extension filepath)
48
49(declare
50 (not usual-integrations)
51 (fixnum)
52 (inline)
53 (lambda-lift)
54 (export 
55
56  filepath:posix filepath:is-windows? filepath:is-posix?
57
58  ;; Separator predicates
59  filepath:path-separator filepath:path-separator-set
60  filepath:is-path-separator? 
61  filepath:search-path-separator filepath:is-search-path-separator? 
62  filepath:ext-separator filepath:is-ext-separator?
63
64  ;; Path methods (environment $PATH)
65  filepath:split-search-path filepath:get-search-path
66
67  ;; Extension procedures
68  filepath:split-extension filepath:take-extension filepath:replace-extension
69  filepath:drop-extension filepath:add-extension filepath:has-extension?
70  filepath:split-all-extensions filepath:drop-all-extensions filepath:take-all-extensions
71
72  ;; Drive procedures
73  filepath:split-drive filepath:join-drive
74  filepath:take-drive filepath:has-drive? filepath:drop-drive
75  filepath:is-drive?
76
77  ;; Operations on a file path, as a list of directories
78  filepath:split-file-name filepath:take-file-name
79  filepath:replace-file-name filepath:drop-file-name
80  filepath:take-base-name filepath:replace-base-name
81  filepath:take-directory filepath:replace-directory
82  filepath:combine filepath:split-path filepath:join-path
83  filepath:split-directories
84
85  ;; Low-level procedures
86  filepath:has-trailing-path-separator?
87  filepath:add-trailing-path-separator
88  filepath:drop-trailing-path-separator
89
90  ;; File name manipulators
91  filepath:normalise filepath:path-equal?
92  filepath:make-relative filepath:is-relative? filepath:is-absolute?
93  filepath:is-valid? filepath:make-valid
94 
95  ))
96
97(cond-expand
98   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
99   (else (use srfi-13 srfi-14)))
100
101;; Utility list procedures
102
103(define (scatter p lst)
104  (define (break1 p lst)
105    (let-values (((hd tl)  (break p lst)))
106                (list hd tl)))
107  (let loop ((lst lst) (ax (list)))
108    (match (break1 p lst)
109           ((() ())  (reverse ax))
110           ((hd ())  (reverse (cons hd ax)))
111           ((() tl)  (loop (cdr tl) (cons (list) ax)))
112           ((hd tl)  (loop (cdr tl) (cons hd ax))))))
113
114(define (prefix? p lst)
115  (let loop ((p p)  (lst lst))
116    (cond ((null? p)   #t)
117          ((null? lst) #f)
118          ((eq? (first p) (first lst))
119           (loop (cdr p) (cdr lst)))
120          (else #f))))
121       
122
123;; Utility char procedures
124
125(define (is-letter? c)  (char-set-contains? char-set:letter c))
126
127;; (define char-upcase-map
128;;   (zip (char-set->list char-set:lower-case)
129;;        (char-set->list char-set:upper-case)))
130
131;; (define (char-upcase c) (or (safe-car (alist-ref c char-upcase-map)) c))
132
133;; (define char-downcase-map
134;;   (zip (char-set->list char-set:upper-case)
135;;        (char-set->list char-set:lower-case)))
136
137;; (define (char-downcase c) (or (safe-car (alist-ref c char-downcase-map)) c))
138
139
140;; Is the operating system environment POSIX or Windows like
141
142(define filepath:posix 
143  (make-parameter 
144   (or (equal? (software-type) 'unix)
145       (equal? (software-type 'macos)))))
146
147(define (is-posix?) (filepath:posix))
148 
149(define (is-windows?) (not (is-posix?)))
150 
151 
152;;  Default path separator character. In the case where more than one
153;;  separator is possible, path-separator is the most commonly used
154;;  one.
155;;
156
157(define (path-separator)
158  (cond ((is-posix?)     #\/)
159        ((is-windows?)   #\\)
160        (else (error 'path-separator "unknown system environment"))))
161
162;; The set of all possible separators.
163
164(define (path-separator-set)
165  (cond ((is-posix?)    (list->char-set (list #\/)))
166        ((is-windows?)  (list->char-set (list #\\ #\/)))
167        (else         (error 'path-separator-set "unknown system environment"))))
168 
169(define (is-path-separator? x)
170  (char-set-contains? (path-separator-set) x))
171
172;; The character that is used to separate the entries in the $PATH
173;; environment variable.
174
175(define (search-path-separator)
176  (cond ((is-posix?)    #\:)
177        ((is-windows?)  #\;)
178        (else         (error 'search-path-separator "unknown system environment"))))
179       
180(define (is-search-path-separator? x)
181  (equal? x (search-path-separator)))
182
183;; File extension character
184
185(define (ext-separator) #\.)
186 
187(define (is-ext-separator? x)
188  (equal? x (ext-separator)))
189
190
191;;  Splits a string it on the search-path-separator character.
192;;
193;;   Follows the recommendations in
194;;   <http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap08.html>
195;;
196
197(define (split-search-path s)
198  (let ((cs (if (string? s) (string->list s) s)))
199    (filter-map (lambda (x) (match x (()  (and (is-posix?) (list #\.))) (else x)))
200                (scatter is-search-path-separator? cs))))
201
202(define (get-search-path)  (split-search-path (getenv "PATH")))
203
204;; Splits a file path string on the extension.
205
206(define (split-extension p)
207  (let ((pcs (if (string? p) (string->list p) p)))
208    (match-let (((a b)  (split-file-name pcs)))
209      (let-values (((c d)  (break is-ext-separator? (reverse b))))
210          (match d
211                 (()       (list pcs (list)))
212                 ((y . ys)  (list (append a (reverse ys)) (cons y (reverse c)))))))))
213
214(define (take-extension p)
215  (second (split-extension p)))
216
217(define (drop-extension p)
218  (first (split-extension p)))
219
220(define (replace-extension p ext)
221  (add-extension (drop-extension p) ext))
222
223(define (add-extension p ext)
224  (let ((ecs (if (string? ext) (string->list ext) ext))
225        (pcs (if (string? p) (string->list p) p)))
226    (if (null? ecs) pcs
227        (if (prefix? (list (ext-separator)) ecs)
228            (append pcs ecs)
229            (append pcs (list (ext-separator)) ecs)))))
230
231(define (has-extension? p)  (member (ext-separator) p))
232
233(define (split-all-extensions p)
234  (let ((pcs (if (string? p) (string->list p) p)))
235    (match-let (((a b)  (split-file-name pcs)))
236               (match (scatter is-ext-separator? b)
237                      ((c d . e) (list (concatenate (append a (list c))) 
238                                       (concatenate (intersperse (cons d e) (list (ext-separator))))))
239                      (else       (list pcs (list)))))))
240
241(define (drop-all-extensions p)
242  (first (split-all-extensions p)))
243
244(define (take-all-extensions p)
245  (second (split-all-extensions p)))
246
247(define (split-drive p)
248  (let ((pcs (if (string? p) (string->list p) p)))
249    (or (and (is-posix?) 
250             (let-values (((pre rest) (span is-path-separator? pcs)))
251                         (and (not (null? pre)) (list pre rest))))
252        (read-drive-letter pcs)
253        (read-drive-unc pcs)
254        (read-drive-share pcs)
255        (list (list) pcs))))
256
257(define (add-slash a xs)
258  (let ((xcs (if (string? xs) (string->list xs) xs))
259        (acs (if (string? a) (string->list a) a)))
260    (let-values (((c d) (span is-path-separator? xcs)))
261                (list (append acs c) d))))
262
263;; http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
264;; "\\?\D:\<path>" or "\\?\UNC\<server>\<share>"
265;; a is "\\?\"
266
267(define (read-drive-unc p)
268  (let ((pcs (if (string? p) (string->list p) p)))
269    (match pcs 
270           (((and s1 (? is-path-separator?)) 
271             (and s2 (? is-path-separator?))
272             #\? (and s3 (? is-path-separator?)) . xs)
273            (let ((us (map char-upcase xs)))
274              (match us 
275                     ((#\U #\N #\C (and s4 (? is-path-separator?)) . _)
276                      (match (read-drive-share-name (drop xs 4))
277                             ((a b)  (list (cons* s1 s2 #\? s3 (append (take xs 4) a)) b))))
278                     (else
279                      (match (read-drive-letter xs)
280                             ((a b) (list (cons* s1 s2 #\? s3 a) b))
281                             (else  #f))))))
282           (else #f))))
283
284
285(define (read-drive-letter p)
286  (let ((pcs (if (string? p) (string->list p) p)))
287    (match pcs
288           (((and x (? is-letter?))  #\: (and y (? is-path-separator?)) . xs)
289            (add-slash (list x #\:) (cons y xs)))
290           (((and x (? is-letter?)) #\: . xs) 
291            (list (list x #\:) xs))
292           (else #f))))
293
294(define (read-drive-share p)
295  (let ((pcs (if (string? p) (string->list p) p)))
296    (match pcs
297           (((and s1 (? is-path-separator?)) (and s2 (? is-path-separator?)) . xs)
298            (match-let (((a b)  (read-drive-share-name xs)))
299                       (list (cons* s1 s2 a) b)))
300           (else #f))))
301
302(define (read-drive-share-name n)
303  (let ((ncs (if (string? n) (string->list n) n)))
304    (let-values (((a b) (break is-path-separator? ncs)))
305                (and (not (null? a)) (add-slash a b)))))
306
307
308;; Join a drive and the rest of the path.
309;;  Windows: joinDrive "C:" "foo" == "C:foo"
310;;  Windows: joinDrive "C:\\" "bar" == "C:\\bar"
311;;  Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo"
312;;  Windows: joinDrive "/:" "foo" == "/:\\foo"
313
314(define (join-drive a b)
315  (let ((acs (if (string? a) (string->list a) a))
316        (bcs (if (string? b) (string->list b) b)))
317  (cond ((is-posix?)    (append acs bcs))
318        ((null? acs)  bcs)
319        ((null? bcs)  acs)
320        ((is-path-separator? (last acs)) (append acs bcs))
321        (else (match acs
322                     (((and a1 (? is-letter?)) #\:) (append acs bcs))
323                     (else (append acs (list (path-separator)) bcs)))))))
324
325
326(define (take-drive p)  (first (split-drive p)))
327
328(define (drop-drive p)  (second (split-drive p)))
329
330(define (has-drive? p)  (not (null? (take-drive p))))
331
332(define (is-drive? p)   (null? (drop-drive p)))
333
334
335;; Operations on a filepath, as a list of directories
336
337;;; Split a filename into directory and file. 'combine' is the inverse.
338(define (split-file-name p)
339  (let ((pcs (if (string? p) (string->list p) p)))
340    (match-let (((c d)  (split-drive pcs)))
341      (let-values (((a b)  (break is-path-separator? (reverse d))))
342                  (list (append c (reverse b)) (reverse a))))))
343
344(define (replace-file-name p r)
345  (drop-file-name (combine p r)))
346
347(define (drop-file-name p) (first (split-file-name p)))
348
349(define (take-file-name p) (second (split-file-name p)))
350
351(define (take-base-name p) (drop-extension (take-file-name p)))
352
353(define (replace-base-name p name) 
354  (let ((ncs (if (string? name) (string->list name) name)))
355    (match-let (((a b) (split-file-name p)))
356       (let* ((ext (take-extension b))
357              (ext (if (prefix? (list (ext-separator)) ext) ext 
358                       (cons (ext-separator) ext))))
359         (combine-always a (append ncs ext))))))
360
361;; Is an item either a directory or the last character a path separator?
362(define (has-trailing-path-separator? p)
363  (let ((pcs (if (string? p) (string->list p) p)))
364    (and (not (null? pcs)) (is-path-separator? (last pcs)))))
365 
366(define (add-trailing-path-separator p)
367  (let ((pcs (if (string? p) (string->list p) p)))
368    (if (has-trailing-path-separator? pcs) pcs 
369        (append pcs (list (path-separator))))))
370
371(define (drop-trailing-path-separator p)
372  (let ((pcs (if (string? p) (string->list p) p)))
373    (if (and (has-trailing-path-separator? pcs) (not (is-drive? pcs)))
374        (reverse (drop-while is-path-separator? (reverse pcs))) pcs)))
375
376(define (take-directory p)
377  (let ((pcs (if (string? p) (string->list p) p)))
378    (let* ((fn   (drop-file-name pcs))
379           (res  (reverse (drop-while is-path-separator? (reverse fn)))))
380      (if (is-drive? fn) fn
381          (if (and (null? res) (not (null? fn))) fn
382              res)))))
383           
384(define (replace-directory p dir)
385  (let ((pcs (if (string? p) (string->list p) p))
386        (dcs (if (string? dir) (string->list dir) dir)))
387    (combine-always dir (take-file-name pcs))))
388
389
390;; Combine two paths, if the second path 'isAbsolute', then it returns the second.
391;;
392;; Posix:   combine "/" "test" == "/test"
393;; Posix:   combine "home" "bob" == "home/bob"
394;; Windows: combine "home" "bob" == "home\\bob"
395;; Windows: combine "home" "/bob" == "/bob"
396
397(define (combine a b)
398  (let ((acs (if (string? a) (string->list a) a))
399        (bcs (if (string? b) (string->list b) b)))
400    (cond ((or (has-drive? bcs) (and (not (null? bcs)) (is-path-separator? (first bcs)))) bcs)
401          (else (combine-always acs bcs)))))
402
403;; Combine two paths, assuming rhs is NOT absolute.
404(define (combine-always a b)
405  (let ((acs (if (string? a) (string->list a) a))
406        (bcs (if (string? b) (string->list b) b)))
407    (cond ((null? acs) bcs)
408          ((null? bcs) acs)
409          ((is-path-separator? (last acs))  (append acs bcs))
410          ((is-drive? acs)  (join-drive acs bcs))
411          (else (append acs (list (path-separator)) bcs)))))
412
413
414;; Split a path by the directory separator.
415;; splitPath "test//item/" == ["test//","item/"]
416;; splitPath "test/item/file" == ["test/","item/","file"]
417;; splitPath "" == []
418;; Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"]
419;; Posix:   splitPath "/file/test" == ["/","file/","test"]
420
421(define (split-path p )
422  (define (f y) 
423    (if (null? y) y
424        (let*-values (((a b) (break is-path-separator? y))
425                      ((c d) (break (lambda (x) (not (is-path-separator? x))) b)))
426          (cons (append a c) (f d)))))
427  (let ((pcs (if (string? p) (string->list p) p)))
428    (match-let (((drive path)  (split-drive pcs)))
429               (append (if (null? drive) (list) (list drive)) (f path)))))
430
431;; Just as 'splitPath', but don't add the trailing slashes to each element.
432;; splitDirectories "test/file" == ["test","file"]
433;; splitDirectories "/test/file" == ["/","test","file"]
434;; splitDirectories "" == []
435
436(define (split-directories p)
437  (define (g x)
438    (let ((res (take-while (lambda (x) (not (is-path-separator? x))) x)))
439      (if (null? res) x res)))
440  (let* ((pcs (if (string? p) (string->list p) p))
441         (path-components (split-path pcs)))
442    (if (has-drive? pcs) 
443        (cons (car path-components) (map g (cdr path-components)))
444        (map g path-components))))
445
446
447;; Join path elements back together.
448;; joinPath [] == ""
449;; Posix: joinPath ["test","file","path"] == "test/file/path"
450
451(define (join-path p)
452  (let ((pcs (if (string? p) (string->list p) p)))
453    (fold-right combine (list) pcs)))
454
455
456;; Equality of two 'FilePath's.
457;;  Note that this doesn't follow symlinks or DOSNAM~1s.
458;;   Posix:   equalFilePath "foo" "foo/"
459;;   Posix:   not (equalFilePath "foo" "/foo")
460;;   Posix:   not (equalFilePath "foo" "FOO")
461;;   Windows: equalFilePath "foo" "FOO"
462
463(define (path-equal? a b)
464  (define (f x) 
465    (if (is-windows?) (drop-trail-slash (map char-downcase (normalise x)))
466        (drop-trail-slash (normalise x))))
467  (define (drop-trail-slash x)
468    (if (and (>= (length x) 2) (is-path-separator? (last x)))
469        (drop-right x 1) x))
470  (let ((acs (if (string? a) (string->list a) a))
471        (bcs (if (string? b) (string->list b) b)))
472    (equal? (f acs) (f bcs))))
473
474
475;; Contract a filename, based on a relative path.
476;; Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob"
477;; Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob"
478;; Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob"
479;; Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob"
480;; Windows: makeRelative "/Home" "/home/bob" == "bob"
481;; Posix:   makeRelative "/Home" "/home/bob" == "/home/bob"
482;; Posix:   makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar"
483;; Posix:   makeRelative "/fred" "bob" == "bob"
484;; Posix:   makeRelative "/file/test" "/file/test/fred" == "fred"
485;; Posix:   makeRelative "/file/test" "/file/test/fred/" == "fred/"
486;; Posix:   makeRelative "some/path" "some/path/a/b/c" == "a/b/c"
487
488(define (make-relative root path)
489  (define (drop-abs p) 
490    (match p (((and x (? is-path-separator?)) . xs) xs)
491           (else (drop-drive p))))
492
493  (define (take-abs p)
494    (match p (((and x (? is-path-separator?)) . xs) (list (path-separator)))
495           (else (map (lambda (y) (if (is-path-separator? y) (path-separator) (char-downcase y))) 
496                      (take-drive p)))))
497
498  (define (f x y pcs)
499    (if (null? x) (drop-while is-path-separator? y)
500        (match-let (((x1 x2)  (g x))
501                    ((y1 y2)  (g y)))
502                   (if (path-equal? x1 y1) (f x2 y2 pcs) pcs))))
503
504  (define (g x)
505    (let-values (((a b)  (break is-path-separator? (drop-while is-path-separator? x))))
506       (list (drop-while is-path-separator? a) (drop-while is-path-separator? b) )))
507
508  (let ((pcs (if (string? path) (string->list path) path))
509        (rcs (if (string? root) (string->list root) root)))
510
511    (cond ((path-equal? rcs pcs)  (list #\.))
512          ((not (equal? (take-abs rcs) (take-abs pcs)))  pcs)
513          (else (f (drop-abs rcs) (drop-abs pcs) pcs)))))
514
515;; Normalise a file
516;;  Posix:   normalise "/file/\\test////" == "/file/\\test/"
517;;  Posix:   normalise "/file/./test" == "/file/test"
518;;  Posix:   normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/"
519;;  Posix:   normalise "../bob/fred/" == "../bob/fred/"
520;;  Posix:   normalise "./bob/fred/" == "bob/fred/"
521;;  Posix:   normalise "./" == "./"
522;;  Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\"
523;;  Windows: normalise "c:\\" == "C:\\"
524;;  Windows: normalise "\\\\server\\test" == "\\\\server\\test"
525;;  Windows: normalise "c:/file" == "C:\\file"
526;;           normalise "." == "."
527
528(define (normalise path)
529  (define (drop-dots ax)
530    (lambda (xs)
531      (match xs
532             (((#\.) . (and rest (? pair?))) ((drop-dots ax) rest))
533             ((x . rest)  ((drop-dots (cons x ax)) rest))
534             (()          (reverse ax)))))
535
536  (define (prop-sep xs)
537    (match xs 
538           (((and a (? is-path-separator?)) (and b (? is-path-separator?)) . rest) 
539            (prop-sep (cons a rest)))
540           (((and a (? is-path-separator?)) . rest)
541            (cons (path-separator) (prop-sep rest)))
542           ((x . rest)
543            (cons x (prop-sep rest)))
544           (() xs)))
545
546  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
547
548  (match-let (((drv pth)  (split-drive path)))
549     (append (join-drive (normalise-drive drv) (f pth))
550             (if (and (not (null? pth)) (is-path-separator? (last pth)))
551                 (list (path-separator)) (list)))))
552
553(define (normalise-drive drive)
554  (define (rep-slash x) (if (is-path-separator? x) (path-separator) x))
555  (if (is-posix?) drive
556      (let ((x2 (map rep-slash drive)))
557        (if (read-drive-letter x2) (map char-upcase x2) drive))))
558       
559
560
561;; information for validity functions on Windows
562;; see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
563
564(define bad-chars (list->char-set (string->list ":*?><|")))
565
566(define (is-bad-char? c)  (char-set-contains? bad-chars c))
567
568(define bad-elems
569  (map string->list
570       (list "CON"  "PRN"  "AUX"  "NUL"  "COM1" "COM2" 
571             "COM3" "COM4" "COM5" "COM6" "COM7" "COM8"
572             "COM9" "LPT1" "LPT2" "LPT3" "LPT4" "LPT5"
573             "LPT6" "LPT7" "LPT8" "LPT9" "CLOCK$")))
574
575
576(define (is-bad-elem? x) 
577  (let ((x1 (map char-upcase (drop-all-extensions x))))
578    (member x1 bad-elems)))
579
580(define (is-valid? p)
581  (let ((pcs (if (string? p) (string->list p) p)))
582    (and (not (null? pcs))
583         (or (is-posix?)
584             (let ((pcs1 (drop-drive pcs)))
585               (and (not (any is-bad-char? pcs1))
586                    (not (any is-bad-elem? (split-directories pcs1)))
587                    (not (and (>= (length pcs) 2) 
588                              (every is-path-separator? pcs)))))))))
589                   
590
591;; Take a FilePath and make it valid; does not change already valid FilePaths.
592;; isValid x ==> makeValid x == x
593;; makeValid "" == "_"
594;; Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test"
595;; Windows: makeValid "test*" == "test_"
596;; Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_"
597;; Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt"
598;; Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt"
599;; Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file"
600
601(define (valid-chars p)
602  (map (lambda (x) (if (is-bad-char? x) #\_ x)) p))
603
604(define (valid-elements p)
605  (define (g x) 
606    (let-values (((a b) (span is-path-separator? (reverse x))))
607                (append (h (reverse b)) (reverse a))))
608  (define (h x)
609    (match-let ((( a b) (split-all-extensions x)))
610               (if (is-bad-elem? a) (add-extension (append a (list #\_)) b) x)))
611  (join-path (map g (split-path p))))
612
613(define (make-valid p)
614  (let ((pcs (if (string? p) (string->list p) p)))
615    (cond ((null? pcs)  (list #\_))
616          ((is-posix?)    pcs)
617          ((and (>= (length pcs) 2) (every is-path-separator? pcs))
618           (append (take pcs 2) (string->list "drive")))
619          (else (match-let (((drv pth) (split-drive pcs)))
620                           (join-drive drv (valid-elements (valid-chars pth))))))))
621
622
623;; Is a path relative, or is it fixed to the root?
624;; Windows: isRelative "path\\test" == True
625;; Windows: isRelative "c:\\test" == False
626;; Windows: isRelative "c:test" == True
627;; Windows: isRelative "c:" == True
628;; Windows: isRelative "\\\\foo" == False
629;; Windows: isRelative "/foo" == True
630;; Posix:   isRelative "test/path" == True
631;; Posix:   isRelative "/test" == False
632
633(define (is-relative? p)
634  (is-relative-drive? (take-drive p)))
635
636
637(define (is-relative-drive? p)
638  (not (is-path-separator? (last (first (read-drive-letter p))))))
639
640(define (is-absolute? p)
641  (not (is-relative? p)))
642
643
644;;; Exported interface
645
646(define filepath:is-posix?    is-posix?)
647(define filepath:is-windows?  is-windows?)
648
649(define filepath:path-separator path-separator)
650(define filepath:path-separator-set path-separator-set)
651(define filepath:is-path-separator? is-path-separator?)
652
653(define filepath:search-path-separator search-path-separator)
654(define filepath:is-search-path-separator? is-search-path-separator?)
655(define filepath:ext-separator ext-separator)
656(define filepath:is-ext-separator? is-ext-separator?)
657
658;; wrappers that take a char-list result from an internal procedure
659;; and convert it to a string
660
661(define (list-wrapper lst) 
662  (map list->string lst))
663
664  ;; Path methods (environment $PATH)
665(define filepath:split-search-path (compose list-wrapper split-search-path))
666(define filepath:get-search-path   (compose list-wrapper get-search-path))
667
668  ;; Extension procedures
669(define filepath:split-extension    (compose list-wrapper split-extension))
670(define filepath:take-extension     (compose list->string  take-extension))
671(define filepath:drop-extension     (compose list->string drop-extension))
672(define filepath:replace-extension  (compose list->string replace-extension))
673(define filepath:add-extension      (compose list->string add-extension))
674(define filepath:split-all-extensions   (compose list-wrapper split-all-extensions))
675(define filepath:drop-all-extensions    (compose list->string drop-all-extensions))
676(define filepath:take-all-extensions    (compose list->string take-all-extensions))
677(define filepath:has-extension? has-extension?)
678
679;; Drive procedures
680(define filepath:split-drive  (compose list-wrapper split-drive))
681(define filepath:join-drive   (compose list->string join-drive))
682(define filepath:take-drive   (compose list->string take-drive))
683(define filepath:drop-drive   (compose list->string drop-drive)) 
684(define filepath:has-drive?   has-drive?)
685(define filepath:is-drive?    is-drive?)
686
687;; Operations on a file path, as a list of directories
688(define filepath:split-file-name   (compose list-wrapper split-file-name))
689(define filepath:take-file-name    (compose list->string take-file-name))
690(define filepath:replace-file-name (compose list->string replace-file-name))
691(define filepath:drop-file-name    (compose list->string drop-file-name))
692(define filepath:take-base-name    (compose list->string take-base-name))
693(define filepath:replace-base-name (compose list->string replace-base-name))
694(define filepath:take-directory    (compose list->string take-directory))
695(define filepath:replace-directory (compose list->string replace-directory))
696(define filepath:combine           (compose list->string combine))
697(define filepath:split-path        (compose list-wrapper split-path))
698(define filepath:join-path         (compose list->string join-path))
699(define filepath:split-directories (compose list-wrapper split-directories))
700
701;; Low-level procedures
702(define filepath:add-trailing-path-separator (compose list->string add-trailing-path-separator))
703(define filepath:drop-trailing-path-separator (compose list->string drop-trailing-path-separator))
704(define filepath:has-trailing-path-separator? has-trailing-path-separator?)
705
706;; File name manipulators
707(define filepath:normalise      (compose list->string normalise ))
708(define filepath:make-relative  (compose list->string make-relative ))
709(define filepath:make-valid     (compose list->string make-valid ))
710(define filepath:is-valid?      is-valid? )
711(define filepath:path-equal?    path-equal?)
712(define filepath:is-relative?   is-relative?) 
713(define filepath:is-absolute?   is-absolute?)
Note: See TracBrowser for help on using the repository browser.