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