~ 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_char *p = s;
 86   while(*p != 0) {
 87     *p = *p == '\\' ? '/' : *p;
 88     ++p;
 89   }
 90   C_strlcpy(C_c_string(b), s, C_unfix(l));
 91   return(C_fix(C_strlen(s)));
 92}
 93# define C_readdir(h,e)      C_set_block_item(e, 0, (C_word) _wreaddir((_WDIR *)C_block_item(h, 0)))
 94# define C_closedir(h)       (_wclosedir((_WDIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
 95#else
 96# define C_opendir(s,h)      C_set_block_item(h, 0, (C_word) opendir(C_c_string(s)))
 97# 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)))
 98
 99# define C_readdir(h,e)      C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
100# define C_closedir(h)       (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
101#endif
102
103static C_word C_u_i_lstat(C_word path)
104{
105#if !defined(_WIN32) || defined(__CYGWIN__)
106  struct stat buf;
107  if (lstat(C_c_string(path), &buf) == 0)
108    return C_fix(buf.st_mode);
109#else
110  struct _stat buf;
111  if(_wstat(C_utf16(path, 0), &buf) == 0)
112    return C_SCHEME_TRUE;
113#endif
114  return C_SCHEME_FALSE;
115}
116
117#if !defined(_WIN32) || defined(__CYGWIN__)
118# define C_u_i_symbolic_linkp(m)		C_mk_bool(S_ISLNK(C_unfix(m)))
119#else
120# define C_u_i_symbolic_linkp(m)        C_SCHEME_FALSE
121#endif
122
123EOF
124))
125
126(module chicken.file
127  (create-directory delete-directory
128   create-temporary-file create-temporary-directory
129   delete-file delete-file* copy-file move-file rename-file
130   file-exists? directory-exists?
131   file-readable? file-writable? file-executable?
132   directory find-files glob)
133
134(import scheme
135	chicken.base
136	chicken.condition
137	chicken.fixnum
138	chicken.foreign
139	chicken.io
140	chicken.irregex
141	chicken.pathname
142	chicken.process-context)
143
144(include "common-declarations.scm")
145
146(define-foreign-variable strerror c-string "strerror(errno)")
147
148;; TODO: Some duplication from POSIX, to give better error messages.
149;; This really isn't so much posix-specific, and code like this is
150;; also in library.scm.  This should be deduplicated across the board.
151(define posix-error
152  (let ([strerror (foreign-lambda c-string "strerror" int)]
153	[string-append string-append] )
154    (lambda (type loc msg . args)
155      (let ([rn (##sys#update-errno)])
156        (apply ##sys#signal-hook/errno
157               type rn loc (string-append msg " - " (strerror rn)) args)))))
158
159
160;;; Existence checks:
161
162(define (file-exists? name)
163  (##sys#check-string name 'file-exists?)
164  (and (##sys#file-exists? name #f #f 'file-exists?) name))
165
166(define (directory-exists? name)
167  (##sys#check-string name 'directory-exists?)
168  (and (##sys#file-exists? name #f #t 'directory-exists?) name))
169
170
171;;; Permissions:
172
173(define-foreign-variable _r_ok int "R_OK")
174(define-foreign-variable _w_ok int "W_OK")
175(define-foreign-variable _x_ok int "X_OK")
176
177(define (test-access filename acc loc)
178  (##sys#check-string filename loc)
179  (let ((r (##core#inline "C_test_access" (##sys#make-c-string filename loc) acc)))
180    (or (fx= r 0)
181	(if (fx= (##sys#update-errno) (foreign-value "EACCES" int))
182	    #f
183	    (posix-error #:file-error loc "cannot access file" filename)))))
184
185(define (file-readable? filename) (test-access filename _r_ok 'file-readable?))
186(define (file-writable? filename) (test-access filename _w_ok 'file-writable?))
187(define (file-executable? filename) (test-access filename _x_ok 'file-executable?))
188
189
190;;; Directories:
191
192(define (directory #!optional (spec (current-directory)) show-dotfiles?)
193  (##sys#check-string spec 'directory)
194  (let ((buffer (##sys#make-bytevector 256))
195	(handle (##sys#make-pointer))
196	(entry (##sys#make-pointer)))
197    (##core#inline
198     "C_opendir"
199     (##sys#make-c-string spec 'directory) handle)
200    (if (##sys#null-pointer? handle)
201	(posix-error #:file-error 'directory "cannot open directory" spec)
202	(let loop ()
203	  (##core#inline "C_readdir" handle entry)
204	  (if (##sys#null-pointer? entry)
205	      (begin (##core#inline "C_closedir" handle) '())
206	      (let* ((flen (##core#inline "C_foundfile" entry buffer (##sys#size buffer)))
207		     (file (##sys#buffer->string buffer 0 flen))
208		     (char1 (string-ref file 0))
209		     (char2 (and (fx> flen 1) (string-ref file 1))))
210		(if (and (eq? #\. char1)
211			 (or (not char2)
212			     (and (eq? #\. char2) (eq? 2 flen))
213			     (not show-dotfiles?)))
214		    (loop)
215		    (cons file (loop)))))))))
216
217(define-inline (*lstat name loc)
218  (##core#inline "C_u_i_lstat" (##sys#make-c-string name loc)))
219
220(define-inline (*symbolic-link? m)
221  (##core#inline "C_u_i_symbolic_linkp" m))
222
223(define-inline (*create-directory loc name)
224  (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
225    (posix-error #:file-error loc "cannot create directory" name)))
226
227(define create-directory
228  (lambda (name #!optional recursive)
229    (##sys#check-string name 'create-directory)
230    (unless (or (fx= 0 (string-length name))
231                (file-exists? name))
232      (if recursive
233	  (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
234			    (if file (make-pathname dir file ext) dir))))
235	    (when (and dir (not (directory-exists? dir)))
236	      (loop (pathname-directory dir))
237	      (*create-directory 'create-directory dir)))
238	  (*create-directory 'create-directory name)))
239    name))
240
241(define delete-directory
242  (lambda (name #!optional recursive)
243    (define (rmdir dir)
244      (let ((sname (##sys#make-c-string dir)))
245	(when (and (not (fx= 0 (##core#inline "C_rmdir" sname)))
246	           (not (fx= (##sys#update-errno) (foreign-value "ENOENT" int))))
247	  (posix-error #:file-error 'delete-directory "cannot delete directory" dir))))
248    (##sys#check-string name 'delete-directory)
249    (if recursive
250	(let ((files (find-files ; relies on `find-files' to list dir-contents before dir
251		      name
252		      dotfiles: #t
253		      follow-symlinks: #f)))
254	  (for-each
255	   (lambda (f)
256	     ((cond ((*symbolic-link? (*lstat f 'delete-directory)) delete-file)
257		    ((directory-exists? f) rmdir)
258		    (else delete-file))
259	      f))
260	   files)
261	  (rmdir name))
262	(rmdir name))))
263
264
265;;; File management:
266
267(define (delete-file filename)
268  (##sys#check-string filename 'delete-file)
269  (unless (eq? 0 (##core#inline "C_remove" (##sys#make-c-string filename 'delete-file)))
270    (##sys#signal-hook/errno
271     #:file-error (##sys#update-errno) 'delete-file
272     (##sys#string-append "cannot delete file - " strerror) filename))
273  filename)
274
275(define (delete-file* file)
276  (and (*lstat file 'delete-file*)
277       (delete-file file)))
278
279(define (rename-file oldfile newfile #!optional (clobber #f))
280  (##sys#check-string oldfile 'rename-file)
281  (##sys#check-string newfile 'rename-file)
282  (when (and (not clobber) (file-exists? newfile))
283    (##sys#error 'rename-file "newfile exists but clobber is false" newfile))
284  (unless (eq? 0 (##core#inline
285		  "C_rename"
286		  (##sys#make-c-string oldfile 'rename-file)
287		  (##sys#make-c-string newfile 'rename-file)))
288    (##sys#signal-hook/errno
289     #:file-error (##sys#update-errno) 'rename-file
290     (##sys#string-append "cannot rename file - " strerror) oldfile newfile))
291  newfile)
292
293(define (copy-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
294  (##sys#check-string oldfile 'copy-file)
295  (##sys#check-string newfile 'copy-file)
296  (##sys#check-number blocksize 'copy-file)
297  (unless (and (integer? blocksize) (> blocksize 0))
298    (##sys#error 'copy-file "invalid blocksize - not a positive integer" blocksize))
299  (when (directory-exists? oldfile)
300    (##sys#error 'copy-file "cannot copy directories" oldfile))
301  (when (and (not clobber) (file-exists? newfile))
302    (##sys#error 'copy-file "newfile exists but clobber is false" newfile))
303  (let* ((i (open-input-file oldfile #:binary))
304	 (o (open-output-file newfile #:binary))
305	 (s (##sys#make-bytevector blocksize)))
306    (let loop ((d (read-bytevector! s i))
307	       (l 0))
308      (if (fx= 0 d)
309	  (begin
310	    (close-input-port i)
311	    (close-output-port o)
312	    l)
313	  (begin
314	    (write-bytevector s o 0 d)
315	    (loop (read-bytevector! s i) (fx+ d l)))))))
316
317(define (move-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
318  (##sys#check-string oldfile 'move-file)
319  (##sys#check-string newfile 'move-file)
320  (##sys#check-number blocksize 'move-file)
321  (unless (and (integer? blocksize) (> blocksize 0))
322    (##sys#error 'move-file "invalid blocksize - not a positive integer" blocksize))
323  (when (directory-exists? oldfile)
324    (##sys#error 'move-file "cannot move directories" oldfile))
325  (when (and (not clobber) (file-exists? newfile))
326    (##sys#error 'move-file "newfile exists but clobber is false" newfile))
327  (let* ((i (open-input-file oldfile #:binary))
328	 (o (open-output-file newfile #:binary))
329	 (s (##sys#make-bytevector blocksize)))
330    (let loop ((d (read-bytevector! s i))
331	       (l 0))
332      (if (fx= 0 d)
333	  (begin
334	    (close-input-port i)
335	    (close-output-port o)
336	    (delete-file oldfile)
337	    l)
338	  (begin
339	    (write-bytevector s o 0 d)
340	    (loop (read-bytevector! s i) (fx+ d l)))))))
341
342
343;;; Temporary file creation:
344
345(define create-temporary-file)
346(define create-temporary-directory)
347
348(let ((temp-prefix "temp")
349      (string-append string-append))
350  (define (tempdir)
351    (or (get-environment-variable "TMPDIR")
352        (get-environment-variable "TEMP")
353        (get-environment-variable "TMP")
354        (if ##sys#windows-platform
355            (let ((up (get-environment-variable "USERPROFILE")))
356              (if up
357                  (string-append up "/AppData/Local/Temp")
358                  "."))
359            "/tmp")))
360  (set! create-temporary-file
361    (lambda (#!optional (ext "tmp"))
362      (##sys#check-string ext 'create-temporary-file)
363      (let loop ()
364	(let* ((n (##core#inline "C_random_fixnum" #x10000))
365	       (getpid (foreign-lambda int "C_getpid"))
366	       (pn (make-pathname
367		    (tempdir)
368		    (string-append
369		     temp-prefix
370		     (number->string n 16)
371		     "."
372		     (##sys#number->string (getpid)))
373		    ext)))
374	  (if (file-exists? pn)
375	      (loop)
376	      (call-with-output-file pn (lambda (p) pn)))))))
377  (set! create-temporary-directory
378    (lambda ()
379      (let loop ()
380	(let* ((n (##core#inline "C_random_fixnum" #x10000))
381	       (getpid (foreign-lambda int "C_getpid"))
382	       (pn (make-pathname
383		    (tempdir)
384		    (string-append
385		     temp-prefix
386		     (number->string n 16)
387		     "."
388		     (##sys#number->string (getpid))))))
389	  (if (file-exists? pn)
390	      (loop)
391	      (let ((r (##core#inline "C_mkdir" (##sys#make-c-string pn 'create-temporary-directory))))
392		(if (eq? r 0)
393		    pn
394		    (##sys#signal-hook
395		     #:file-error 'create-temporary-directory
396		     (##sys#string-append "cannot create temporary directory - " strerror)
397		     pn)))))))))
398
399
400;;; Filename globbing:
401
402(define (glob . paths)
403  (let conc-loop ((paths paths))
404    (if (null? paths)
405	'()
406	(let ((path (car paths)))
407	  (let-values (((dir fil ext) (decompose-pathname path)))
408	    (let ((dir* (or dir "."))
409		  (rx   (irregex (glob->sre (make-pathname #f (or fil "*") ext)))))
410	      (let loop ((fns (condition-case (directory dir* #t)
411				((exn i/o file) #f))))
412		(cond ((not (pair? fns)) (conc-loop (cdr paths)))
413		      ((irregex-match rx (car fns)) =>
414		       (lambda (m)
415			 (cons (make-pathname dir (irregex-match-substring m))
416			       (loop (cdr fns)))))
417		      (else (loop (cdr fns)))))))))))
418
419
420;;; Find matching files:
421
422(define (find-files dir #!key (test (lambda _ #t))
423			      (action (lambda (x y) (cons x y)))
424			      (seed '())
425			      (limit #f)
426			      (dotfiles #f)
427			      (follow-symlinks #f))
428  (##sys#check-string dir 'find-files)
429  (let* ((depth 0)
430	 (lproc
431	  (cond ((not limit) (lambda _ #t))
432		((fixnum? limit) (lambda _ (fx< depth limit)))
433		(else limit)))
434	 (pproc
435	  (if (procedure? test)
436	      test
437	      (let ((test (irregex test))) ; force compilation
438		(lambda (x) (irregex-match test x))))))
439    (let loop ((dir dir)
440	       (fs (directory dir dotfiles))
441	       (r seed))
442      (if (null? fs)
443	  r
444	  (let* ((filename (##sys#slot fs 0))
445		 (f (make-pathname dir filename))
446		 (rest (##sys#slot fs 1)))
447	    (cond ((directory-exists? f)
448		   (cond ((member filename '("." "..")) (loop dir rest r))
449			 ((and (*symbolic-link? (*lstat f 'find-files)) (not follow-symlinks))
450			  (loop dir rest (if (pproc f) (action f r) r)))
451			 ((lproc f)
452			  (loop dir
453				rest
454				(fluid-let ((depth (fx+ depth 1)))
455				  (loop f
456					(directory f dotfiles)
457					(if (pproc f) (action f r) r)))))
458			 (else (loop dir rest (if (pproc f) (action f r) r)))))
459		  ((pproc f) (loop dir rest (action f r)))
460		  (else (loop dir rest r))))))))
461
462)