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

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

Fixed some incorrect variable references.

File size: 24.5 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-all-extensions filepath:drop-all-extensions filepath:take-all-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
120;; Utility char procedures
121
122(define (is-letter? c)  (char-set-contains? char-set:letter c))
123
124;; (define char-upcase-map
125;;   (zip (char-set->list char-set:lower-case)
126;;        (char-set->list char-set:upper-case)))
127
128;; (define (char-upcase c) (or (safe-car (alist-ref c char-upcase-map)) c))
129
130;; (define char-downcase-map
131;;   (zip (char-set->list char-set:upper-case)
132;;        (char-set->list char-set:lower-case)))
133
134;; (define (char-downcase c) (or (safe-car (alist-ref c char-downcase-map)) c))
135
136
137;; Is the operating system environment POSIX or Windows like
138
139(define is-posix?
140  (make-parameter 
141   (or (equal? (software-type) 'unix)
142       (equal? (software-type 'macos)))
143   boolean?))
144 
145(define is-windows?
146  (make-parameter
147   (equal? (software-type) 'windows)
148   boolean?))
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     (match (reverse (scatter is-ext-separator? b))
209            ((c . d) (let ((ext  c) 
210                           (fp   (append a (intersperse (reverse d) ext-separator))))
211                       (list fp ext)))
212            (else    (list pcs ""))))))
213
214(define (take-extension p)
215  (second (split-extension p)))
216
217(define (drop-extension p)
218  (first (split-extension p)))
219
220(define (replace-extension p ext)
221  (add-extension (drop-extension p) ext))
222
223(define (add-extension p ext)
224  (let ((ecs (if (string? ext) (string->list ext) ext))
225        (pcs (if (string? p) (string->list p) p)))
226    (if (prefix? ext-separator ecs)
227        (append p ext)
228        (append p (list ext-separator) ext))))
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? (let-values (((pre rest) (span is-path-separator? pcs)))
247                                   (list  pre rest)))
248        (read-drive-letter p)
249        (read-drive-unc p)
250        (read-drive-share p)
251        (list (list) p))))
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    (match (break is-path-separator? ncs)
301           ((a b)  (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                 ((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    (match-let (((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    (match-let (((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:path-separator path-separator)
640(define filepath:path-separator-set path-separator-set)
641(define filepath:is-path-separator? is-path-separator?)
642
643(define filepath:search-path-separator search-path-separator)
644(define filepath:is-search-path-separator? is-search-path-separator?)
645(define filepath:ext-separator ext-separator)
646(define filepath:is-ext-separator? is-ext-separator?)
647
648;; wrappers that take a char-list result from an internal procedure
649;; and convert it to a string
650
651  ;; Path methods (environment $PATH)
652(define filepath:split-search-path (compose list->string split-search-path))
653(define filepath:get-search-path   (compose list->string get-search-path))
654
655  ;; Extension procedures
656(define filepath:split-extension    (compose list->string split-extension))
657(define filepath:take-extension     (compose list->string  take-extension))
658(define filepath:replace-extension  (compose list->string replace-extension))
659(define filepath:drop-extension     (compose list->string drop-extension))
660(define filepath:add-extension      (compose list->string add-extension))
661(define filepath:split-all-extensions   (compose list->string split-all-extensions))
662(define filepath:drop-all-extensions    (compose list->string drop-all-extensions))
663(define filepath:take-all-extensions    (compose list->string take-all-extensions))
664(define filepath:has-extension? has-extension?)
665
666;; Drive procedures
667(define filepath:split-drive  (compose list->string split-drive))
668(define filepath:join-drive   (compose list->string join-drive))
669(define filepath:take-drive   (compose list->string take-drive))
670(define filepath:drop-drive   (compose list->string drop-drive)) 
671(define filepath:has-drive?   has-drive?)
672(define filepath:is-drive?    is-drive?)
673
674;; Operations on a file path, as a list of directories
675(define filepath:split-file-name   (compose list->string split-file-name))
676(define filepath:take-file-name    (compose list->string take-file-name))
677(define filepath:replace-file-name (compose list->string replace-file-name))
678(define filepath:drop-file-name    (compose list->string drop-file-name))
679(define filepath:take-base-name    (compose list->string take-base-name))
680(define filepath:replace-base-name (compose list->string replace-base-name))
681(define filepath:take-directory    (compose list->string take-directory))
682(define filepath:replace-directory (compose list->string replace-directory))
683(define filepath:combine           (compose list->string combine))
684(define filepath:split-path        (compose list->string split-path))
685(define filepath:join-path         (compose list->string join-path))
686(define filepath:split-directories (compose list->string split-directories))
687
688;; Low-level procedures
689(define filepath:add-trailing-path-separator (compose list->string add-trailing-path-separator))
690(define filepath:drop-trailing-path-separator (compose list->string drop-trailing-path-separator))
691(define filepath:has-trailing-path-separator? has-trailing-path-separator?)
692
693;; File name manipulators
694(define filepath:normalise      (compose list->string normalise ))
695(define filepath:make-relative  (compose list->string make-relative ))
696(define filepath:make-valid     (compose list->string make-valid ))
697(define filepath:is-valid?      is-valid? )
698(define filepath:path-equal?    path-equal?)
699(define filepath:is-relative?   is-relative?) 
700(define filepath:is-absolute?   is-absolute?)
Note: See TracBrowser for help on using the repository browser.