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