- Fixed errno-error calls to include the syscall's args. This should greatly
improve the quality of the error messages.
- Fixed file-match so that if a filter procedure raises an error condition,
it is caught and treated as a match failure (as if the procedure returned
#f). This means you no longer get blown out of the water by
(file-match "." #f file-directory?)
if the cwd contains a dangling symlink, for example.
- Added set-file-times (utime).
- Caught a bug in an unused arm of the define-errno-syscall macros (rest arg
case).
- Perhaps one or two other minor tweaks.
This commit is contained in:
shivers
parent
241344c36b
commit
3e52c5100b
|
|
@ -32,6 +32,13 @@
|
|||
;;; Return: list of matching file names (strings)
|
||||
;;; The matcher never considers "." or "..".
|
||||
|
||||
;;; Subtle point:
|
||||
;;; If a file-match predicate raises an error condition, it is caught by
|
||||
;;; FILE-MATCH, and the file under consideration is not matched. This
|
||||
;;; means that (file-match "." #f file-directory?) doesn't error out
|
||||
;;; if you happen to run it in a directory containing a dangling symlink
|
||||
;;; when FILE-DIRECTORY? is applied to the bogus symlink.
|
||||
|
||||
(define (file-match root dot-files? . patterns)
|
||||
(let ((patterns (apply append (map split-pat patterns))))
|
||||
(let recur ((root root)
|
||||
|
|
@ -43,11 +50,26 @@
|
|||
(matcher (cond ((string? pattern)
|
||||
(let ((re (make-regexp pattern)))
|
||||
(lambda (f) (regexp-exec re f))))
|
||||
|
||||
;; This arm makes a file-matcher using
|
||||
;; predicate PATTERN. If PATTERN signals
|
||||
;; an error condition while it is being
|
||||
;; run, our matcher catches it and returns
|
||||
;; #f.
|
||||
((procedure? pattern)
|
||||
(lambda (f)
|
||||
(pattern (string-append dir f))))
|
||||
(call-with-current-continuation
|
||||
(lambda (abort)
|
||||
(with-handler (lambda (condition more)
|
||||
(if (error? condition)
|
||||
(abort #f)
|
||||
(more)))
|
||||
(lambda ()
|
||||
(pattern (string-append dir f))))))))
|
||||
|
||||
(else
|
||||
(error "Bad file-match pattern" pattern))))
|
||||
|
||||
(candidates (maybe-directory-files root dot-files?))
|
||||
(winners (filter matcher candidates)))
|
||||
(apply append (map (lambda (fn) (recur (string-append dir fn)
|
||||
|
|
|
|||
|
|
@ -106,7 +106,7 @@
|
|||
(define (get-lock-region fdes lock)
|
||||
(receive (err type whence start len pid)
|
||||
(call-lock-region %get-lock fcntl/get-record-lock fdes lock)
|
||||
(if err (errno-error err get-lock-region)
|
||||
(if err (errno-error err get-lock-region fdes lock)
|
||||
(and (not (= type lock/release))
|
||||
(make-%lock-region (= type lock/write) start len whence pid)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@
|
|||
(define (dbm-open file flags mode)
|
||||
(receive (err dbm) (%dbm-open file flags mode)
|
||||
(if err
|
||||
(errno-error err dbm-open)
|
||||
(errno-error err dbm-open file flags mode)
|
||||
dbm)))
|
||||
|
||||
(define-foreign dbm-close (database_close ((C DBM*) dbm))
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@
|
|||
-1))
|
||||
(policy (if (zero? size) bufpol/none policy))
|
||||
(err (%fdport-set-buffering/errno port policy size)))
|
||||
(if err (errno-error err set-port-buffering))))
|
||||
(if err (errno-error err set-port-buffering port policy size))))
|
||||
|
||||
|
||||
;;; Open & Close
|
||||
|
|
|
|||
|
|
@ -222,7 +222,7 @@
|
|||
(receive (err pid status) (%wait-pid/errno pid flags)
|
||||
(if err
|
||||
(if (= err errno/intr) (lp)
|
||||
(errno-error err %wait-pid))
|
||||
(errno-error err %wait-pid pid flags))
|
||||
(and (not (zero? pid)) status))))) ; pid=0 => none ready.
|
||||
|
||||
|
||||
|
|
@ -231,7 +231,7 @@
|
|||
(receive (err pid status) (%wait-pid/errno -1 flags)
|
||||
(cond (err (cond ((= err errno/child) (values #f #t)) ; No more.
|
||||
((= err errno/intr) (lp))
|
||||
(else (errno-error err %wait-any))))
|
||||
(else (errno-error err %wait-any flags))))
|
||||
((zero? pid) (values #f #f)) ; None ready.
|
||||
(else (values pid status))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -205,6 +205,7 @@
|
|||
set-file-mode
|
||||
set-file-owner
|
||||
set-file-group
|
||||
set-file-times
|
||||
truncate-file
|
||||
|
||||
read-symlink ; Not POSIX.
|
||||
|
|
|
|||
|
|
@ -443,6 +443,30 @@ scheme_value df_rmdir(long nargs, scheme_value *args)
|
|||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_scm_utime(long nargs, scheme_value *args)
|
||||
{
|
||||
extern int scm_utime(const char *, int , int , int , int );
|
||||
scheme_value ret1;
|
||||
int r1;
|
||||
|
||||
cig_check_nargs(5, nargs, "scm_utime");
|
||||
r1 = scm_utime(cig_string_body(args[4]), EXTRACT_FIXNUM(args[3]), EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0]));
|
||||
ret1 = errno_or_false(r1);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_scm_utime_now(long nargs, scheme_value *args)
|
||||
{
|
||||
extern int scm_utime_now(const char *);
|
||||
scheme_value ret1;
|
||||
int r1;
|
||||
|
||||
cig_check_nargs(1, nargs, "scm_utime_now");
|
||||
r1 = scm_utime_now(cig_string_body(args[0]));
|
||||
ret1 = errno_or_false(r1);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_scheme_stat(long nargs, scheme_value *args)
|
||||
{
|
||||
extern int scheme_stat(const char *, scheme_value , int );
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@
|
|||
;;;
|
||||
;;; (define (SYSCALL . ARGS)
|
||||
;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
|
||||
;;; (if err (errno-error err SYSCALL)
|
||||
;;; (if err (errno-error err SYSCALL . ARGS)
|
||||
;;; (values . RET-VALS))))
|
||||
|
||||
(define-syntax define-errno-syscall
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
ret-val ...)
|
||||
(define (syscall arg ...)
|
||||
(receive (err ret-val ...) (syscall/errno arg ...)
|
||||
(if err (errno-error err syscall)
|
||||
(if err (errno-error err syscall arg ...)
|
||||
(values ret-val ...)))))
|
||||
|
||||
;;; This case handles rest args
|
||||
|
|
@ -52,7 +52,7 @@
|
|||
ret-val ...)
|
||||
(define (syscall . args)
|
||||
(receive (err ret-val ...) (apply syscall/errno . args)
|
||||
(if err (errno-error err syscall)
|
||||
(if err (apply errno-error err syscall args)
|
||||
(values ret-val ...)))))))
|
||||
|
||||
;;; DEFINE-SIMPLE-ERRNO-SYSCALL is for the simple case of a system call
|
||||
|
|
@ -63,21 +63,21 @@
|
|||
;;;
|
||||
;;; (define (SYSCALL . ARGS)
|
||||
;;; (cond ((SYSCALL/ERRNO . ARGS) =>
|
||||
;;; (lambda (err) (errno-error err SYSCALL)))))
|
||||
;;; (lambda (err) (errno-error err SYSCALL . ARGS)))))
|
||||
|
||||
(define-syntax define-simple-errno-syscall
|
||||
(syntax-rules ()
|
||||
((define-simple-errno-syscall (syscall arg ...) syscall/errno)
|
||||
(define (syscall arg ...)
|
||||
(cond ((syscall/errno arg ...) =>
|
||||
(lambda (err) (errno-error err syscall))))))
|
||||
(lambda (err) (errno-error err syscall arg ...))))))
|
||||
|
||||
|
||||
;; This case handles rest args
|
||||
((define-simple-errno-syscall (syscall . args) syscall/errno)
|
||||
(define (syscall . args)
|
||||
(cond ((apply syscall/errno . args) =>
|
||||
(lambda (err) (errno-error err syscall))))))))
|
||||
;; This case handles a single rest arg.
|
||||
((define-simple-errno-syscall (syscall . rest) syscall/errno)
|
||||
(define (syscall . rest)
|
||||
(cond ((apply syscall/errno rest) =>
|
||||
(lambda (err) (apply errno-error err syscall rest))))))))
|
||||
|
||||
|
||||
;;; Process
|
||||
|
|
@ -90,7 +90,7 @@
|
|||
integer)
|
||||
|
||||
(define (%%exec prog argv env)
|
||||
(errno-error (%%exec/errno prog argv env) %exec)) ; cute.
|
||||
(errno-error (%%exec/errno prog argv env) %exec prog argv env)) ; cute.
|
||||
|
||||
(define (%exec prog arg-list env)
|
||||
(let ((argv (mapv! stringify (list->vector arg-list)))
|
||||
|
|
@ -342,7 +342,8 @@
|
|||
(let ((mode (optional-arg maybe-mode #o777))
|
||||
(fname (ensure-file-name-is-nondirectory path)))
|
||||
(cond ((create-directory/errno fname mode) =>
|
||||
(lambda (err) (if err (errno-error err create-directory)))))))
|
||||
(lambda (err)
|
||||
(if err (errno-error err create-directory path mode)))))))
|
||||
|
||||
|
||||
(define-foreign read-symlink/errno (scm_readlink (string path))
|
||||
|
|
@ -368,6 +369,31 @@
|
|||
(define-simple-errno-syscall (delete-directory path) delete-directory/errno)
|
||||
|
||||
|
||||
(define-foreign %utime/errno (scm_utime (string path)
|
||||
(integer ac_hi) (integer ac_lo)
|
||||
(integer m_hi) (integer m_lo))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-foreign %utime-now/errno (scm_utime_now (string path))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
|
||||
;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time])
|
||||
|
||||
(define (set-file-times/errno path . maybe-times)
|
||||
(if (pair? maybe-times)
|
||||
(let ((access-time (car maybe-times))
|
||||
(mod-time (if (pair? (cddr maybe-times))
|
||||
(error "Too many arguments to set-file-times/errno"
|
||||
(cons path maybe-times))
|
||||
(cadr maybe-times))))
|
||||
(%utime/errno path (hi8 access-time) (lo24 access-time)
|
||||
(hi8 mod-time) (lo24 mod-time)))
|
||||
(%utime-now/errno path)))
|
||||
|
||||
(define-simple-errno-syscall (set-file-times . args) set-file-times/errno)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; STAT
|
||||
|
||||
|
|
@ -436,10 +462,10 @@
|
|||
(vector-ref ans-vec 13))))))))
|
||||
|
||||
(define (file-info fd/port/fname . maybe-chase?)
|
||||
(receive (err info) (file-info/errno fd/port/fname
|
||||
(optional-arg maybe-chase? #t))
|
||||
(if err (errno-error err file-info)
|
||||
info)))
|
||||
(let ((chase? (optional-arg maybe-chase? #t)))
|
||||
(receive (err info) (file-info/errno fd/port/fname chase?)
|
||||
(if err (errno-error err file-info fd/port/fname chase?)
|
||||
info))))
|
||||
|
||||
|
||||
(define file-attributes
|
||||
|
|
@ -540,18 +566,19 @@
|
|||
(define seek/end 2)
|
||||
|
||||
(define (seek fd/port offset . maybe-whence)
|
||||
(receive (err offset)
|
||||
((if (integer? fd/port) %fd-seek/errno %fdport-seek/errno)
|
||||
fd/port
|
||||
offset
|
||||
(optional-arg maybe-whence seek/set))
|
||||
(if err (errno-error err seek) offset)))
|
||||
(let ((whence (optional-arg maybe-whence seek/set)))
|
||||
(receive (err cursor)
|
||||
((if (integer? fd/port) %fd-seek/errno %fdport-seek/errno)
|
||||
fd/port
|
||||
offset
|
||||
whence)
|
||||
(if err (errno-error err seek fd/port offset whence) cursor))))
|
||||
|
||||
(define (tell fd/port)
|
||||
(receive (err offset) (if (integer? fd/port)
|
||||
(%fd-seek/errno fd/port 0 seek/delta) ; seek(fd)
|
||||
(%fdport-tell/errno fd/port)) ; ftell(f)
|
||||
(if err (errno-error err tell) offset)))
|
||||
(if err (errno-error err tell fd/port) offset)))
|
||||
|
||||
|
||||
(define-foreign %char-ready-fdes?/errno
|
||||
|
|
@ -601,7 +628,7 @@
|
|||
|
||||
(define (read-fdes-char fd)
|
||||
(let ((c (%read-fdes-char fd)))
|
||||
(if (integer? c) (errno-error c read-fdes-char) c)))
|
||||
(if (integer? c) (errno-error c read-fdes-char fd) c)))
|
||||
|
||||
|
||||
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (integer fd))
|
||||
|
|
@ -797,7 +824,7 @@
|
|||
(check-arg string? dir directory-files)
|
||||
(receive (err cvec numfiles)
|
||||
(%open-dir (ensure-file-name-is-nondirectory dir))
|
||||
(if err (errno-error err directory-files))
|
||||
(if err (errno-error err directory-files dir dotfiles?))
|
||||
(%sort-file-vector cvec numfiles)
|
||||
(let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
|
||||
(if dotfiles? files
|
||||
|
|
@ -816,7 +843,7 @@
|
|||
(check-arg string? dir match-files)
|
||||
(receive (err cvec numfiles)
|
||||
(%open-dir (ensure-file-name-is-nondirectory dir))
|
||||
(if err (errno-error err match-files))
|
||||
(if err (errno-error err match-files regexp dir))
|
||||
(receive (err numfiles) (%filter-C-strings! regexp cvec)
|
||||
(if (not (equal? err "")) (error err match-files))
|
||||
(%sort-file-vector cvec numfiles)
|
||||
|
|
@ -922,7 +949,7 @@
|
|||
|
||||
(define (%fdport*-read-char data)
|
||||
(let ((c (%fdport*-read-char/errno data)))
|
||||
(if (integer? c) (errno-error c %fdport*-read-char)
|
||||
(if (integer? c) (errno-error c %fdport*-read-char data)
|
||||
(or c eof-object))))
|
||||
|
||||
|
||||
|
|
@ -932,7 +959,7 @@
|
|||
|
||||
(define (%fdport*-char-ready? data)
|
||||
(let ((val (%fdport*-char-ready?/errno data)))
|
||||
(if (integer? val) (errno-error val %fdport*-char-ready?)
|
||||
(if (integer? val) (errno-error val %fdport*-char-ready? data)
|
||||
val)))
|
||||
|
||||
(define-foreign %fdport*-write-char/errno
|
||||
|
|
|
|||
|
|
@ -19,12 +19,19 @@
|
|||
#include <sys/wait.h>
|
||||
#include <unistd.h>
|
||||
#include <string.h>
|
||||
#include <utime.h>
|
||||
|
||||
#include "cstuff.h"
|
||||
|
||||
extern int errno;
|
||||
extern char **environ;
|
||||
|
||||
/* Sux because it's dependent on 32-bitness. */
|
||||
#define hi8(i) (((i)>>24) & 0xff)
|
||||
#define lo24(i) ((i) & 0xffffff)
|
||||
#define comp8_24(hi, lo) (((hi)<<24) + (lo))
|
||||
|
||||
|
||||
/* Process stuff
|
||||
*******************************************************************************
|
||||
** wait, exec
|
||||
|
|
@ -121,6 +128,22 @@ char *scm_readlink(char *path)
|
|||
}
|
||||
|
||||
|
||||
|
||||
/* Scheme interfaces to utime().
|
||||
** Complicated by need to pass real 32-bit quantities.
|
||||
*/
|
||||
|
||||
int scm_utime(char const *path, int ac_hi, int ac_lo, int mod_hi, int mod_lo)
|
||||
{
|
||||
struct utimbuf t;
|
||||
t.actime = comp8_24(ac_hi, ac_lo);
|
||||
t.modtime = comp8_24(mod_hi, mod_lo);
|
||||
return utime(path, &t);
|
||||
}
|
||||
|
||||
int scm_utime_now(char const *path) {return utime(path, 0);}
|
||||
|
||||
|
||||
/* Two versions of CWD
|
||||
*******************************************************************************
|
||||
*/
|
||||
|
|
|
|||
Loading…
Reference in New Issue