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

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

Some bug fixes and added file with test cases.

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