~ chicken-core (master) /file.scm
Trap1;;;; file.scm - File operations
2;
3; Copyright (c) 2008-2022, The CHICKEN Team
4; Copyright (c) 2000-2007, Felix L. Winkelmann
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 are
9; 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 the
16; documentation and/or other materials provided with the distribution.
17;
18; Neither the name of the author nor the names of its contributors may
19; be used to endorse or promote products derived from this software
20; without specific prior written permission.
21;
22; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
23; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
24; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
25; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
26; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
27; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
28; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
29; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
30; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
31; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
32; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
33; DAMAGE.
34
35
36(declare
37 (unit file)
38 (uses extras irregex pathname)
39 (fixnum)
40 (disable-interrupts)
41 (foreign-declare #<<EOF
42#include <errno.h>
43
44/* For Windows */
45#ifndef R_OK
46# define R_OK 2
47#endif
48#ifndef W_OK
49# define W_OK 4
50#endif
51#ifndef X_OK
52# define X_OK 2
53#endif
54
55#if defined(_WIN32) && !defined(__CYGWIN__)
56# include <direct.h>
57# define C_test_access(fn, m) C_fix(_waccess(C_utf16(fn, 0), C_unfix(m)))
58
59static C_word C_rename(C_word old, C_word new) {
60 wchar_t *s = C_utf16(old, 0), *s2 = C_utf16(new, 1);
61 _wremove(s2);
62 return(C_fix(_wrename(s, s2)));
63}
64
65# define C_remove(str) C_fix(_wremove(C_utf16(str, 0)))
66# define C_rmdir(str) C_fix(_wrmdir(C_utf16(str, 0)))
67# define C_mkdir(str) C_fix(_wmkdir(C_utf16(str, 0)))
68#else
69# include <sys/stat.h>
70# define C_test_access(fn, m) C_fix(access(C_c_string(fn), C_unfix(m)))
71# define C_rename(old, new) C_fix(rename(C_c_string(old), C_c_string(new)))
72# define C_remove(str) C_fix(remove(C_c_string(str)))
73# define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
74# define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
75#endif
76
77#include <sys/types.h>
78#include <dirent.h>
79
80#if defined(_WIN32) && !defined(__CYGWIN__)
81# define C_opendir(s,h) C_set_block_item(h, 0, (C_word) _wopendir(C_utf16(s, 0)))
82
83static C_word C_foundfile(C_word e,C_word b,C_word l) {
84 C_char *s = C_utf8(((struct _wdirent *)C_block_item(e, 0))->d_name);
85 C_strlcpy(C_c_string(b), s, C_unfix(l));
86 return(C_fix(strlen(s)));
87}
88# define C_readdir(h,e) C_set_block_item(e, 0, (C_word) _wreaddir((_WDIR *)C_block_item(h, 0)))
89# define C_closedir(h) (_wclosedir((_WDIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
90#else
91# define C_opendir(s,h) C_set_block_item(h, 0, (C_word) opendir(C_c_string(s)))
92# define C_foundfile(e,b,l) (C_strlcpy(C_c_string(b), ((struct dirent *)C_block_item(e, 0))->d_name, C_unfix(l)), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
93
94# define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
95# define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
96#endif
97
98static C_word C_u_i_symbolic_linkp(C_word path)
99{
100#if !defined(_WIN32) || defined(__CYGWIN__)
101 struct stat buf;
102 if (lstat(C_c_string(path), &buf) == 0)
103 return C_mk_bool(S_ISLNK(buf.st_mode));
104#endif
105 return C_SCHEME_FALSE;
106}
107
108EOF
109))
110
111(module chicken.file
112 (create-directory delete-directory
113 create-temporary-file create-temporary-directory
114 delete-file delete-file* copy-file move-file rename-file
115 file-exists? directory-exists?
116 file-readable? file-writable? file-executable?
117 directory find-files glob)
118
119(import scheme
120 chicken.base
121 chicken.condition
122 chicken.fixnum
123 chicken.foreign
124 chicken.io
125 chicken.irregex
126 chicken.pathname
127 chicken.process-context)
128
129(include "common-declarations.scm")
130
131(define-foreign-variable strerror c-string "strerror(errno)")
132
133;; TODO: Some duplication from POSIX, to give better error messages.
134;; This really isn't so much posix-specific, and code like this is
135;; also in library.scm. This should be deduplicated across the board.
136(define posix-error
137 (let ([strerror (foreign-lambda c-string "strerror" int)]
138 [string-append string-append] )
139 (lambda (type loc msg . args)
140 (let ([rn (##sys#update-errno)])
141 (apply ##sys#signal-hook/errno
142 type rn loc (string-append msg " - " (strerror rn)) args)))))
143
144
145;;; Existence checks:
146
147(define (file-exists? name)
148 (##sys#check-string name 'file-exists?)
149 (and (##sys#file-exists? name #f #f 'file-exists?) name))
150
151(define (directory-exists? name)
152 (##sys#check-string name 'directory-exists?)
153 (and (##sys#file-exists? name #f #t 'directory-exists?) name))
154
155
156;;; Permissions:
157
158(define-foreign-variable _r_ok int "R_OK")
159(define-foreign-variable _w_ok int "W_OK")
160(define-foreign-variable _x_ok int "X_OK")
161
162(define (test-access filename acc loc)
163 (##sys#check-string filename loc)
164 (let ((r (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc)))
165 (or (fx= r 0)
166 (if (fx= (##sys#update-errno) (foreign-value "EACCES" int))
167 #f
168 (posix-error #:file-error loc "cannot access file" filename)))))
169
170(define (file-readable? filename) (test-access filename _r_ok 'file-readable?))
171(define (file-writable? filename) (test-access filename _w_ok 'file-writable?))
172(define (file-executable? filename) (test-access filename _x_ok 'file-executable?))
173
174
175;;; Directories:
176
177(define (directory #!optional (spec (current-directory)) show-dotfiles?)
178 (##sys#check-string spec 'directory)
179 (let ((buffer (##sys#make-bytevector 256))
180 (handle (##sys#make-pointer))
181 (entry (##sys#make-pointer)))
182 (##core#inline
183 "C_opendir"
184 (##sys#make-c-string spec 'directory) handle)
185 (if (##sys#null-pointer? handle)
186 (posix-error #:file-error 'directory "cannot open directory" spec)
187 (let loop ()
188 (##core#inline "C_readdir" handle entry)
189 (if (##sys#null-pointer? entry)
190 (begin (##core#inline "C_closedir" handle) '())
191 (let* ((flen (##core#inline "C_foundfile" entry buffer (##sys#size buffer)))
192 (file (##sys#buffer->string buffer 0 flen))
193 (char1 (string-ref file 0))
194 (char2 (and (fx> flen 1) (string-ref file 1))))
195 (if (and (eq? #\. char1)
196 (or (not char2)
197 (and (eq? #\. char2) (eq? 2 flen))
198 (not show-dotfiles?)))
199 (loop)
200 (cons file (loop)))))))))
201
202(define-inline (*symbolic-link? name loc)
203 (##core#inline "C_u_i_symbolic_linkp" (##sys#make-c-string name loc)))
204
205(define-inline (*create-directory loc name)
206 (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
207 (posix-error #:file-error loc "cannot create directory" name)))
208
209(define create-directory
210 (lambda (name #!optional recursive)
211 (##sys#check-string name 'create-directory)
212 (unless (or (fx= 0 (string-length name))
213 (file-exists? name))
214 (if recursive
215 (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
216 (if file (make-pathname dir file ext) dir))))
217 (when (and dir (not (directory-exists? dir)))
218 (loop (pathname-directory dir))
219 (*create-directory 'create-directory dir)))
220 (*create-directory 'create-directory name)))
221 name))
222
223(define delete-directory
224 (lambda (name #!optional recursive)
225 (define (rmdir dir)
226 (let ((sname (##sys#make-c-string dir)))
227 (unless (fx= 0 (##core#inline "C_rmdir" sname))
228 (posix-error #:file-error 'delete-directory "cannot delete directory" dir))))
229 (##sys#check-string name 'delete-directory)
230 (if recursive
231 (let ((files (find-files ; relies on `find-files' to list dir-contents before dir
232 name
233 dotfiles: #t
234 follow-symlinks: #f)))
235 (for-each
236 (lambda (f)
237 ((cond ((*symbolic-link? f 'delete-directory) delete-file)
238 ((directory-exists? f) rmdir)
239 (else delete-file))
240 f))
241 files)
242 (rmdir name))
243 (rmdir name))))
244
245
246;;; File management:
247
248(define (delete-file filename)
249 (##sys#check-string filename 'delete-file)
250 (unless (eq? 0 (##core#inline "C_remove" (##sys#make-c-string filename 'delete-file)))
251 (##sys#signal-hook/errno
252 #:file-error (##sys#update-errno) 'delete-file
253 (##sys#string-append "cannot delete file - " strerror) filename))
254 filename)
255
256(define (delete-file* file)
257 (and (file-exists? file) (delete-file file)))
258
259(define (rename-file oldfile newfile #!optional (clobber #f))
260 (##sys#check-string oldfile 'rename-file)
261 (##sys#check-string newfile 'rename-file)
262 (when (and (not clobber) (file-exists? newfile))
263 (##sys#error 'rename-file "newfile exists but clobber is false" newfile))
264 (unless (eq? 0 (##core#inline
265 "C_rename"
266 (##sys#make-c-string oldfile 'rename-file)
267 (##sys#make-c-string newfile 'rename-file)))
268 (##sys#signal-hook/errno
269 #:file-error (##sys#update-errno) 'rename-file
270 (##sys#string-append "cannot rename file - " strerror) oldfile newfile))
271 newfile)
272
273(define (copy-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
274 (##sys#check-string oldfile 'copy-file)
275 (##sys#check-string newfile 'copy-file)
276 (##sys#check-number blocksize 'copy-file)
277 (unless (and (integer? blocksize) (> blocksize 0))
278 (##sys#error 'copy-file "invalid blocksize - not a positive integer" blocksize))
279 (when (directory-exists? oldfile)
280 (##sys#error 'copy-file "cannot copy directories" oldfile))
281 (when (and (not clobber) (file-exists? newfile))
282 (##sys#error 'copy-file "newfile exists but clobber is false" newfile))
283 (let* ((i (open-input-file oldfile #:binary))
284 (o (open-output-file newfile #:binary))
285 (s (##sys#make-bytevector blocksize)))
286 (let loop ((d (read-bytevector! s i))
287 (l 0))
288 (if (fx= 0 d)
289 (begin
290 (close-input-port i)
291 (close-output-port o)
292 l)
293 (begin
294 (write-bytevector s o 0 d)
295 (loop (read-bytevector! s i) (fx+ d l)))))))
296
297(define (move-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
298 (##sys#check-string oldfile 'move-file)
299 (##sys#check-string newfile 'move-file)
300 (##sys#check-number blocksize 'move-file)
301 (unless (and (integer? blocksize) (> blocksize 0))
302 (##sys#error 'move-file "invalid blocksize - not a positive integer" blocksize))
303 (when (directory-exists? oldfile)
304 (##sys#error 'move-file "cannot move directories" oldfile))
305 (when (and (not clobber) (file-exists? newfile))
306 (##sys#error 'move-file "newfile exists but clobber is false" newfile))
307 (let* ((i (open-input-file oldfile #:binary))
308 (o (open-output-file newfile #:binary))
309 (s (##sys#make-bytevector blocksize)))
310 (let loop ((d (read-bytevector! s i))
311 (l 0))
312 (if (fx= 0 d)
313 (begin
314 (close-input-port i)
315 (close-output-port o)
316 (delete-file oldfile)
317 l)
318 (begin
319 (write-bytevector s o 0 d)
320 (loop (read-bytevector! s i) (fx+ d l)))))))
321
322
323;;; Temporary file creation:
324
325(define create-temporary-file)
326(define create-temporary-directory)
327
328(let ((temp-prefix "temp")
329 (string-append string-append))
330 (define (tempdir)
331 (or (get-environment-variable "TMPDIR")
332 (get-environment-variable "TEMP")
333 (get-environment-variable "TMP")
334 (if ##sys#windows-platform
335 (let ((up (get-environment-variable "USERPROFILE")))
336 (if up
337 (string-append up "/AppData/Local/Temp")
338 "."))
339 "/tmp")))
340 (set! create-temporary-file
341 (lambda (#!optional (ext "tmp"))
342 (##sys#check-string ext 'create-temporary-file)
343 (let loop ()
344 (let* ((n (##core#inline "C_random_fixnum" #x10000))
345 (getpid (foreign-lambda int "C_getpid"))
346 (pn (make-pathname
347 (tempdir)
348 (string-append
349 temp-prefix
350 (number->string n 16)
351 "."
352 (##sys#number->string (getpid)))
353 ext)))
354 (if (file-exists? pn)
355 (loop)
356 (call-with-output-file pn (lambda (p) pn)))))))
357 (set! create-temporary-directory
358 (lambda ()
359 (let loop ()
360 (let* ((n (##core#inline "C_random_fixnum" #x10000))
361 (getpid (foreign-lambda int "C_getpid"))
362 (pn (make-pathname
363 (tempdir)
364 (string-append
365 temp-prefix
366 (number->string n 16)
367 "."
368 (##sys#number->string (getpid))))))
369 (if (file-exists? pn)
370 (loop)
371 (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 'create-temporary-directory))))
372 (if (eq? r 0)
373 pn
374 (##sys#signal-hook
375 #:file-error 'create-temporary-directory
376 (##sys#string-append "cannot create temporary directory - " strerror)
377 pn)))))))))
378
379
380;;; Filename globbing:
381
382(define (glob . paths)
383 (let conc-loop ((paths paths))
384 (if (null? paths)
385 '()
386 (let ((path (car paths)))
387 (let-values (((dir fil ext) (decompose-pathname path)))
388 (let ((dir* (or dir "."))
389 (rx (irregex (glob->sre (make-pathname #f (or fil "*") ext)))))
390 (let loop ((fns (condition-case (directory dir* #t)
391 ((exn i/o file) #f))))
392 (cond ((not (pair? fns)) (conc-loop (cdr paths)))
393 ((irregex-match rx (car fns)) =>
394 (lambda (m)
395 (cons (make-pathname dir (irregex-match-substring m))
396 (loop (cdr fns)))))
397 (else (loop (cdr fns)))))))))))
398
399
400;;; Find matching files:
401
402(define (find-files dir #!key (test (lambda _ #t))
403 (action (lambda (x y) (cons x y)))
404 (seed '())
405 (limit #f)
406 (dotfiles #f)
407 (follow-symlinks #f))
408 (##sys#check-string dir 'find-files)
409 (let* ((depth 0)
410 (lproc
411 (cond ((not limit) (lambda _ #t))
412 ((fixnum? limit) (lambda _ (fx< depth limit)))
413 (else limit)))
414 (pproc
415 (if (procedure? test)
416 test
417 (let ((test (irregex test))) ; force compilation
418 (lambda (x) (irregex-match test x))))))
419 (let loop ((dir dir)
420 (fs (directory dir dotfiles))
421 (r seed))
422 (if (null? fs)
423 r
424 (let* ((filename (##sys#slot fs 0))
425 (f (make-pathname dir filename))
426 (rest (##sys#slot fs 1)))
427 (cond ((directory-exists? f)
428 (cond ((member filename '("." "..")) (loop dir rest r))
429 ((and (*symbolic-link? f 'find-files) (not follow-symlinks))
430 (loop dir rest (if (pproc f) (action f r) r)))
431 ((lproc f)
432 (loop dir
433 rest
434 (fluid-let ((depth (fx+ depth 1)))
435 (loop f
436 (directory f dotfiles)
437 (if (pproc f) (action f r) r)))))
438 (else (loop dir rest (if (pproc f) (action f r) r)))))
439 ((pproc f) (loop dir rest (action f r)))
440 (else (loop dir rest r))))))))
441
442)