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

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

Added initial code for filepath library.

File size: 24.4 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  ;; Separator predicates
57  filepath:path-separator filepath:path-separator-set
58  filepath:is-path-separator? filepath:search-path-separator
59  filepath:is-search-path-separator? filepath:ext-separator filepath:is-ext-separator?
60
61  ;; Path methods (environment $PATH)
62  filepath:split-search-path filepath:get-search-path
63
64  ;; Extension procedures
65  filepath:split-extension filepath:take-extension filepath:replace-extension
66  filepath:drop-extension filepath:add-extension filepath:has-extension?
67  filepath:split-extensions filepath:drop-extensions filepath:take-extensions
68
69  ;; Drive procedures
70  filepath:split-drive filepath:join-drive,
71  filepath:take-drive filepath:has-drive filepath:drop-drive
72  filepath:is-drive?
73
74  ;; Operations on a file path, as a list of directories
75  filepath:split-file-name filepath:take-file-name
76  filepath:replace-file-name filepath:drop-file-name
77  filepath:take-base-name filepath:replace-base-name
78  filepath:take-directory filepath:replace-directory
79  filepath:combine filepath:split-path filepath:join-path
80  filepath:split-directories
81
82  ;; Low-level procedures
83  filepath:has-trailing-path-separator?
84  filepath:add-trailing-path-separator
85  filepath:drop-trailing-path-separator
86
87  ;; File name manipulators
88  filepath:normalise filepath:path-equal?
89  filepath:make-relative filepath:is-relative? filepath:is-absolute?
90  filepath:is-valid? filepath:make-valid
91 
92  ))
93
94(cond-expand
95   (utf8-strings (use utf8-srfi-13 utf8-srfi-14))
96   (else (use srfi-13 srfi-14)))
97
98;; Utility list procedures
99
100(define (scatter p lst)
101  (define (break1 p lst)
102    (let-values (((hd tl)  (break p lst)))
103                (list hd tl)))
104  (let loop ((lst lst) (ax (list)))
105    (match (break1 p lst)
106           ((() ())  (reverse ax))
107           ((hd ())  (reverse (cons hd ax)))
108           ((() tl)  (loop (cdr tl) (cons (list) ax)))
109           ((hd tl)  (loop (cdr tl) (cons hd ax))))))
110
111(define (prefix? p lst)
112  (let loop ((p p)  (lst lst))
113    (cond ((null? p)   #t)
114          ((null? lst) #f)
115          ((eq? (first p) (first lst))
116           (loop (cdr p) (cdr lst)))
117          (else #f))))
118       
119(define (safe-car x) (and (pair? x) (car x)))
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
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 is-posix?
143  (make-parameter 
144   (case (software-type)
145     ((unix)  #t)
146     ((macos) #t)
147     (else #f)))
148  boolean?)
149 
150(define is-windows?
151  (make-parameter
152   (case (software-type)
153     ((windows) #t)
154     (else #f))
155   boolean?))
156 
157 
158;;  Default path separator character. In the case where more than one
159;;  separator is possible, path-separator is the most commonly used
160;;  one.
161;;
162
163(define path-separator
164  (cond (is-posix?     #\/)
165        (is-windows?   #\\)
166        (else (error 'path-separator "unknown system environment"))))
167
168;; The set of all possible separators.
169
170(define path-separator-set 
171  (cond (is-posix?    (list->char-set (list #\/)))
172        (is-windows?  (list->char-set (list #\\ #\/)))
173        (else         (error 'path-separator-set "unknown system environment"))))
174 
175(define (is-path-separator? x)
176  (char-set-contains? path-separator-set x))
177
178;; The character that is used to separate the entries in the $PATH
179;; environment variable.
180
181(define search-path-separator
182  (cond (is-posix?    #\:)
183        (is-windows?  #\;)
184        (else         (error 'search-path-separator "unknown system environment"))))
185       
186(define (is-search-path-separator? x)
187  (equal? x search-path-separator))
188
189;; File extension character
190
191(define ext-separator #\.)
192 
193(define (is-ext-separator? x)
194  (equal? x ext-separator))
195
196
197;;  Splits a string it on the search-path-separator character.
198;;
199;;   Follows the recommendations in
200;;   <http://www.opengroup.org/onlinepubs/009695399/basedefs/xbd_chap08.html>
201;;
202
203(define (split-search-path s)
204  (let ((cs (if (string? s) (string->list s) s)))
205    (filter-map (lambda (x) (match x (()  (and is-posix? (list #\.))) (else x)))
206                (scatter is-search-path-separator? cs))))
207
208(define (get-search-path)  (split-search-path (getenv "PATH")))
209
210;; Splits a file path string on the extension.
211
212(define (split-extension p)
213  (let ((pcs (if (string? p) (string->list p) op)))
214    (match-let (((a b)  (split-file-name pcs)))
215     (match (reverse (scatter is-ext-separator? b))
216            ((c . d) (let ((ext  c) 
217                           (fp   (append a (intersperse (reverse d) ext-separator))))
218                       (list fp ext)))
219            (else    (list pcs ""))))))
220
221(define (take-extension p)
222  (second (split-extension p)))
223
224(define (drop-extension p)
225  (first (split-extension p)))
226
227(define (replace-extension p ext)
228  (add-extension (drop-extension p) ext))
229
230(define (add-extension p ext)
231  (let ((ecs (if (string? ext) (string->list ext) ext))
232        (pcs (if (string? p) (string->list p) p)))
233    (if (prefix? extension-separator ecs)
234        (append p ext)
235        (append p (list ext-separator) ext))))
236
237(define (has-extension? p)  (member ext-separator p))
238
239(define (split-all-extensions p)
240  (match-let (((a b)  (split-file-name p)))
241    (match (scatter is-ext-separator? b)
242           ((c . d)  (list a (intersperse b ext-separator)))
243           (else     (list p (list))))))
244
245(define (drop-all-extensions p)
246  (first (split-all-extensions p)))
247
248(define (take-all-extensions p)
249  (second (split-all-extensions p)))
250
251(define (split-drive p)
252  (let ((pcs (if (string? p) (string->list p) p)))
253    (or (and is-posix? (let-values (((pre rest) (span is-path-separator? pcs)))
254                                   (list  pre rest)))
255        (read-drive-letter p)
256        (read-drive-unc p)
257        (read-drive-share p)
258        (list (list) p))))
259
260(define (add-slash a xs)
261  (let ((xcs (if (string? xs) (string->list xs) xs)))
262    (let-values (((c d) (span is-path-separator? xcs)))
263                (list (append a c) d))))
264
265;; http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
266;; "\\?\D:\<path>" or "\\?\UNC\<server>\<share>"
267;; a is "\\?\"
268
269(define (read-drive-unc p)
270  (let ((pcs (if (string? p) (string->list p) p)))
271    (match pcs 
272           (((and s1 (? is-path-separator?)) 
273             (and s2 (? is-path-separator?))
274             #\? (and s3 (? is-path-separator?)) . xs)
275            (let ((us (map char-upcase xs)))
276              (match us 
277                     ((#\U #\N #\C (and s4 (? is-path-separator?)) . _)
278                      (match (read-drive-share-name (drop xs 4))
279                             ((a b)  (list (c$ (cons* s1 s2 #\? s3 (append (take xs 4) a))) (c$  b)))))
280                     (else
281                      (match (read-drive-letter xs)
282                             ((a b) (list (c$ (cons* s1 s2 #\? s3 a)) (c$ b)))
283                             (else  #f))))))
284           (else #f))))
285
286
287(define (read-drive-letter p)
288  (let ((pcs (if (string? p) (string->list p) p)))
289    (match pcs
290           (((and x (? is-letter?))  #\: (and y (? is-path-separator?)) . xs)
291            (list (add-slash (list x #\:)) (cons y xs)))
292           (((and x (? is-letter?)) #\: . xs) 
293            (list (list x #\:) xs))
294           (else #f))))
295
296(define (read-drive-share p)
297  (let ((pcs (if (string? p) (string->list p) p)))
298    (match pcs
299           (((and s1 (? is-path-separator?)) (and s2 (? is-path-separator?)) . xs)
300            (match ((a b)  (read-drive-share-name xs))
301                   (list (cons* s1 s2 a) b)))
302           (else #f))))
303
304(define (read-drive-share-name n)
305  (let ((ncs (if (string? n) (string->list n) n)))
306    (match (break is-path-separator? ncs)
307           ((a b)  (add-slash a b)))))
308
309
310;; Join a drive and the rest of the path.
311;;  Windows: joinDrive "C:" "foo" == "C:foo"
312;;  Windows: joinDrive "C:\\" "bar" == "C:\\bar"
313;;  Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo"
314;;  Windows: joinDrive "/:" "foo" == "/:\\foo"
315
316(define (join-drive a b)
317  (let ((acs (if (string? a) (string->list a) a))
318        (bcs (if (string? b) (string->list b) b)))
319  (cond (is-posix?    (append acs bcs))
320        ((null? acs)  bcs)
321        ((null? bcs)  acs)
322        ((is-path-separator? (last acs)) (append acs bcs))
323        (else (match acs
324                     (((and a1 (? is-letter?)) #\:) (append a b))
325                     (else (append a (list path-separator) b)))))))
326
327
328(define (take-drive p)  (first (split-drive p)))
329
330(define (drop-drive p)  (second (split-drive p)))
331
332(define (has-drive? p)  (not (string-null? (take-drive p))))
333
334(define (is-drive? p)   (string-null? (drop-drive p)))
335
336
337;; Operations on a filepath, as a list of directories
338
339;;; Split a filename into directory and file. 'combine' is the inverse.
340
341(define (split-file-name p)
342  (let ((pcs (if (string? p) (string->list p) p)))
343    (match-let* (((c d)  (split-drive x))
344                 ((a b)  (break is-path-separator? (reverse d))))
345      (list (append c (reverse b)) (reverse a)))))
346
347(define (replace-file-name p r)
348  (drop-file-name (combine p r)))
349
350(define (drop-file-name p) (first (split-file p)))
351
352(define (take-file-name p) (second (split-file p)))
353
354(define (take-base-name p) (drop-extension (take-file p)))
355
356(define (replace-base-name p name) 
357  (match-let (((a b) (split-file-name p)))
358    (let ((ext (take-extension b)))
359      (combine-always a (append name (list ext-separator) 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    (if (null? pcs) #f (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))) x)))
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? b) (and (not (null? b)) (is-path-separator? (first b)))) b)
401          (else (combine-always a b)))))
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? a) b)
408          ((null? b) a)
409          ((is-path-separator? (last a))  (append a b))
410          ((is-drive? a)  (join-drive a b))
411          (else (append a (list path-separator) b)))))
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          (append (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 drive (f path)))))
430           
431           
432
433;; Just as 'splitPath', but don't add the trailing slashes to each element.
434;; splitDirectories "test/file" == ["test","file"]
435;; splitDirectories "/test/file" == ["/","test","file"]
436;; Valid x => joinPath (splitDirectories x) `equalFilePath` x
437;; splitDirectories "" == []
438
439(define (split-directories p)
440  (define (g x)
441    (let ((res (take-while (lambda (x) (not (is-path-separator? x))) x)))
442      (if (null? res) x res)))
443  (let ((pcs (if (string? p) (string->list p) p)))
444    (if (has-drive? p) (cons (first (path-components)) (map g (tail 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;;        takeAbs (x:_) | isPathSeparator x = [pathSeparator]
489;;        takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x
490
491
492(define (make-relative root path)
493  (define (drop-abs p) 
494    (match p (((and x (? is-path-separator?)) . xs) xs)
495           (else (drop-drive p))))
496  (define (take-abs p)
497    (match p (((and x (? is-path-separator?)) . xs) (list path-separator))
498           (else (map (lambda (y) (if (is-path-separator? y) path-separator (char-downcase y))) (take-drive x)))))
499  (define (f x y)
500    (if (null? x) (drop-while is-path-separator? y)
501        (match-let (((x1 x2)  (g x))
502                    ((y1 y2)  (g y)))
503                   (if (path-equal? x1 y1) (f x2 y2) path))))
504  (define (g x)
505    (match-let (((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  (let ((pcs (if (string? path) (string->list path) path))
508        (rcs (if (string? root) (string->list root) root)))
509    (cond ((path-equal? rcs pcs)  (list #\.))
510          ((not (equal? (take-abs rcs) (take-abs pcs)))  pcs)
511          (else (f (drop-abs rcs) (drop-abs pcs))))))
512
513;; Normalise a file
514;;  Posix:   normalise "/file/\\test////" == "/file/\\test/"
515;;  Posix:   normalise "/file/./test" == "/file/test"
516;;  Posix:   normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/"
517;;  Posix:   normalise "../bob/fred/" == "../bob/fred/"
518;;  Posix:   normalise "./bob/fred/" == "bob/fred/"
519;;  Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\"
520;;  Windows: normalise "c:\\" == "C:\\"
521;;  Windows: normalise "\\\\server\\test" == "\\\\server\\test"
522;;  Windows: normalise "c:/file" == "C:\\file"
523;;           normalise "." == "."
524;;  Posix:   normalise "./" == "./"
525
526(define (normalise path)
527  (define (drop-dots ax)
528    (lambda (xs)
529      (match xs
530             ((#\. . (and rest (? pair?))) (drop-dots ax rest))
531             ((x . rest)  (drop-dots (cons x ax) rest))
532             (()          (reverse ax)))))
533
534  (define (prop-sep xs)
535    (match xs 
536           (((and a (? is-path-separator?)) (and b (? is-path-separator?)) . rest) 
537            (prop-sep (cons a rest)))
538           (((and a (? is-path-separator?)) . rest)
539            (cons path-separator (prop-set rest)))))
540
541  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
542
543  (match-let (((drv pth)  (split-drive path)))
544     (append (join-drive (normalize-drive drv) (f pth))
545             (if (and (not (null? pth)) (is-path-separator (last pth)))
546                 (list path-separator) (list)))))
547
548(define (normalise-drive drive)
549  (define (rep-slash x) (if (is-path-separator? x) path-separator x))
550  (if is-posix? drive
551      (let ((x2 (map rep-slash drive)))
552        (if (read-drive-letter x2) (map char-upcase x2) drive))))
553       
554
555;; information for validity functions on Windows
556;; see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
557
558(define bad-chars (list->char-set (string->list ":*?><|")))
559
560(define (is-bad-char? c)  (char-set-contains? bad-chars c))
561
562(define bad-elems
563  (map string->list
564       (list "CON"  "PRN"  "AUX"  "NUL"  "COM1" "COM2" 
565             "COM3" "COM4" "COM5" "COM6" "COM7" "COM8"
566             "COM9" "LPT1" "LPT2" "LPT3" "LPT4" "LPT5"
567             "LPT6" "LPT7" "LPT8" "LPT9" "CLOCK$")))
568
569
570(define (is-bad-elem? x) (member (map char-upcase (drop-extensions x)) bad-elems))
571
572(define (is-valid? p)
573  (let ((pcs (if (string? p) (string->list p) p)))
574    (and (not (null? pcs))
575         (or is-posix?
576             (let ((pcs1 (drop-drive pcs)))
577               (and (not (any is-bad-char? pcs1))
578                    (not (any is-bad-elem? (split-directories pcs1)))
579                    (not (and (>= (length pcs) 2) 
580                              (every is-path-separator? pcs)))))))))
581                   
582
583;; Take a FilePath and make it valid; does not change already valid FilePaths.
584;; isValid x ==> makeValid x == x
585;; makeValid "" == "_"
586;; Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test"
587;; Windows: makeValid "test*" == "test_"
588;; Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_"
589;; Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt"
590;; Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt"
591;; Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file"
592
593(define (valid-chars p)
594  (map (lambda (x) (if (is-bad-char? x) #\_ x)) p))
595
596(define (valid-elements p)
597  (define (g x) 
598    (match-let (((a b) (span is-path-separator? (reverse x))))
599               (append (h (reverse b)) (reverse a))))
600  (define (h x)
601    (match-let ((( a b) (split-extensions x)))
602               (if (is-bad-elem? a) (add-extension (append a (list #\_)) b) x)))
603  (join-path (map g (split-path p))))
604
605(define (make-valid p)
606  (let ((pcs (if (string? p) (string->list p) p)))
607    (cond ((null? pcs)  (list #\_))
608          (is-posix?    pcs)
609          ((and (>= (length pcs) 2) (every is-path-separator? pcs))
610           (append (take pcs 2) (string->list "drive")))
611          (else (match-let (((drv pth) (split-drive pcs)))
612                           (join-drive drv (valid-elements (valid-chars pth))))))))
613
614
615;; Is a path relative, or is it fixed to the root?
616;; Windows: isRelative "path\\test" == True
617;; Windows: isRelative "c:\\test" == False
618;; Windows: isRelative "c:test" == True
619;; Windows: isRelative "c:" == True
620;; Windows: isRelative "\\\\foo" == False
621;; Windows: isRelative "/foo" == True
622;; Posix:   isRelative "test/path" == True
623;; Posix:   isRelative "/test" == False
624
625(define (is-relative? p)
626  (is-relative-drive? (take-drive p)))
627
628
629(define (is-relative-drive? p)
630  (not (is-path-separator? (last (first (read-drive-letter p))))))
631
632(define (is-absolute? p)
633  (not (is-relative? p)))
634
635
636;;; Exported interface
637
638(define filepath:path-separator path-separator)
639(define filepath:path-separator-set path-separator-set)
640(define filepath:is-path-separator? is-path-separator?)
641
642(define filepath:search-path-separator search-path-separator)
643(define filepath:is-search-path-separator? is-search-path-separator?)
644(define filepath:ext-separator ext-separator)
645(define filepath:is-ext-separator? is-ext-separator?)
646
647;; wrappers that take a char-list result from an internal procedure
648;; and convert it to a string
649
650  ;; Path methods (environment $PATH)
651(define filepath:split-search-path (compose list->string split-search-path))
652(define filepath:get-search-path   (compose list->string get-search-path))
653
654  ;; Extension procedures
655(define filepath:split-extension    (compose list->string split-extension))
656(define filepath:take-extension     (compose list->string  take-extension))
657(define filepath:replace-extension  (compose list->string replace-extension))
658(define filepath:drop-extension     (compose list->string drop-extension))
659(define filepath:add-extension      (compose list->string add-extension))
660(define filepath:split-extensions   (compose list->string split-extensions))
661(define filepath:drop-extensions    (compose list->string drop-extensions))
662(define filepath:take-extensions    (compose list->string take-extensions))
663(define filepath:has-extension? has-extension?)
664
665;; Drive procedures
666(define filepath:split-drive  (compose list->string split-drive))
667(define filepath:join-drive   (compose list->string join-drive))
668(define filepath:take-drive   (compose list->string take-drive))
669(define filepath:has-drive    (compose list->string has-drive)) 
670(define filepath:drop-drive   (compose list->string drop-drive)) 
671(define filepath:is-drive?    is-drive?)
672
673;; Operations on a file path, as a list of directories
674(define filepath:split-file-name   (compose list->string split-file-name))
675(define filepath:take-file-name    (compose list->string take-file-name))
676(define filepath:replace-file-name (compose list->string replace-file-name))
677(define filepath:drop-file-name    (compose list->string drop-file-name))
678(define filepath:take-base-name    (compose list->string take-base-name))
679(define filepath:replace-base-name (compose list->string replace-base-name))
680(define filepath:take-directory    (compose list->string take-directory))
681(define filepath:replace-directory (compose list->string replace-directory))
682(define filepath:combine           (compose list->string combine))
683(define filepath:split-path        (compose list->string split-path))
684(define filepath:join-path         (compose list->string join-path))
685(define filepath:split-directories (compose list->string split-directories))
686
687;; Low-level procedures
688(define filepath:add-trailing-path-separator (compose list->string add-trailing-path-separator))
689(define filepath:drop-trailing-path-separator (compose list->string drop-trailing-path-separator))
690(define filepath:has-trailing-path-separator? has-trailing-path-separator?)
691
692;; File name manipulators
693(define filepath:normalise      (compose list->string normalise ))
694(define filepath:make-relative  (compose list->string make-relative ))
695(define filepath:make-valid     (compose list->string make-valid ))
696(define filepath:is-valid?      is-valid? )
697(define filepath:path-equal?    path-equal?)
698(define filepath:is-relative?   is-relative?) 
699(define filepath:is-absolute?   is-absolute?)
Note: See TracBrowser for help on using the repository browser.