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

Last change on this file since 14940 was 13677, checked in by Kon Lovett, 11 years ago

Moved 'apropos' out. Added routines to encapsulate information the new apropos extension needs

File size: 12.7 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-match regexp
53      ##sys#string-append ##sys#substring  string-append
54      getenv
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(define absolute-pathname?
168  (let ([string-match string-match]
169        [regexp regexp]
170        [string-append string-append])
171    (let* ([drv (if ##sys#windows-platform "([A-Za-z]:)?" "")]
172           [patt (string-append drv "[\\/\\\\].*")]
173           [rx (regexp patt)] )
174      (lambda (pn)
175        (##sys#check-string pn 'absolute-pathname?)
176        (pair? (string-match rx pn)) ) ) ) )
177
178(define (chop-pds str pds)
179  (and str
180       (let ((len (##sys#size str))
181             (pdslen (if pds (##sys#size pds) 1)))
182         (if (and (fx>= len 1)
183                  (if pds
184                      (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
185                      (memq (##core#inline "C_subchar" str (fx- len pdslen))
186                            '(#\/ #\\) ) ) )
187             (##sys#substring str 0 (fx- len pdslen))
188             str) ) ) )
189
190(define make-pathname)
191(define make-absolute-pathname)
192(let ([string-append string-append]
193      [absolute-pathname? absolute-pathname?]
194      [def-pds "/"] )
195
196  (define (conc-dirs dirs pds)
197    (##sys#check-list dirs 'make-pathname)
198    (let loop ([strs dirs])
199      (if (null? strs)
200          ""
201          (let ((s1 (car strs)))
202            (if (zero? (string-length s1))
203                (loop (cdr strs))
204                (string-append
205                 (chop-pds (car strs) pds)
206                 (or pds def-pds)
207                 (loop (cdr strs))) ) ) ) ) )
208
209  (define (canonicalize-dirs dirs pds)
210    (cond [(or (not dirs) (null? dirs)) ""]
211          [(string? dirs) (conc-dirs (list dirs) pds)]
212          [else           (conc-dirs dirs pds)] ) )
213
214  (define (_make-pathname loc dir file ext pds)
215    (let ([ext (or ext "")]
216          [file (or file "")]
217          [pdslen (if pds (##sys#size pds) 1)] )
218      (##sys#check-string dir loc)
219      (##sys#check-string file loc)
220      (##sys#check-string ext loc)
221      (when pds (##sys#check-string pds loc))
222      (string-append
223       dir
224       (if (and (fx>= (##sys#size file) pdslen)
225                (if pds
226                    (##core#inline "C_substring_compare" pds file 0 0 pdslen)
227                    (memq (##core#inline "C_subchar" file 0) '(#\\ #\/))))
228           (##sys#substring file pdslen (##sys#size file))
229           file)
230       (if (and (fx> (##sys#size ext) 0)
231                (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
232           "."
233           "")
234       ext) ) )
235
236  (set! make-pathname
237    (lambda (dirs file #!optional ext pds)
238      (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
239
240  (set! make-absolute-pathname
241    (lambda (dirs file #!optional ext pds)
242      (_make-pathname
243       'make-absolute-pathname
244       (let ([dir (canonicalize-dirs dirs pds)])
245         (if (absolute-pathname? dir)
246             dir
247             (##sys#string-append (or pds def-pds) dir)) )
248       file ext pds) ) ) )
249
250(define decompose-pathname
251  (let ([string-match string-match]
252        [regexp regexp]
253        [string-append string-append])
254    (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
255           [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
256           [rx1 (regexp patt1)]
257           [rx2 (regexp patt2)]
258           [strip-pds
259             (lambda (dir)
260                (and dir
261                     (if (member dir '("/" "\\"))
262                         dir
263                         (chop-pds dir #f) ) ) )] )
264      (lambda (pn)
265        (##sys#check-string pn 'decompose-pathname)
266        (if (fx= 0 (##sys#size pn))
267            (values #f #f #f)
268            (let ([ms (string-match rx1 pn)])
269              (if ms
270                  (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
271                  (let ([ms (string-match rx2 pn)])
272                    (if ms
273                        (values (strip-pds (cadr ms)) (caddr ms) #f)
274                        (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
275
276(define pathname-directory)
277(define pathname-file)
278(define pathname-extension)
279(define pathname-strip-directory)
280(define pathname-strip-extension)
281(define pathname-replace-directory)
282(define pathname-replace-file)
283(define pathname-replace-extension)
284(let ([decompose-pathname decompose-pathname])
285
286  (set! pathname-directory
287    (lambda (pn)
288      (let-values ([(dir file ext) (decompose-pathname pn)])
289        dir) ) )
290
291  (set! pathname-file
292    (lambda (pn)
293      (let-values ([(dir file ext) (decompose-pathname pn)])
294        file) ) )
295
296  (set! pathname-extension
297    (lambda (pn)
298      (let-values ([(dir file ext) (decompose-pathname pn)])
299        ext) ) )
300
301  (set! pathname-strip-directory
302    (lambda (pn)
303      (let-values ([(dir file ext) (decompose-pathname pn)])
304        (make-pathname #f file ext) ) ) )
305
306  (set! pathname-strip-extension
307    (lambda (pn)
308      (let-values ([(dir file ext) (decompose-pathname pn)])
309        (make-pathname dir file) ) ) )
310
311  (set! pathname-replace-directory
312    (lambda (pn dir)
313      (let-values ([(_ file ext) (decompose-pathname pn)])
314        (make-pathname dir file ext) ) ) )
315
316  (set! pathname-replace-file
317    (lambda (pn file)
318      (let-values ([(dir _ ext) (decompose-pathname pn)])
319        (make-pathname dir file ext) ) ) )
320
321  (set! pathname-replace-extension
322    (lambda (pn ext)
323      (let-values ([(dir file _) (decompose-pathname pn)])
324        (make-pathname dir file ext) ) ) ) )
325
326(define create-temporary-file
327  (let ([getenv getenv]
328        [make-pathname make-pathname]
329        [file-exists? file-exists?]
330        [call-with-output-file call-with-output-file] )
331    (lambda ext
332      (let ([dir (or (getenv "TMPDIR") (getenv "TEMP") (getenv "TMP"))]
333            [ext (if (pair? ext) (car ext) "tmp")])
334        (##sys#check-string ext 'create-temporary-file)
335        (let loop ()
336          (let* ([n (##sys#fudge 16)]
337                 [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
338            (if (file-exists? pn)
339                (loop)
340                (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
341
342
343;;; normalize pathname for a particular platform
344
345(define (normalize-pathname path #!optional (platform (build-platform)))
346  (case platform
347    ((mingw32 msvc)
348     (string-translate path "/" "\\"))
349    (else path)))
350
351
352;; Directory string or list only contains path-separators
353;; and/or current-directory names.
354
355(define (directory-null? dir)
356  (let loop ([lst
357              (if (list? dir)
358                  dir ; Don't bother to check for strings here
359                  (begin
360                    (##sys#check-string dir 'directory-null?)
361                    (string-split dir "/\\" #t)))])
362    (or (null? lst)
363        (and (member (car lst) '("" "."))
364             (loop (cdr lst)) ) ) ) )
Note: See TracBrowser for help on using the repository browser.