source: project/chicken/trunk/files.scm @ 15819

Last change on this file since 15819 was 15819, checked in by Kon Lovett, 10 years ago

files, path-tests Fix for "empty" but absolute pathnames
library, runtime, chicken Better names for experimental "module" introspection
files Deprecated 'make-pathname' separator argument

File size: 16.5 KB
Line 
1;;;; files.scm - File and pathname operations
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
5; All rights reserved.
6;
7; Redistribution and use in source and binary forms, with or without
8; modification, are permitted provided that the following conditions
9; are met:
10;
11;   Redistributions of source code must retain the above copyright
12;   notice, this list of conditions and the following disclaimer.
13;
14;   Redistributions in binary form must reproduce the above copyright
15;   notice, this list of conditions and the following disclaimer in
16;   the documentation and/or other materials provided with the
17;   distribution.
18;
19;   Neither the name of the author nor the names of its contributors
20;     may be used to endorse or promote products derived from this
21;     software without specific prior written permission.
22;
23; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
24; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
25; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
26; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
27; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
28; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
29; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
30; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
31; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
32; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
33; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
34; OF THE POSSIBILITY OF SUCH DAMAGE.
35
36
37(declare
38  (unit files)
39  (uses regex data-structures)
40  (usual-integrations)
41  (fixnum)
42  (hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
43  (disable-interrupts) )
44
45(cond-expand
46 [paranoia]
47 [else
48  (declare
49    (always-bound
50      ##sys#windows-platform)
51    (bound-to-procedure
52      string-match regexp
53      ##sys#string-append ##sys#substring  string-append
54      get-environment-variable
55      file-exists? delete-file
56      call-with-output-file read-string)
57    (no-procedure-checks-for-usual-bindings)
58    (no-bound-checks))] )
59
60(include "unsafe-declarations.scm")
61
62(register-feature! 'files)
63
64
65;;; Like `delete-file', but does nothing if the file doesn't exist:
66
67(define delete-file*
68  (let ([file-exists? file-exists?]
69        [delete-file delete-file] )
70    (lambda (file)
71      (and (file-exists? file) (delete-file file) #t) ) ) )
72
73;;; file-copy and file-move : they do what you'd think.
74(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
75    (##sys#check-string origfile 'file-copy)
76    (##sys#check-string newfile 'file-copy)
77    (##sys#check-number blocksize 'file-copy)
78    (or (and (integer? blocksize) (> blocksize 0))
79        (##sys#error (string-append
80                         "invalid blocksize given: not a positive integer - "
81                         (number->string blocksize))))
82    (or (file-exists? origfile)
83        (##sys#error (string-append "origfile does not exist - " origfile)))
84    (and (file-exists? newfile)
85         (or clobber
86             (##sys#error (string-append
87                              "newfile exists but clobber is false - "
88                              newfile))))
89    (let* ((i   (condition-case (open-input-file origfile)
90                    (val ()
91                        (##sys#error (string-append
92                                         "could not open origfile for read - "
93                                         origfile)))))
94           (o   (condition-case (open-output-file newfile)
95                    (val ()
96                        (##sys#error (string-append
97                                         "could not open newfile for write - "
98                                         newfile)))))
99           (s   (make-string blocksize)))
100        (let loop ((d   (read-string! blocksize s i))
101                   (l   0))
102            (if (= 0 d)
103                (begin
104                    (close-input-port i)
105                    (close-output-port o)
106                    l)
107                (begin
108                    (condition-case (write-string s d o)
109                        (val ()
110                            (close-input-port i)
111                            (close-output-port o)
112                            (##sys#error (string-append
113                                             "error writing file starting at "
114                                             (number->string l)))))
115                    (loop (read-string! blocksize s i) (+ d l)))))))
116
117(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
118    (##sys#check-string origfile 'file-move)
119    (##sys#check-string newfile 'file-move)
120    (##sys#check-number blocksize 'file-move)
121    (or (and (integer? blocksize) (> blocksize 0))
122        (##sys#error (string-append
123                         "invalid blocksize given: not a positive integer - "
124                         (number->string blocksize))))
125    (or (file-exists? origfile)
126        (##sys#error (string-append "origfile does not exist - " origfile)))
127    (and (file-exists? newfile)
128         (or clobber
129             (##sys#error (string-append
130                              "newfile exists but clobber is false - "
131                              newfile))))
132    (let* ((i   (condition-case (open-input-file origfile)
133                    (val ()
134                        (##sys#error (string-append
135                                         "could not open origfile for read - "
136                                         origfile)))))
137           (o   (condition-case (open-output-file newfile)
138                    (val ()
139                        (##sys#error (string-append
140                                         "could not open newfile for write - "
141                                         newfile)))))
142           (s   (make-string blocksize)))
143        (let loop ((d   (read-string! blocksize s i))
144                   (l   0))
145            (if (= 0 d)
146                (begin
147                    (close-input-port i)
148                    (close-output-port o)
149                    (condition-case (delete-file origfile)
150                        (val ()
151                            (##sys#error (string-append
152                                             "could not remove origfile - "
153                                             origfile))))
154                    l)
155                (begin
156                    (condition-case (write-string s d o)
157                        (val ()
158                            (close-input-port i)
159                            (close-output-port o)
160                            (##sys#error (string-append
161                                             "error writing file starting at "
162                                             (number->string l)))))
163                    (loop (read-string! blocksize s i) (+ d l)))))))
164
165;;; Pathname operations:
166
167;; Platform specific absolute pathname operations:
168;; absolute-pathname-root => #f or (<match> [<origin>] <root>)
169;;
170;; Not for general consumption
171
172(define absolute-pathname-root)
173(define root-origin)
174(define root-directory)
175(let ((string-match string-match))
176  (if ##sys#windows-platform
177      (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
178        (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
179        (set! root-origin (lambda (rt) (and rt (cadr rt))))
180        (set! root-directory (lambda (rt) (and rt (caddr rt)))) )
181      (let ((rx (regexp "([\\/\\\\]).*")))
182        (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
183        (set! root-origin (lambda (rt) #f))
184        (set! root-directory (lambda (rt) (and rt (cadr rt)))) ) ) )
185
186(define (absolute-pathname? pn)
187  (##sys#check-string pn 'absolute-pathname?)
188  (pair? (absolute-pathname-root pn)) )
189
190(define-inline (*char-pds? ch) (memq ch '(#\\ #\/)))
191
192(define (chop-pds str pds)
193  (and str
194       (let ((len (##sys#size str))
195             (pdslen (if pds (##sys#size pds) 1)))
196         (if (and (fx>= len 1)
197                  (if pds
198                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
199                      (*char-pds? (##core#inline "C_subchar" str (fx- len pdslen)) ) ) )
200             (##sys#substring str 0 (fx- len pdslen))
201             str) ) ) )
202
203(define make-pathname)
204(define make-absolute-pathname)
205(let ([string-append string-append]
206      [absolute-pathname? absolute-pathname?]
207      [def-pds "/"] )
208
209  (define (conc-dirs dirs pds)
210    (##sys#check-list dirs 'make-pathname)
211    (let loop ([strs dirs])
212      (if (null? strs)
213          ""
214          (let ((s1 (car strs)))
215            (if (zero? (string-length s1))
216                (loop (cdr strs))
217                (string-append
218                 (chop-pds (car strs) pds)
219                 (or pds def-pds)
220                 (loop (cdr strs))) ) ) ) ) )
221
222  (define (canonicalize-dirs dirs pds)
223    (cond [(or (not dirs) (null? dirs)) ""]
224          [(string? dirs) (conc-dirs (list dirs) pds)]
225          [else           (conc-dirs dirs pds)] ) )
226
227  (define (_make-pathname loc dir file ext pds)
228    (let ([ext (or ext "")]
229          [file (or file "")]
230          [pdslen (if pds (##sys#size pds) 1)] )
231      (##sys#check-string dir loc)
232      (##sys#check-string file loc)
233      (##sys#check-string ext loc)
234      (when pds (##sys#check-string pds loc))
235      (string-append
236       dir
237       (if (and (fx>= (##sys#size file) pdslen)
238                (if pds
239                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
240                    (*char-pds? (##core#inline "C_subchar" file 0))))
241           (##sys#substring file pdslen (##sys#size file))
242           file)
243       (if (and (fx> (##sys#size ext) 0)
244                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
245           "."
246           "")
247       ext) ) )
248
249  (set! make-pathname
250    (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
251      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
252
253  (set! make-absolute-pathname
254    (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
255      (_make-pathname
256       'make-absolute-pathname
257       (let ([dir (canonicalize-dirs dirs pds)])
258         (if (absolute-pathname? dir)
259             dir
260             (##sys#string-append (or pds def-pds) dir)) )
261       file ext pds) ) ) )
262
263(define decompose-pathname
264  (let ((string-match string-match))
265    (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
266           [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
267           [rx1 (regexp patt1)]
268           [rx2 (regexp patt2)]
269           [strip-pds
270             (lambda (dir)
271               (and dir
272                    (if (member dir '("/" "\\"))
273                        dir
274                        (chop-pds dir #f) ) ) )] )
275      (lambda (pn)
276        (##sys#check-string pn 'decompose-pathname)
277        (if (fx= 0 (##sys#size pn))
278            (values #f #f #f)
279            (let ([ms (string-match rx1 pn)])
280              (if ms
281                  (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
282                  (let ([ms (string-match rx2 pn)])
283                    (if ms
284                        (values (strip-pds (cadr ms)) (caddr ms) #f)
285                        (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
286
287(define pathname-directory)
288(define pathname-file)
289(define pathname-extension)
290(define pathname-strip-directory)
291(define pathname-strip-extension)
292(define pathname-replace-directory)
293(define pathname-replace-file)
294(define pathname-replace-extension)
295(let ([decompose-pathname decompose-pathname])
296
297  (set! pathname-directory
298    (lambda (pn)
299      (let-values ([(dir file ext) (decompose-pathname pn)])
300        dir) ) )
301
302  (set! pathname-file
303    (lambda (pn)
304      (let-values ([(dir file ext) (decompose-pathname pn)])
305        file) ) )
306
307  (set! pathname-extension
308    (lambda (pn)
309      (let-values ([(dir file ext) (decompose-pathname pn)])
310        ext) ) )
311
312  (set! pathname-strip-directory
313    (lambda (pn)
314      (let-values ([(dir file ext) (decompose-pathname pn)])
315        (make-pathname #f file ext) ) ) )
316
317  (set! pathname-strip-extension
318    (lambda (pn)
319      (let-values ([(dir file ext) (decompose-pathname pn)])
320        (make-pathname dir file) ) ) )
321
322  (set! pathname-replace-directory
323    (lambda (pn dir)
324      (let-values ([(_ file ext) (decompose-pathname pn)])
325        (make-pathname dir file ext) ) ) )
326
327  (set! pathname-replace-file
328    (lambda (pn file)
329      (let-values ([(dir _ ext) (decompose-pathname pn)])
330        (make-pathname dir file ext) ) ) )
331
332  (set! pathname-replace-extension
333    (lambda (pn ext)
334      (let-values ([(dir file _) (decompose-pathname pn)])
335        (make-pathname dir file ext) ) ) ) )
336
337(define create-temporary-file
338  (let ([get-environment-variable get-environment-variable]
339        [make-pathname make-pathname]
340        [file-exists? file-exists?]
341        [call-with-output-file call-with-output-file] )
342    (lambda ext
343      (let ((dir (or (get-environment-variable "TMPDIR") 
344                     (get-environment-variable "TEMP")
345                     (get-environment-variable "TMP")
346                     (file-exists? "/tmp")))
347            (ext (if (pair? ext) (car ext) "tmp")))
348        (##sys#check-string ext 'create-temporary-file)
349        (let loop ()
350          (let* ([n (##sys#fudge 16)]
351                 [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
352            (if (file-exists? pn)
353                (loop)
354                (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
355
356
357;;; normalize pathname for a particular platform
358
359(define normalize-pathname
360  (let ((open-output-string open-output-string)
361        (get-output-string get-output-string)
362        (get-environment-variable get-environment-variable)
363        (reverse reverse)
364        (display display)
365        (bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
366    (define (addpart part parts)
367      (cond ((string=? "." part)        parts )
368            ((string=? ".." part)       (if (null? parts) '("..") (cdr parts)) )
369            (else                       (cons part parts) ) ) )
370    (lambda (path #!optional (platform bldplt))
371      (let ((sep (if (eq? platform 'windows) #\\ #\/)))
372        (##sys#check-string path 'normalize-pathname)
373        (let ((len (##sys#size path))
374              (abspath #f)
375              (drive #f))
376          (let loop ((i 0) (prev 0) (parts '()))
377            (cond ((fx>= i len)
378                   (when (fx> i prev)
379                     (set! parts (addpart (##sys#substring path prev i) parts)))
380                   (if (null? parts)
381                       (if abspath
382                           (##sys#string-append (string sep) ".")
383                           (##sys#string-append "." (string sep)) )
384                       (let ((out (open-output-string))
385                             (parts (reverse parts)))
386                         (display (car parts) out)
387                         (for-each
388                          (lambda (p)
389                            (##sys#write-char-0 sep out)
390                            (display p out) )
391                          (cdr parts))
392                         (when (fx= i prev) (##sys#write-char-0 sep out))
393                         (let* ((r1 (get-output-string out))
394                                (r (##sys#expand-home-path r1)))
395                           (when (string=? r1 r)
396                             (when abspath 
397                               (set! r (##sys#string-append (string sep) r)))
398                             (when drive
399                               (set! r (##sys#string-append drive r))))
400                           r))))
401                  ((*char-pds? (string-ref path i))
402                   (when (and (null? parts) (fx= i prev))
403                     (set! abspath #t))
404                   (if (fx= i prev)
405                       (loop (fx+ i 1) (fx+ i 1) parts)
406                       (loop (fx+ i 1)
407                             (fx+ i 1)
408                             (addpart (##sys#substring path prev i) parts))))
409                  ((and (null? parts) 
410                        (char=? (string-ref path i) #\:)
411                        (eq? 'windows platform))
412                   (set! drive (##sys#substring path 0 (fx+ i 1)))
413                   (loop (fx+ i 1) (fx+ i 1) '()))
414                  (else (loop (fx+ i 1) prev parts)) ) ) ) ) ) ) )
415
416
417;; directory pathname => list of strings
418;; does arg check
419
420(define split-directory
421  (let ((string-split string-split) )
422    (lambda (loc dir keep?)
423      (##sys#check-string dir loc)
424      (string-split dir "/\\" keep?) ) ) )
425
426;; Directory string or list only contains path-separators
427;; and/or current-directory (".") names.
428
429(define (directory-null? dir)
430  (let loop ((ls (if (list? dir) dir (split-directory 'directory-null? dir #t))))
431    (or (null? ls)
432        (and (member (car ls) '("" "."))
433             (loop (cdr ls)) ) ) ) )
434
435;; Directory string => {<origin> <root> <directory-list>}
436;; where any maybe #f when missing
437
438(define (decompose-directory dir)
439  (define (strip-origin-prefix org decomp)
440    #;(assert (or (not org) decomp)) ;cannot have an "origin" but no "decomp"
441    (if (not org)
442        decomp
443        (let ((1st (car decomp)))
444          (let ((olen (##sys#size org)))
445            (if (not (##core#inline "C_substring_compare" org 1st 0 0 olen))
446                ; then origin is not a prefix (really shouldn't happen)
447                decomp
448                ; else is a prefix
449                (let ((rst (cdr decomp))
450                      (elen (##sys#size 1st)) )
451                  (if (fx= olen (##sys#size elen))
452                      ; then origin is a list prefix
453                      rst
454                      ; else origin is a string prefix
455                      (cons (##sys#substring 1st olen elen) rst) ) ) ) ) ) ) )
456  (let* ((ls (split-directory 'decompose-directory dir #f))
457         (rt (absolute-pathname-root dir))
458         (org (root-origin rt)) )
459    (values org (root-directory rt) (strip-origin-prefix org (and (not (null? ls)) ls))) ) )
Note: See TracBrowser for help on using the repository browser.