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

Last change on this file since 12843 was 12843, checked in by Ivan Raikov, 12 years ago

Added initial version of cmk.

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