source: project/release/4/filepath/trunk/filepath.scm @ 25923

Last change on this file since 25923 was 25923, checked in by Ivan Raikov, 10 years ago

filepath: fixed a bug in is-relative-drive (thanks to Christian Kellermann for reporting the issue)

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