source: project/chicken/branches/prerelease/files.scm @ 13240

Last change on this file since 13240 was 13240, checked in by felix winkelmann, 11 years ago

merged trunk svn rev. 13239 into prerelease

File size: 13.0 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)
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-search string-match regexp regexp-escape
53      ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
54      ##sys#hash-table-for-each ##sys#macro-environment
55      ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
56      for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
57      decompose-pathname absolute-pathname? string-append ##sys#substring
58      delete-file system)
59    (no-procedure-checks-for-usual-bindings)
60    (no-bound-checks))] )
61
62(include "unsafe-declarations.scm")
63
64(register-feature! 'files)
65
66
67;;; Like `delete-file', but does nothing if the file doesn't exist:
68
69(define delete-file*
70  (let ([file-exists? file-exists?]
71        [delete-file delete-file] )
72    (lambda (file)
73      (and (file-exists? file) (delete-file file) #t) ) ) )
74
75;;; file-copy and file-move : they do what you'd think.
76(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
77    (##sys#check-string origfile 'file-copy)
78    (##sys#check-string newfile 'file-copy)
79    (##sys#check-number blocksize 'file-copy)
80    (or (and (integer? blocksize) (> blocksize 0))
81        (##sys#error (string-append
82                         "invalid blocksize given: not a positive integer - "
83                         (number->string blocksize))))
84    (or (file-exists? origfile)
85        (##sys#error (string-append "origfile does not exist - " origfile)))
86    (and (file-exists? newfile)
87         (or clobber
88             (##sys#error (string-append
89                              "newfile exists but clobber is false - "
90                              newfile))))
91    (let* ((i   (condition-case (open-input-file origfile)
92                    (val ()
93                        (##sys#error (string-append
94                                         "could not open origfile for read - "
95                                         origfile)))))
96           (o   (condition-case (open-output-file newfile)
97                    (val ()
98                        (##sys#error (string-append
99                                         "could not open newfile for write - "
100                                         newfile)))))
101           (s   (make-string blocksize)))
102        (let loop ((d   (read-string! blocksize s i))
103                   (l   0))
104            (if (= 0 d)
105                (begin
106                    (close-input-port i)
107                    (close-output-port o)
108                    l)
109                (begin
110                    (condition-case (write-string s d o)
111                        (val ()
112                            (close-input-port i)
113                            (close-output-port o)
114                            (##sys#error (string-append
115                                             "error writing file starting at "
116                                             (number->string l)))))
117                    (loop (read-string! blocksize s i) (+ d l)))))))
118
119(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
120    (##sys#check-string origfile 'file-move)
121    (##sys#check-string newfile 'file-move)
122    (##sys#check-number blocksize 'file-move)
123    (or (and (integer? blocksize) (> blocksize 0))
124        (##sys#error (string-append
125                         "invalid blocksize given: not a positive integer - "
126                         (number->string blocksize))))
127    (or (file-exists? origfile)
128        (##sys#error (string-append "origfile does not exist - " origfile)))
129    (and (file-exists? newfile)
130         (or clobber
131             (##sys#error (string-append
132                              "newfile exists but clobber is false - "
133                              newfile))))
134    (let* ((i   (condition-case (open-input-file origfile)
135                    (val ()
136                        (##sys#error (string-append
137                                         "could not open origfile for read - "
138                                         origfile)))))
139           (o   (condition-case (open-output-file newfile)
140                    (val ()
141                        (##sys#error (string-append
142                                         "could not open newfile for write - "
143                                         newfile)))))
144           (s   (make-string blocksize)))
145        (let loop ((d   (read-string! blocksize s i))
146                   (l   0))
147            (if (= 0 d)
148                (begin
149                    (close-input-port i)
150                    (close-output-port o)
151                    (condition-case (delete-file origfile)
152                        (val ()
153                            (##sys#error (string-append
154                                             "could not remove origfile - "
155                                             origfile))))
156                    l)
157                (begin
158                    (condition-case (write-string s d o)
159                        (val ()
160                            (close-input-port i)
161                            (close-output-port o)
162                            (##sys#error (string-append
163                                             "error writing file starting at "
164                                             (number->string l)))))
165                    (loop (read-string! blocksize s i) (+ d l)))))))
166
167;;; Pathname operations:
168
169(define absolute-pathname?
170  (let ([string-match string-match]
171        [regexp regexp]
172        [string-append string-append])
173    (let* ([drv (if ##sys#windows-platform "([A-Za-z]:)?" "")]
174           [patt (string-append drv "[\\/\\\\].*")]
175           [rx (regexp patt)] )
176      (lambda (pn)
177        (##sys#check-string pn 'absolute-pathname?)
178        (pair? (string-match rx pn)) ) ) ) )
179
180(define (chop-pds str pds)
181  (and str
182       (let ((len (##sys#size str))
183             (pdslen (if pds (##sys#size pds) 1)))
184         (if (and (fx>= len 1)
185                  (if pds
186                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
187                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
188                            '(#\/ #\\) ) ) )
189             (##sys#substring str 0 (fx- len pdslen))
190             str) ) ) )
191
192(define make-pathname)
193(define make-absolute-pathname)
194(let ([string-append string-append]
195      [absolute-pathname? absolute-pathname?]
196      [def-pds "/"] )
197
198  (define (conc-dirs dirs pds)
199    (##sys#check-list dirs 'make-pathname)
200    (let loop ([strs dirs])
201      (if (null? strs)
202          ""
203          (let ((s1 (car strs)))
204            (if (zero? (string-length s1))
205                (loop (cdr strs))
206                (string-append
207                 (chop-pds (car strs) pds)
208                 (or pds def-pds)
209                 (loop (cdr strs))) ) ) ) ) )
210
211  (define (canonicalize-dirs dirs pds)
212    (cond [(or (not dirs) (null? dirs)) ""]
213          [(string? dirs) (conc-dirs (list dirs) pds)]
214          [else           (conc-dirs dirs pds)] ) )
215
216  (define (_make-pathname loc dir file ext pds)
217    (let ([ext (or ext "")]
218          [file (or file "")]
219          [pdslen (if pds (##sys#size pds) 1)] )
220      (##sys#check-string dir loc)
221      (##sys#check-string file loc)
222      (##sys#check-string ext loc)
223      (when pds (##sys#check-string pds loc))
224      (string-append
225       dir
226       (if (and (fx>= (##sys#size file) pdslen)
227                (if pds
228                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
229                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
230           (##sys#substring file pdslen (##sys#size file))
231           file)
232       (if (and (fx> (##sys#size ext) 0)
233                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
234           "."
235           "")
236       ext) ) )
237
238  (set! make-pathname
239    (lambda (dirs file #!optional ext pds)
240      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
241
242  (set! make-absolute-pathname
243    (lambda (dirs file #!optional ext pds)
244      (_make-pathname
245       'make-absolute-pathname
246       (let ([dir (canonicalize-dirs dirs pds)])
247         (if (absolute-pathname? dir)
248             dir
249             (##sys#string-append (or pds def-pds) dir)) )
250       file ext pds) ) ) )
251
252(define decompose-pathname
253  (let ([string-match string-match]
254        [regexp regexp]
255        [string-append string-append])
256    (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
257           [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
258           [rx1 (regexp patt1)]
259           [rx2 (regexp patt2)]
260           [strip-pds
261             (lambda (dir)
262                (and dir
263                     (if (member dir '("/" "\\"))
264                         dir
265                         (chop-pds dir #f) ) ) )] )
266      (lambda (pn)
267        (##sys#check-string pn 'decompose-pathname)
268        (if (fx= 0 (##sys#size pn))
269            (values #f #f #f)
270            (let ([ms (string-match rx1 pn)])
271              (if ms
272                  (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
273                  (let ([ms (string-match rx2 pn)])
274                    (if ms
275                        (values (strip-pds (cadr ms)) (caddr ms) #f)
276                        (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
277
278(define pathname-directory)
279(define pathname-file)
280(define pathname-extension)
281(define pathname-strip-directory)
282(define pathname-strip-extension)
283(define pathname-replace-directory)
284(define pathname-replace-file)
285(define pathname-replace-extension)
286(let ([decompose-pathname decompose-pathname])
287
288  (set! pathname-directory
289    (lambda (pn)
290      (let-values ([(dir file ext) (decompose-pathname pn)])
291        dir) ) )
292
293  (set! pathname-file
294    (lambda (pn)
295      (let-values ([(dir file ext) (decompose-pathname pn)])
296        file) ) )
297
298  (set! pathname-extension
299    (lambda (pn)
300      (let-values ([(dir file ext) (decompose-pathname pn)])
301        ext) ) )
302
303  (set! pathname-strip-directory
304    (lambda (pn)
305      (let-values ([(dir file ext) (decompose-pathname pn)])
306        (make-pathname #f file ext) ) ) )
307
308  (set! pathname-strip-extension
309    (lambda (pn)
310      (let-values ([(dir file ext) (decompose-pathname pn)])
311        (make-pathname dir file) ) ) )
312
313  (set! pathname-replace-directory
314    (lambda (pn dir)
315      (let-values ([(_ file ext) (decompose-pathname pn)])
316        (make-pathname dir file ext) ) ) )
317
318  (set! pathname-replace-file
319    (lambda (pn file)
320      (let-values ([(dir _ ext) (decompose-pathname pn)])
321        (make-pathname dir file ext) ) ) )
322
323  (set! pathname-replace-extension
324    (lambda (pn ext)
325      (let-values ([(dir file _) (decompose-pathname pn)])
326        (make-pathname dir file ext) ) ) ) )
327
328(define create-temporary-file
329  (let ([getenv getenv]
330        [make-pathname make-pathname]
331        [file-exists? file-exists?]
332        [call-with-output-file call-with-output-file] )
333    (lambda ext
334      (let ([dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP"))]
335            [ext (if (pair? ext) (car ext) "tmp")])
336        (##sys#check-string ext 'create-temporary-file)
337        (let loop ()
338          (let* ([n (##sys#fudge 16)]
339                 [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
340            (if (file-exists? pn)
341                (loop)
342                (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
343
344
345;;; normalize pathname for a particular platform
346
347(define (normalize-pathname path #!optional (platform (build-platform)))
348  (case platform
349    ((mingw32 msvc)
350     (string-translate path "/" "\\"))
351    (else path)))
352
353
354;; Directory string or list only contains path-separators
355;; and/or current-directory names.
356
357(define (directory-null? dir)
358  (let loop ([lst
359              (if (list? dir)
360                  dir ; Don't bother to check for strings here
361                  (begin
362                    (##sys#check-string dir 'directory-null?)
363                    (string-split dir "/\\" #t)))])
364    (or (null? lst)
365        (and (member (car lst) '("" "."))
366             (loop (cdr lst)) ) ) ) )
Note: See TracBrowser for help on using the repository browser.