~ chicken-core (master) /file.scm


  1;;;; 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)
Trap