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

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

More bug fixes and additional unit tests.

File size: 24.9 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? filepath:search-path-separator
61  filepath:is-search-path-separator? 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  (match-let (((a b)  (split-file-name p)))
234    (match (scatter is-ext-separator? b)
235           ((c . d)  (list a (intersperse b (ext-separator))))
236           (else     (list p (list))))))
237
238(define (drop-all-extensions p)
239  (first (split-all-extensions p)))
240
241(define (take-all-extensions p)
242  (second (split-all-extensions p)))
243
244(define (split-drive p)
245  (let ((pcs (if (string? p) (string->list p) p)))
246    (or (and (is-posix?) 
247             (let-values (((pre rest) (span is-path-separator? pcs)))
248                         (and (not (null? pre)) (list pre rest))))
249        (read-drive-letter pcs)
250        (read-drive-unc pcs)
251        (read-drive-share pcs)
252        (list (list) pcs))))
253
254(define (add-slash a xs)
255  (let ((xcs (if (string? xs) (string->list xs) xs))
256        (acs (if (string? a) (string->list a) a)))
257    (let-values (((c d) (span is-path-separator? xcs)))
258                (list (append acs c) d))))
259
260;; http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
261;; "\\?\D:\<path>" or "\\?\UNC\<server>\<share>"
262;; a is "\\?\"
263
264(define (read-drive-unc p)
265  (let ((pcs (if (string? p) (string->list p) p)))
266    (match pcs 
267           (((and s1 (? is-path-separator?)) 
268             (and s2 (? is-path-separator?))
269             #\? (and s3 (? is-path-separator?)) . xs)
270            (let ((us (map char-upcase xs)))
271              (match us 
272                     ((#\U #\N #\C (and s4 (? is-path-separator?)) . _)
273                      (match (read-drive-share-name (drop xs 4))
274                             ((a b)  (list (cons* s1 s2 #\? s3 (append (take xs 4) a)) b))))
275                     (else
276                      (match (read-drive-letter xs)
277                             ((a b) (list (cons* s1 s2 #\? s3 a) b))
278                             (else  #f))))))
279           (else #f))))
280
281
282(define (read-drive-letter p)
283  (let ((pcs (if (string? p) (string->list p) p)))
284    (match pcs
285           (((and x (? is-letter?))  #\: (and y (? is-path-separator?)) . xs)
286            (add-slash (list x #\:) (cons y xs)))
287           (((and x (? is-letter?)) #\: . xs) 
288            (list (list x #\:) xs))
289           (else #f))))
290
291(define (read-drive-share p)
292  (let ((pcs (if (string? p) (string->list p) p)))
293    (match pcs
294           (((and s1 (? is-path-separator?)) (and s2 (? is-path-separator?)) . xs)
295            (match-let (((a b)  (read-drive-share-name xs)))
296                       (list (cons* s1 s2 a) b)))
297           (else #f))))
298
299(define (read-drive-share-name n)
300  (let ((ncs (if (string? n) (string->list n) n)))
301    (let-values (((a b) (break is-path-separator? ncs)))
302                (and (not (null? a)) (add-slash a b)))))
303
304
305;; Join a drive and the rest of the path.
306;;  Windows: joinDrive "C:" "foo" == "C:foo"
307;;  Windows: joinDrive "C:\\" "bar" == "C:\\bar"
308;;  Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo"
309;;  Windows: joinDrive "/:" "foo" == "/:\\foo"
310
311(define (join-drive a b)
312  (let ((acs (if (string? a) (string->list a) a))
313        (bcs (if (string? b) (string->list b) b)))
314  (cond ((is-posix?)    (append acs bcs))
315        ((null? acs)  bcs)
316        ((null? bcs)  acs)
317        ((is-path-separator? (last acs)) (append acs bcs))
318        (else (match acs
319                     (((and a1 (? is-letter?)) #\:) (append acs bcs))
320                     (else (append acs (list (path-separator)) bcs)))))))
321
322
323(define (take-drive p)  (first (split-drive p)))
324
325(define (drop-drive p)  (second (split-drive p)))
326
327(define (has-drive? p)  (not (null? (take-drive p))))
328
329(define (is-drive? p)   (null? (drop-drive p)))
330
331
332;; Operations on a filepath, as a list of directories
333
334;;; Split a filename into directory and file. 'combine' is the inverse.
335(define (split-file-name p)
336  (let ((pcs (if (string? p) (string->list p) p)))
337    (match-let (((c d)  (split-drive pcs)))
338      (let-values (((a b)  (break is-path-separator? (reverse d))))
339                  (list (append c (reverse b)) (reverse a))))))
340
341(define (replace-file-name p r)
342  (drop-file-name (combine p r)))
343
344(define (drop-file-name p) (first (split-file-name p)))
345
346(define (take-file-name p) (second (split-file-name p)))
347
348(define (take-base-name p) (drop-extension (take-file-name p)))
349
350(define (replace-base-name p name) 
351  (let ((ncs (if (string? name) (string->list name) name)))
352    (match-let (((a b) (split-file-name p)))
353       (let* ((ext (take-extension b))
354              (ext (if (prefix? (list (ext-separator)) ext) ext 
355                       (cons (ext-separator) ext))))
356         (combine-always a (append ncs ext))))))
357
358;; Is an item either a directory or the last character a path separator?
359(define (has-trailing-path-separator? p)
360  (let ((pcs (if (string? p) (string->list p) p)))
361    (and (not (null? pcs)) (is-path-separator? (last pcs)))))
362 
363(define (add-trailing-path-separator p)
364  (let ((pcs (if (string? p) (string->list p) p)))
365    (if (has-trailing-path-separator? pcs) pcs 
366        (append pcs (list (path-separator))))))
367
368(define (drop-trailing-path-separator p)
369  (let ((pcs (if (string? p) (string->list p) p)))
370    (if (and (has-trailing-path-separator? pcs) (not (is-drive? pcs)))
371        (reverse (drop-while is-path-separator? (reverse pcs))) pcs)))
372
373(define (take-directory p)
374  (let ((pcs (if (string? p) (string->list p) p)))
375    (let* ((fn   (drop-file-name pcs))
376           (res  (reverse (drop-while is-path-separator? (reverse fn)))))
377      (if (is-drive? fn) fn
378          (if (and (null? res) (not (null? fn))) fn
379              res)))))
380           
381(define (replace-directory p dir)
382  (let ((pcs (if (string? p) (string->list p) p))
383        (dcs (if (string? dir) (string->list dir) dir)))
384    (combine-always dir (take-file-name pcs))))
385
386
387;; Combine two paths, if the second path 'isAbsolute', then it returns the second.
388;;
389;; Posix:   combine "/" "test" == "/test"
390;; Posix:   combine "home" "bob" == "home/bob"
391;; Windows: combine "home" "bob" == "home\\bob"
392;; Windows: combine "home" "/bob" == "/bob"
393
394(define (combine a b)
395  (let ((acs (if (string? a) (string->list a) a))
396        (bcs (if (string? b) (string->list b) b)))
397    (cond ((or (has-drive? bcs) (and (not (null? bcs)) (is-path-separator? (first bcs)))) bcs)
398          (else (combine-always acs bcs)))))
399
400;; Combine two paths, assuming rhs is NOT absolute.
401(define (combine-always a b)
402  (let ((acs (if (string? a) (string->list a) a))
403        (bcs (if (string? b) (string->list b) b)))
404    (cond ((null? acs) bcs)
405          ((null? bcs) acs)
406          ((is-path-separator? (last acs))  (append acs bcs))
407          ((is-drive? acs)  (join-drive acs bcs))
408          (else (append acs (list (path-separator)) bcs)))))
409
410
411;; Split a path by the directory separator.
412;; splitPath "test//item/" == ["test//","item/"]
413;; splitPath "test/item/file" == ["test/","item/","file"]
414;; splitPath "" == []
415;; Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"]
416;; Posix:   splitPath "/file/test" == ["/","file/","test"]
417
418(define (split-path p )
419  (define (f y) 
420    (if (null? y) y
421        (let*-values (((a b) (break is-path-separator? y))
422                      ((c d) (break (lambda (x) (not (is-path-separator? x))) b)))
423          (cons (append a c) (f d)))))
424  (let ((pcs (if (string? p) (string->list p) p)))
425    (match-let (((drive path)  (split-drive pcs)))
426               (append (if (null? drive) (list) (list drive)) (f path)))))
427
428;; Just as 'splitPath', but don't add the trailing slashes to each element.
429;; splitDirectories "test/file" == ["test","file"]
430;; splitDirectories "/test/file" == ["/","test","file"]
431;; splitDirectories "" == []
432
433(define (split-directories p)
434  (define (g x)
435    (let ((res (take-while (lambda (x) (not (is-path-separator? x))) x)))
436      (if (null? res) x res)))
437  (let* ((pcs (if (string? p) (string->list p) p))
438         (path-components (split-path pcs)))
439    (if (has-drive? pcs) 
440        (cons (car path-components) (map g (cdr path-components)))
441        (map g path-components))))
442
443
444;; Join path elements back together.
445;; joinPath [] == ""
446;; Posix: joinPath ["test","file","path"] == "test/file/path"
447
448(define (join-path p)
449  (let ((pcs (if (string? p) (string->list p) p)))
450    (fold-right combine (list) pcs)))
451
452
453;; Equality of two 'FilePath's.
454;;  Note that this doesn't follow symlinks or DOSNAM~1s.
455;;   Posix:   equalFilePath "foo" "foo/"
456;;   Posix:   not (equalFilePath "foo" "/foo")
457;;   Posix:   not (equalFilePath "foo" "FOO")
458;;   Windows: equalFilePath "foo" "FOO"
459
460(define (path-equal? a b)
461  (define (f x) 
462    (if (is-windows?) (drop-trail-slash (map char-downcase (normalise x)))
463        (drop-trail-slash (normalise x))))
464  (define (drop-trail-slash x)
465    (if (and (>= (length x) 2) (is-path-separator? (last x)))
466        (drop-right x 1) x))
467  (let ((acs (if (string? a) (string->list a) a))
468        (bcs (if (string? b) (string->list b) b)))
469    (equal? (f acs) (f bcs))))
470
471
472;; Contract a filename, based on a relative path.
473;; Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob"
474;; Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob"
475;; Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob"
476;; Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob"
477;; Windows: makeRelative "/Home" "/home/bob" == "bob"
478;; Posix:   makeRelative "/Home" "/home/bob" == "/home/bob"
479;; Posix:   makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar"
480;; Posix:   makeRelative "/fred" "bob" == "bob"
481;; Posix:   makeRelative "/file/test" "/file/test/fred" == "fred"
482;; Posix:   makeRelative "/file/test" "/file/test/fred/" == "fred/"
483;; Posix:   makeRelative "some/path" "some/path/a/b/c" == "a/b/c"
484
485(define (make-relative root path)
486  (define (drop-abs p) 
487    (match p (((and x (? is-path-separator?)) . xs) xs)
488           (else (drop-drive p))))
489
490  (define (take-abs p)
491    (match p (((and x (? is-path-separator?)) . xs) (list (path-separator)))
492           (else (map (lambda (y) (if (is-path-separator? y) (path-separator) (char-downcase y))) 
493                      (take-drive p)))))
494
495  (define (f x y pcs)
496    (if (null? x) (drop-while is-path-separator? y)
497        (match-let (((x1 x2)  (g x))
498                    ((y1 y2)  (g y)))
499                   (if (path-equal? x1 y1) (f x2 y2 pcs) pcs))))
500
501  (define (g x)
502    (let-values (((a b)  (break is-path-separator? (drop-while is-path-separator? x))))
503       (list (drop-while is-path-separator? a) (drop-while is-path-separator? b) )))
504
505  (let ((pcs (if (string? path) (string->list path) path))
506        (rcs (if (string? root) (string->list root) root)))
507
508    (cond ((path-equal? rcs pcs)  (list #\.))
509          ((not (equal? (take-abs rcs) (take-abs pcs)))  pcs)
510          (else (f (drop-abs rcs) (drop-abs pcs) pcs)))))
511
512;; Normalise a file
513;;  Posix:   normalise "/file/\\test////" == "/file/\\test/"
514;;  Posix:   normalise "/file/./test" == "/file/test"
515;;  Posix:   normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/"
516;;  Posix:   normalise "../bob/fred/" == "../bob/fred/"
517;;  Posix:   normalise "./bob/fred/" == "bob/fred/"
518;;  Posix:   normalise "./" == "./"
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
525(define (normalise path)
526  (define (drop-dots ax)
527    (lambda (xs)
528      (match xs
529             (((#\.) . (and rest (? pair?))) ((drop-dots ax) rest))
530             ((x . rest)  ((drop-dots (cons x ax)) rest))
531             (()          (reverse ax)))))
532
533  (define (prop-sep xs)
534    (match xs 
535           (((and a (? is-path-separator?)) (and b (? is-path-separator?)) . rest) 
536            (prop-sep (cons a rest)))
537           (((and a (? is-path-separator?)) . rest)
538            (cons (path-separator) (prop-sep rest)))
539           ((x . rest)
540            (cons x (prop-sep rest)))
541           (() xs)))
542
543  (define f (compose join-path (drop-dots (list)) split-directories prop-sep))
544
545  (match-let (((drv pth)  (split-drive path)))
546     (append (join-drive (normalise-drive drv) (f pth))
547             (if (and (not (null? pth)) (is-path-separator? (last pth)))
548                 (list (path-separator)) (list)))))
549
550(define (normalise-drive drive)
551  (define (rep-slash x) (if (is-path-separator? x) (path-separator) x))
552  (if (is-posix?) drive
553      (let ((x2 (map rep-slash drive)))
554        (if (read-drive-letter x2) (map char-upcase x2) drive))))
555       
556
557
558;; information for validity functions on Windows
559;; see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp
560
561(define bad-chars (list->char-set (string->list ":*?><|")))
562
563(define (is-bad-char? c)  (char-set-contains? bad-chars c))
564
565(define bad-elems
566  (map string->list
567       (list "CON"  "PRN"  "AUX"  "NUL"  "COM1" "COM2" 
568             "COM3" "COM4" "COM5" "COM6" "COM7" "COM8"
569             "COM9" "LPT1" "LPT2" "LPT3" "LPT4" "LPT5"
570             "LPT6" "LPT7" "LPT8" "LPT9" "CLOCK$")))
571
572
573(define (is-bad-elem? x) 
574  (member (map char-upcase (drop-all-extensions x)) bad-elems))
575
576(define (is-valid? p)
577  (let ((pcs (if (string? p) (string->list p) p)))
578    (and (not (null? pcs))
579         (or (is-posix?)
580             (let ((pcs1 (drop-drive pcs)))
581               (and (not (any is-bad-char? pcs1))
582                    (not (any is-bad-elem? (split-directories pcs1)))
583                    (not (and (>= (length pcs) 2) 
584                              (every is-path-separator? pcs)))))))))
585                   
586
587;; Take a FilePath and make it valid; does not change already valid FilePaths.
588;; isValid x ==> makeValid x == x
589;; makeValid "" == "_"
590;; Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test"
591;; Windows: makeValid "test*" == "test_"
592;; Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_"
593;; Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt"
594;; Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt"
595;; Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file"
596
597(define (valid-chars p)
598  (map (lambda (x) (if (is-bad-char? x) #\_ x)) p))
599
600(define (valid-elements p)
601  (define (g x) 
602    (let-values (((a b) (span is-path-separator? (reverse x))))
603                (append (h (reverse b)) (reverse a))))
604  (define (h x)
605    (match-let ((( a b) (split-all-extensions x)))
606               (if (is-bad-elem? a) (add-extension (append a (list #\_)) b) x)))
607  (join-path (map g (split-path p))))
608
609(define (make-valid p)
610  (let ((pcs (if (string? p) (string->list p) p)))
611    (cond ((null? pcs)  (list #\_))
612          ((is-posix?)    pcs)
613          ((and (>= (length pcs) 2) (every is-path-separator? pcs))
614           (append (take pcs 2) (string->list "drive")))
615          (else (match-let (((drv pth) (split-drive pcs)))
616                           (join-drive drv (valid-elements (valid-chars pth))))))))
617
618
619;; Is a path relative, or is it fixed to the root?
620;; Windows: isRelative "path\\test" == True
621;; Windows: isRelative "c:\\test" == False
622;; Windows: isRelative "c:test" == True
623;; Windows: isRelative "c:" == True
624;; Windows: isRelative "\\\\foo" == False
625;; Windows: isRelative "/foo" == True
626;; Posix:   isRelative "test/path" == True
627;; Posix:   isRelative "/test" == False
628
629(define (is-relative? p)
630  (is-relative-drive? (take-drive p)))
631
632
633(define (is-relative-drive? p)
634  (not (is-path-separator? (last (first (read-drive-letter p))))))
635
636(define (is-absolute? p)
637  (not (is-relative? p)))
638
639
640;;; Exported interface
641
642(define filepath:is-posix?    is-posix?)
643(define filepath:is-windows?  is-windows?)
644
645(define filepath:path-separator path-separator)
646(define filepath:path-separator-set path-separator-set)
647(define filepath:is-path-separator? is-path-separator?)
648
649(define filepath:search-path-separator search-path-separator)
650(define filepath:is-search-path-separator? is-search-path-separator?)
651(define filepath:ext-separator ext-separator)
652(define filepath:is-ext-separator? is-ext-separator?)
653
654;; wrappers that take a char-list result from an internal procedure
655;; and convert it to a string
656
657(define (list-wrapper lst) 
658  (begin ; (print "lst = " lst)
659         (map list->string lst)))
660
661  ;; Path methods (environment $PATH)
662(define filepath:split-search-path (compose list-wrapper split-search-path))
663(define filepath:get-search-path   (compose list-wrapper get-search-path))
664
665  ;; Extension procedures
666(define filepath:split-extension    (compose list-wrapper split-extension))
667(define filepath:take-extension     (compose list->string  take-extension))
668(define filepath:drop-extension     (compose list->string drop-extension))
669(define filepath:replace-extension  (compose list->string replace-extension))
670(define filepath:add-extension      (compose list->string add-extension))
671(define filepath:split-all-extensions   (compose list-wrapper split-all-extensions))
672(define filepath:drop-all-extensions    (compose list->string drop-all-extensions))
673(define filepath:take-all-extensions    (compose list->string take-all-extensions))
674(define filepath:has-extension? has-extension?)
675
676;; Drive procedures
677(define filepath:split-drive  (compose list-wrapper split-drive))
678(define filepath:join-drive   (compose list->string join-drive))
679(define filepath:take-drive   (compose list->string take-drive))
680(define filepath:drop-drive   (compose list->string drop-drive)) 
681(define filepath:has-drive?   has-drive?)
682(define filepath:is-drive?    is-drive?)
683
684;; Operations on a file path, as a list of directories
685(define filepath:split-file-name   (compose list-wrapper split-file-name))
686(define filepath:take-file-name    (compose list->string take-file-name))
687(define filepath:replace-file-name (compose list->string replace-file-name))
688(define filepath:drop-file-name    (compose list->string drop-file-name))
689(define filepath:take-base-name    (compose list->string take-base-name))
690(define filepath:replace-base-name (compose list->string replace-base-name))
691(define filepath:take-directory    (compose list->string take-directory))
692(define filepath:replace-directory (compose list->string replace-directory))
693(define filepath:combine           (compose list->string combine))
694(define filepath:split-path        (compose list-wrapper split-path))
695(define filepath:join-path         (compose list->string join-path))
696(define filepath:split-directories (compose list-wrapper split-directories))
697
698;; Low-level procedures
699(define filepath:add-trailing-path-separator (compose list->string add-trailing-path-separator))
700(define filepath:drop-trailing-path-separator (compose list->string drop-trailing-path-separator))
701(define filepath:has-trailing-path-separator? has-trailing-path-separator?)
702
703;; File name manipulators
704(define filepath:normalise      (compose list->string normalise ))
705(define filepath:make-relative  (compose list->string make-relative ))
706(define filepath:make-valid     (compose list->string make-valid ))
707(define filepath:is-valid?      is-valid? )
708(define filepath:path-equal?    path-equal?)
709(define filepath:is-relative?   is-relative?) 
710(define filepath:is-absolute?   is-absolute?)
Note: See TracBrowser for help on using the repository browser.