1017 lines
29 KiB
Scheme
1017 lines
29 KiB
Scheme
|
|
;;; POSIX system-call Scheme binding.
|
|
;;; Copyright (c) 1993 by Olin Shivers.
|
|
|
|
;;; Scheme48 implementation.
|
|
|
|
;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme?
|
|
|
|
(foreign-init-name "syscalls")
|
|
|
|
(foreign-source
|
|
"#include <sys/signal.h>"
|
|
"#include <sys/types.h>"
|
|
"#include <sys/times.h>"
|
|
"#include <sys/time.h>"
|
|
"#include <fcntl.h> /* for O_RDWR */" ; ???
|
|
"#include <sys/stat.h>"
|
|
"#include <netdb.h>"
|
|
"#include <pwd.h>"
|
|
"#include <unistd.h>"
|
|
""
|
|
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
|
"#include \"dirstuff1.h\""
|
|
; "#include \"fdports1.h\"" JMG
|
|
"#include \"select1.h\""
|
|
"#include \"syscalls1.h\""
|
|
"#include \"userinfo1.h\""
|
|
""
|
|
"extern int errno;"
|
|
""
|
|
"#define errno_on_zero_or_false(x) ((x) ? S48_FALSE : s48_enter_fixnum(errno))"
|
|
"#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)" ; Not a function.
|
|
"" "")
|
|
|
|
;;; Macro for converting syscalls that return error codes to ones that
|
|
;;; raise exceptions on errors.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from
|
|
;;; one that returns an error code as its first return value -- #f for win,
|
|
;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall),
|
|
;;; we try again.
|
|
;;;
|
|
;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
|
|
;;;
|
|
;;; (define (SYSCALL . ARGS)
|
|
;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
|
|
;;; (cond ((not err) (values . RET-VALS)) ; Win
|
|
;;; ((= err errno/intr) (SYSCALL . ARGS)) ; Retry
|
|
;;; (else (errno-error err SYSCALL . ARGS))))); Lose
|
|
|
|
(define-syntax define-errno-syscall
|
|
(syntax-rules ()
|
|
((define-errno-syscall (syscall arg ...) syscall/errno
|
|
ret-val ...)
|
|
(define (syscall arg ...)
|
|
(receive (err ret-val ...) (syscall/errno arg ...)
|
|
(cond ((not err) (values ret-val ...)) ; Win
|
|
((= err errno/intr)
|
|
(syscall arg ...)) ; Retry
|
|
(else (errno-error err syscall arg ...)))))) ; Lose
|
|
|
|
;;; This case handles rest args
|
|
((define-errno-syscall (syscall . args) syscall/errno
|
|
ret-val ...)
|
|
(define (syscall . args)
|
|
(receive (err ret-val ...) (apply syscall/errno args)
|
|
(cond ((not err) (values ret-val ...)) ; Win
|
|
((= err errno/intr)
|
|
(apply syscall args)) ; Retry
|
|
(else (apply errno-error err syscall args)))))))); Lose
|
|
|
|
;;; By the way, it would be better to insert a (LET LP () ...) for the
|
|
;;; the errno/intr retries, instead of calling the top-level definition
|
|
;;; (because in Scheme you have to allow for the fact that top-level
|
|
;;; defns can be re-defined, so the compiler can't just turn it into a
|
|
;;; jump), but the brain-dead S48 byte-compiler will cons a closure for
|
|
;;; the LP loop, which means that little syscalls like read-char can cons
|
|
;;; like crazy. So I'm doing it this way. Ech.
|
|
|
|
|
|
;;; Process
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; we can't algin env here, because exec-path/env calls
|
|
;; %%exec/errno directly F*&% *P
|
|
(define-stubless-foreign %%exec/errno (prog argv env) "scheme_exec")
|
|
|
|
(define (%%exec prog argv env)
|
|
(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)))
|
|
(prog (stringify prog))
|
|
(env (if (eq? env #t) #t (alist->env-vec env))))
|
|
(%%exec prog argv env)))
|
|
|
|
|
|
(define-stubless-foreign exit/errno ; errno -- misnomer.
|
|
(status) "scsh_exit")
|
|
|
|
(define-stubless-foreign %exit/errno ; errno -- misnomer
|
|
(status) "scsh__exit")
|
|
|
|
(define (%exit . maybe-status)
|
|
(%exit/errno (:optional maybe-status 0))
|
|
(error "Yikes! %exit returned."))
|
|
|
|
|
|
(define-stubless-foreign %%fork () "scsh_fork")
|
|
|
|
;;; Posix waitpid(2) call.
|
|
(define-stubless-foreign %wait-pid/errno-list (pid options)
|
|
"wait_pid")
|
|
|
|
(define (%wait-pid/errno pid options)
|
|
(apply values (%wait-pid/errno-list pid options)))
|
|
|
|
;;; Miscellaneous process state
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Working directory
|
|
|
|
(define-stubless-foreign %chdir (directory) "scsh_chdir")
|
|
|
|
;;; These calls change/reveal the process working directory
|
|
;;;
|
|
|
|
(define (process-chdir . maybe-dir)
|
|
(let ((dir (:optional maybe-dir (home-dir))))
|
|
(%chdir (ensure-file-name-is-nondirectory dir))))
|
|
|
|
;; TODO: we get an error if cwd does not exist on startup
|
|
(define-stubless-foreign process-cwd () "scheme_cwd")
|
|
|
|
;;; GID
|
|
|
|
(define-stubless-foreign user-gid () "scsh_getgid")
|
|
|
|
(define-stubless-foreign user-effective-gid () "scsh_getegid")
|
|
|
|
(define-stubless-foreign set-gid (gid) "scsh_setgid")
|
|
|
|
(define-stubless-foreign set-effective-gid (gid) "scsh_setegid")
|
|
|
|
(define-stubless-foreign user-supplementary-gids () "get_groups")
|
|
|
|
;;; UID
|
|
(define-stubless-foreign user-uid () "scsh_getuid")
|
|
|
|
(define-stubless-foreign user-effective-uid () "scsh_geteuid")
|
|
|
|
(define-stubless-foreign set-uid (uid) "scsh_setuid")
|
|
|
|
(define-stubless-foreign set-effective-uid (uid) "scsh_seteuid")
|
|
|
|
(import-lambda-definition %user-login-name () "my_username")
|
|
|
|
(define (user-login-name)
|
|
(or (%user-login-name)
|
|
(error "Cannot get your name")))
|
|
|
|
;;; PID
|
|
|
|
(define-foreign pid (getpid) pid_t)
|
|
(define-foreign parent-pid (getppid) pid_t)
|
|
|
|
|
|
;;; Process groups and session ids
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-foreign process-group (getpgrp) pid_t)
|
|
(define-foreign %set-process-group/errno
|
|
(setpgid (pid_t pid) (pid_t groupid))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (%set-process-group pid pgrp)
|
|
%set-process-group/errno)
|
|
|
|
|
|
(define (set-process-group arg1 . maybe-arg2)
|
|
(receive (pid pgrp) (if (null? maybe-arg2)
|
|
(values (pid) arg1)
|
|
(values arg1 (car maybe-arg2)))
|
|
(%set-process-group pid pgrp)))
|
|
|
|
|
|
(define-foreign become-session-leader/errno (setsid)
|
|
(multi-rep (to-scheme pid_t errno_or_false)
|
|
pid_t))
|
|
|
|
(define-errno-syscall (become-session-leader) become-session-leader/errno
|
|
sid)
|
|
|
|
|
|
;;; UMASK
|
|
|
|
(define-foreign set-umask (umask (mode_t mask)) no-declare ; integer on SunOS
|
|
mode_t)
|
|
|
|
(define (umask)
|
|
(let ((m (set-umask 0)))
|
|
(set-umask m)
|
|
m))
|
|
|
|
|
|
;;; PROCESS TIMES
|
|
|
|
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
|
|
|
|
|
(define-foreign process-times/errno (process_times)
|
|
(to-scheme integer errno_or_false)
|
|
clock_t ; user cpu time
|
|
clock_t ; system cpu time
|
|
clock_t ; user cpu time for me and all my descendants.
|
|
clock_t) ; system cpu time for me and all my descendants.
|
|
|
|
(define-errno-syscall (process-times) process-times/errno
|
|
utime stime cutime cstime)
|
|
|
|
(define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer)
|
|
|
|
;;; File system
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Useful little utility for generic ops that work on filenames, fd's or
|
|
;;; ports.
|
|
|
|
(define (generic-file-op thing fd-op fname-op)
|
|
(if (string? thing) (fname-op thing)
|
|
(call/fdes thing fd-op)))
|
|
|
|
|
|
(define-foreign set-file-mode/errno
|
|
(chmod (string path) (mode_t mode)) no-declare ; integer on SunOS
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
; IBM's AIX include files declare fchmod(char*, mode_t).
|
|
; Amazing, but true. So we must prevent this def-foreign from issuing
|
|
; the conflicting, correct declaration. Hence the NO-DECLARE.
|
|
|
|
(define-foreign set-fdes-mode/errno
|
|
(fchmod (fixnum fd) (mode_t mode)) ; integer on SunOS
|
|
no-declare ; Workaround for AIX bug.
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (set-file-mode thing mode)
|
|
(lambda (thing mode)
|
|
(generic-file-op thing
|
|
(lambda (fd) (set-fdes-mode/errno fd mode))
|
|
(lambda (fname) (set-file-mode/errno fname mode)))))
|
|
|
|
|
|
;;; NO-DECLARE: gcc unistd.h bogusness.
|
|
(define-foreign set-file-uid&gid/errno
|
|
(chown (string path) (uid_t uid) (gid_t gid)) no-declare
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-foreign set-fdes-uid&gid/errno
|
|
(fchown (fixnum fd) (uid_t uid) (gid_t gid))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (set-file-owner thing uid)
|
|
(lambda (thing uid)
|
|
(generic-file-op thing
|
|
(lambda (fd) (set-fdes-uid&gid/errno fd uid -1))
|
|
(lambda (fname) (set-file-uid&gid/errno fname uid -1)))))
|
|
|
|
(define-errno-syscall (set-file-group thing gid)
|
|
(lambda (thing gid)
|
|
(generic-file-op thing
|
|
(lambda (fd) (set-fdes-uid&gid/errno fd -1 gid))
|
|
(lambda (fname) (set-file-uid&gid/errno fname -1 gid)))))
|
|
|
|
|
|
;;; Uses real uid and gid, not effective. I don't use this anywhere.
|
|
|
|
(define-foreign %file-ruid-access-not?
|
|
(access (string path)
|
|
(integer perms))
|
|
bool)
|
|
|
|
;(define (file-access? path perms)
|
|
; (not (%file-access-not? path perms)))
|
|
;
|
|
;(define (file-executable? fname)
|
|
; (file-access? fname 1))
|
|
;
|
|
;(define (file-writable? fname)
|
|
; (file-access? fname 2))
|
|
;
|
|
;(define (file-readable? fname)
|
|
; (file-access? fname 4))
|
|
|
|
|
|
(define-foreign create-hard-link/errno
|
|
(link (string original-name) (string new-name))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (create-hard-link original-name new-name)
|
|
create-hard-link/errno)
|
|
|
|
|
|
(define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode))
|
|
no-declare ; integer on SunOS
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (create-fifo path mode) create-fifo/errno)
|
|
|
|
|
|
(define-foreign create-directory/errno
|
|
(mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS.
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define (create-directory path . maybe-mode)
|
|
(let ((mode (:optional 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 path mode)))))))
|
|
|
|
(define-stubless-foreign read-symlink (path) "scm_readlink")
|
|
|
|
(define-foreign %rename-file/errno
|
|
(rename (string old-name) (string new-name))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (%rename-file old-name new-name)
|
|
%rename-file/errno)
|
|
|
|
|
|
(define-foreign delete-directory/errno
|
|
(rmdir (string path))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (delete-directory path) delete-directory/errno)
|
|
|
|
|
|
(define-foreign %utime/errno (scm_utime (string path)
|
|
(time_t ac)
|
|
(time_t m))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-foreign %utime-now/errno (scm_utime_now (string path))
|
|
(to-scheme fixnum 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 (real->exact-integer (car maybe-times)))
|
|
(mod-time (if (pair? (cddr maybe-times))
|
|
(error "Too many arguments to set-file-times/errno"
|
|
(cons path maybe-times))
|
|
(real->exact-integer (cadr maybe-times)))))
|
|
(%utime/errno path access-time
|
|
mod-time ))
|
|
(%utime-now/errno path)))
|
|
|
|
(define-errno-syscall (set-file-times . args) set-file-times/errno)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; STAT
|
|
|
|
(define-stubless-foreign stat-file (path data chase?) "scheme_stat")
|
|
|
|
(define-stubless-foreign stat-fdes (fd data) "scheme_fstat")
|
|
|
|
(define-record file-info
|
|
type
|
|
device
|
|
inode
|
|
mode
|
|
nlinks
|
|
uid
|
|
gid
|
|
size
|
|
atime
|
|
mtime
|
|
ctime
|
|
)
|
|
|
|
|
|
;;; Should be redone to return multiple-values.
|
|
(define (%file-info fd/port/fname chase?)
|
|
(let ((ans-vec (make-vector 11))
|
|
(file-type (lambda (type-code)
|
|
(vector-ref '#(block-special char-special directory fifo
|
|
regular socket symlink)
|
|
type-code))))
|
|
(generic-file-op fd/port/fname
|
|
(lambda (fd)
|
|
(stat-fdes fd ans-vec))
|
|
(lambda (fname)
|
|
(stat-file fname ans-vec chase?)))
|
|
(make-file-info (file-type (vector-ref ans-vec 0))
|
|
(vector-ref ans-vec 1)
|
|
(vector-ref ans-vec 2)
|
|
(vector-ref ans-vec 3)
|
|
(vector-ref ans-vec 4)
|
|
(vector-ref ans-vec 5)
|
|
(vector-ref ans-vec 6)
|
|
(vector-ref ans-vec 7)
|
|
(vector-ref ans-vec 8)
|
|
(vector-ref ans-vec 9)
|
|
(vector-ref ans-vec 10))))
|
|
|
|
|
|
(define (file-info fd/port/fname . maybe-chase?)
|
|
(with-cwd-aligned
|
|
(let ((chase? (:optional maybe-chase? #t)))
|
|
(%file-info fd/port/fname chase?))))
|
|
|
|
|
|
(define file-attributes
|
|
(deprecated-proc file-info "file-attributes" "Use file-info instead."))
|
|
|
|
|
|
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
|
;;; the OLD-NAME arg is "const". It *should* be const.
|
|
|
|
(define-foreign create-symlink/errno
|
|
(symlink (string old-name) (string new-name)) no-declare
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
;(define-errno-syscall (create-symlink old-name new-name)
|
|
; create-symlink/errno)
|
|
|
|
|
|
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
|
;;; the PATH arg is "const". It *should* be const.
|
|
|
|
(define-foreign truncate-file/errno
|
|
(truncate (string path) (off_t length)) no-declare
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-foreign truncate-fdes/errno
|
|
(ftruncate (fixnum fd) (off_t length)) no-declare ; Indigo bogosity.
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (truncate-file path length)
|
|
(lambda (thing length)
|
|
(generic-file-op thing
|
|
(lambda (fd) (truncate-fdes/errno fd length))
|
|
(lambda (fname) (truncate-file/errno fname length)))))
|
|
|
|
|
|
(define-foreign delete-file/errno
|
|
(unlink (string path))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (delete-file path) delete-file/errno)
|
|
|
|
|
|
(define-foreign sync-file/errno (fsync (fixnum fd))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (sync-file fd/port)
|
|
(lambda (fd/port)
|
|
(if (output-port? fd/port) (force-output fd/port))
|
|
(sleazy-call/fdes fd/port sync-file/errno)))
|
|
|
|
|
|
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
|
|
(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int
|
|
ignore)
|
|
|
|
|
|
;;; I/O
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-foreign %close-fdes/errno (close (fixnum fd))
|
|
(to-scheme fixnum "errno_or_false"))
|
|
|
|
(define (%close-fdes fd)
|
|
(let lp ()
|
|
(let ((errno (%close-fdes/errno fd)))
|
|
(cond ((not errno) #t) ; Successful close.
|
|
((= errno errno/badf) #f) ; File descriptor already closed.
|
|
((= errno errno/intr) (lp)) ; Retry.
|
|
(else
|
|
(errno-error errno %close-fdes fd)))))) ; You lose.
|
|
|
|
(define-foreign %dup/errno
|
|
(dup (fixnum fd))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum))
|
|
|
|
(define-errno-syscall (%dup fd) %dup/errno
|
|
new-fd)
|
|
|
|
(define-foreign %dup2/errno
|
|
(dup2 (fixnum fd-from) (fixnum fd-to))
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum))
|
|
|
|
(define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno
|
|
new-fd)
|
|
|
|
|
|
(define-foreign %fd-seek/errno
|
|
(lseek (fixnum fd) (off_t offset) (fixnum whence))
|
|
(multi-rep (to-scheme off_t errno_or_false)
|
|
off_t))
|
|
|
|
|
|
|
|
(define seek/set 0) ;Unix codes for "whence"
|
|
(define seek/delta 1)
|
|
(define seek/end 2)
|
|
|
|
(define (seek fd/port offset . maybe-whence)
|
|
(let ((whence (:optional maybe-whence seek/set))
|
|
(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
|
(receive (err cursor) (%fd-seek/errno fd offset whence)
|
|
(if err (errno-error err seek fd offset whence) cursor))))
|
|
|
|
(define (tell fd/port)
|
|
(let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
|
(receive (err offset) (%fd-seek/errno fd 0 seek/delta)
|
|
(if err (errno-error err tell fd/port) offset))))
|
|
|
|
(define-foreign %char-ready-fdes?/errno
|
|
(char_ready_fdes (fixnum fd))
|
|
desc) ; errno, #t, or #f
|
|
|
|
(define (%char-ready-fdes? fd)
|
|
(let ((retval (%char-ready-fdes?/errno fd)))
|
|
(if (integer? retval) (errno-error retval %char-ready-fdes? fd)
|
|
retval)))
|
|
|
|
|
|
(define-foreign %open/errno
|
|
(open (string path)
|
|
(fixnum flags)
|
|
(mode_t mode)) ; integer on SunOS
|
|
no-declare ; NOTE
|
|
(multi-rep (to-scheme fixnum errno_or_false)
|
|
fixnum))
|
|
|
|
(define-errno-syscall (%open path flags mode) %open/errno
|
|
fd)
|
|
|
|
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
|
(with-cwd-aligned
|
|
(%open path flags (:optional maybe-mode #o666))))
|
|
|
|
|
|
(define-stubless-foreign pipe-fdes () "scheme_pipe")
|
|
|
|
(define (pipe)
|
|
(apply (lambda (r-fd w-fd)
|
|
(let ((r (fdes->inport r-fd))
|
|
(w (fdes->outport w-fd)))
|
|
(release-port-handle r)
|
|
(release-port-handle w)
|
|
(values r w)))
|
|
(pipe-fdes)))
|
|
|
|
(define-foreign %read-fdes-char
|
|
(read_fdes_char (fixnum fd))
|
|
desc) ; Char or errno or #f (eof).
|
|
|
|
(define (read-fdes-char fd)
|
|
(let ((c (%read-fdes-char fd)))
|
|
(if (integer? c) (errno-error c read-fdes-char fd) c)))
|
|
|
|
|
|
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (fixnum fd))
|
|
(to-scheme fixnum errno_or_false))
|
|
|
|
(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Read and write
|
|
|
|
(define-foreign read-fdes-substring!/errno
|
|
(read_fdes_substring (string-desc buf)
|
|
(size_t start)
|
|
(size_t end)
|
|
(fixnum fd))
|
|
(multi-rep (to-scheme ssize_t errno_or_false)
|
|
ssize_t))
|
|
|
|
(define-foreign write-fdes-substring/errno
|
|
(write_fdes_substring (string-desc buf)
|
|
(size_t start)
|
|
(size_t end)
|
|
(fixnum fd))
|
|
(multi-rep (to-scheme ssize_t errno_or_false)
|
|
ssize_t))
|
|
|
|
|
|
;;; Signals (rather incomplete)
|
|
;;; ---------------------------
|
|
|
|
(define-stubless-foreign signal-pid (pid signal) "scsh_kill")
|
|
|
|
(define (signal-process proc signal)
|
|
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
|
((integer? proc) proc)
|
|
(else (error "Illegal proc passed to signal-process" proc)))
|
|
signal))
|
|
|
|
(define (signal-process-group proc-group signal)
|
|
(signal-pid (- (cond ((proc? proc-group) (proc:pid proc-group))
|
|
((integer? proc-group) proc-group)
|
|
(else (error "Illegal proc passed to signal-process-group"
|
|
proc-group))))
|
|
signal))
|
|
(define (itimer sec)
|
|
((structure-ref events schedule-timer-interrupt!) (* sec 1000)))
|
|
;;; SunOS, not POSIX:
|
|
;;; (define-foreign signal-process-group/errno
|
|
;;; (killpg (integer proc-group) (integer signal))
|
|
;;; (to-scheme integer errno_or_false))
|
|
;;;
|
|
;;; (define-errno-syscall (signal-process-group proc-group signal)
|
|
;;; signal-process-group/errno)
|
|
|
|
(define-foreign pause-until-interrupt (pause) no-declare ignore)
|
|
|
|
;;; now in low-interrupt: (define-foreign itimer (alarm (uint_t secs)) uint_t)
|
|
|
|
;;; User info
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record user-info
|
|
name uid gid home-dir shell
|
|
|
|
;; Make user-info records print like #{user-info shivers}.
|
|
((disclose ui)
|
|
(list "user-info" (user-info:name ui))))
|
|
|
|
|
|
(import-lambda-definition
|
|
%uid->user-info
|
|
(uid user-info-record)
|
|
"user_info_uid")
|
|
|
|
(import-lambda-definition
|
|
%name->user-info
|
|
(name user-info-record)
|
|
"user_info_name")
|
|
|
|
(define (uid->user-info uid)
|
|
(let ((empty-user-info (make-user-info #f uid #f #f #f)))
|
|
(if (%uid->user-info uid empty-user-info)
|
|
empty-user-info
|
|
(error "Cannot get user's information" uid->user-info uid))))
|
|
|
|
|
|
(define (name->user-info name)
|
|
(let ((empty-user-info (make-user-info name #f #f #f #f)))
|
|
(if (%name->user-info name empty-user-info)
|
|
empty-user-info
|
|
(error "Cannot get user's information" name->user-info name))))
|
|
|
|
(define (user-info uid/name)
|
|
((cond ((string? uid/name) name->user-info)
|
|
((integer? uid/name) uid->user-info)
|
|
(else (error "user-info arg must be string or integer" uid/name)))
|
|
uid/name))
|
|
|
|
;;; Derived functions
|
|
|
|
(define (->uid uid/name)
|
|
(user-info:uid (user-info uid/name)))
|
|
|
|
(define (->username uid/name)
|
|
(user-info:name (user-info uid/name)))
|
|
|
|
(define (%homedir uid/name)
|
|
(user-info:home-dir (user-info uid/name)))
|
|
|
|
|
|
;;; Group info
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-record group-info
|
|
name gid members
|
|
|
|
;; Make group-info records print like #{group-info wheel}.
|
|
((disclose gi) (list "group-info" (group-info:name gi))))
|
|
|
|
(import-lambda-definition
|
|
%gid->group-info
|
|
(gid group-info-record)
|
|
"group_info_gid")
|
|
|
|
(import-lambda-definition
|
|
%name->group-info
|
|
(name group-info-record)
|
|
"group_info_name")
|
|
|
|
(define (gid->group-info gid)
|
|
(let ((empty-group-info (make-group-info #f gid #f)))
|
|
(if (%gid->group-info gid empty-group-info)
|
|
empty-group-info
|
|
(error "Cannot get group's information for gid" gid))))
|
|
|
|
(define (name->group-info name)
|
|
(let ((empty-group-info (make-group-info name #f #f)))
|
|
(if (%name->group-info name empty-group-info)
|
|
empty-group-info
|
|
(error "Cannot get group's information for name" name))))
|
|
|
|
(define (group-info gid/name)
|
|
((cond ((string? gid/name) name->group-info)
|
|
((integer? gid/name) gid->group-info)
|
|
(else (error "group-info arg must be string or integer" gid/name)))
|
|
gid/name))
|
|
|
|
;;; Derived functions
|
|
|
|
(define (->gid name)
|
|
(group-info:gid (group-info name)))
|
|
|
|
(define (->groupname gid)
|
|
(group-info:name (group-info gid)))
|
|
|
|
;;; Directory stuff
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-foreign %open-dir (open_dir (string dir-name))
|
|
(to-scheme integer "False_on_zero") ; Win: #f, lose: errno
|
|
(C char**) ; Vector of strings
|
|
fixnum) ; Length of strings
|
|
|
|
;;; Takes a null-terminated C vector of strings -- filenames.
|
|
;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others.
|
|
|
|
(define-foreign %sort-file-vector
|
|
(scm_sort_filevec ((C "const char** ~a") cvec)
|
|
(fixnum veclen))
|
|
ignore)
|
|
|
|
(define (directory-files . args)
|
|
(with-cwd-aligned
|
|
(let-optionals args ((dir ".")
|
|
(dotfiles? #f))
|
|
(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 dir dotfiles?))
|
|
(%sort-file-vector cvec numfiles)
|
|
(let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
|
|
(if dotfiles? files
|
|
(filter (lambda (f) (not (char=? (string-ref f 0) #\.)))
|
|
files)))))))
|
|
|
|
;;; I do this one in C, I'm not sure why:
|
|
;;; It is used by MATCH-FILES.
|
|
;;; 99/7: No one is using this function, so I'm commenting it out.
|
|
;;; Later, we could tune up the globber or regexp file-matcher to use
|
|
;;; it (but should shift it into the rx directory). But I should also go
|
|
;;; to a file-at-a-time cursor model for directory fetching. -Olin
|
|
|
|
;(define-foreign %filter-C-strings!
|
|
; (filter_stringvec (string pattern) ((C "char const ** ~a") cvec))
|
|
; static-string ; error message -- #f if no error.
|
|
; integer) ; number of files that pass the filter.
|
|
|
|
|
|
;(define (match-files regexp . maybe-dir)
|
|
; (let ((dir (:optional maybe-dir ".")))
|
|
; (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 regexp dir))
|
|
; (receive (err numfiles) (%filter-C-strings! regexp cvec)
|
|
; (if err (error err match-files))
|
|
; (%sort-file-vector cvec numfiles)
|
|
; (let ((files (C-string-vec->Scheme&free cvec numfiles)))
|
|
; (vector->list files))))))
|
|
|
|
|
|
;;; Environment manipulation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; (var . val) / "var=val" rep conversion:
|
|
|
|
|
|
|
|
(define (split-env-string var=val)
|
|
(let ((i (string-index var=val #\=)))
|
|
(if i (values (substring var=val 0 i)
|
|
(substring var=val (+ i 1) (string-length var=val)))
|
|
(error "No \"=\" in environment string" var=val))))
|
|
|
|
(define (env-list->alist env-list)
|
|
(map (lambda (var=val)
|
|
(call-with-values (lambda () (split-env-string var=val))
|
|
cons))
|
|
env-list))
|
|
|
|
(define (alist->env-vec alist)
|
|
(list->vector (map (lambda (var.val)
|
|
(string-append (car var.val) "=" (cdr var.val)))
|
|
alist)))
|
|
|
|
;;; ENV->ALIST
|
|
|
|
(define-foreign %load-env (scm_envvec)
|
|
desc)
|
|
|
|
(define (env->list)
|
|
(%load-env))
|
|
|
|
(define (environ-env->alist)
|
|
(env-list->alist (env->list)))
|
|
|
|
|
|
|
|
;;; ALIST->ENV
|
|
|
|
(define-foreign %install-env/errno
|
|
(install_env (vector-desc env-vec))
|
|
(to-scheme integer errno_or_false))
|
|
|
|
(define-errno-syscall (%install-env env-vec) %install-env/errno)
|
|
|
|
;;; assumes aligned env
|
|
(define (envvec-alist->env alist)
|
|
(%install-env (alist->env-vec alist)))
|
|
|
|
;;; create new env for thread
|
|
(define-foreign %create-env/errno
|
|
(create_env (vector-desc env-vec))
|
|
(to-scheme integer errno_or_false)
|
|
desc)
|
|
|
|
(define-errno-syscall (%create-env env-vec)
|
|
%create-env/errno
|
|
bvec)
|
|
|
|
(define (alist->envvec alist)
|
|
(%create-env (alist->env-vec alist)))
|
|
|
|
(define-foreign %align-env
|
|
(align_env (desc))
|
|
ignore)
|
|
|
|
(define-foreign %free-env
|
|
(free_envvec (desc))
|
|
desc)
|
|
;;; GETENV, SETENV
|
|
;;; they all assume an aligned env
|
|
|
|
|
|
(define-foreign %envvec-setenv (envvec_setenv (desc name) (desc entry))
|
|
desc)
|
|
|
|
(define (envvec-setenv name value)
|
|
(%envvec-setenv name (string-append name "=" value)))
|
|
|
|
(define-foreign envvec-getenv (getenv (string var))
|
|
static-string)
|
|
|
|
(foreign-source
|
|
"#define errno_on_nonzero_or_false(x) ((x) ? s48_enter_fixnum(errno) : S48_FALSE)"
|
|
"" "")
|
|
|
|
(define-foreign envvec-delete-env (delete_env (desc var))
|
|
desc)
|
|
|
|
|
|
;;; Fd-ports
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-stubless-foreign %set-cloexec (fd val) "set_cloexec")
|
|
|
|
;;; Some of fcntl()
|
|
;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
|
|
(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")
|
|
|
|
;;; fcntl()'s F_GETFD and F_SETFD. Note that the SLEAZY- prefix on the
|
|
;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
|
|
;;; of these procedures. Straight CALL/FDES modifies unrevealed file
|
|
;;; descriptors by clearing their CLOEXEC bit when it reveals them -- so it
|
|
;;; would interfere with the reading and writing of that bit!
|
|
|
|
(define (fdes-flags fd/port)
|
|
(sleazy-call/fdes fd/port
|
|
(lambda (fd) (%fcntl-read fd fcntl/get-fdes-flags))))
|
|
|
|
(define (set-fdes-flags fd/port flags)
|
|
(sleazy-call/fdes fd/port
|
|
(lambda (fd) (%fcntl-write fd fcntl/set-fdes-flags flags))))
|
|
|
|
;;; fcntl()'s F_GETFL and F_SETFL.
|
|
;;; Get: Returns open flags + get-status flags (below)
|
|
;;; Set: append, sync, async, nbio, nonblocking, no-delay
|
|
|
|
(define (fdes-status fd/port)
|
|
(sleazy-call/fdes fd/port
|
|
(lambda (fd) (%fcntl-read fd fcntl/get-status-flags))))
|
|
|
|
(define (set-fdes-status fd/port flags)
|
|
(sleazy-call/fdes fd/port
|
|
(lambda (fd) (%fcntl-write fd fcntl/set-status-flags flags))))
|
|
|
|
;;; Miscellaneous
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;; usleep(3): Try to sleep for USECS microseconds.
|
|
;;; sleep(3): Try to sleep for SECS seconds.
|
|
|
|
; De-released -- not POSIX and not on SGI systems.
|
|
; (define-foreign usleep (usleep (integer usecs)) integer)
|
|
|
|
(define (sleep secs) (sleep-until (+ secs (time))))
|
|
|
|
(define (sleep-until when)
|
|
(let* ((when (floor when)) ; Painful to do real->int in Scheme.
|
|
(when (if (exact? when) when (inexact->exact when))))
|
|
(let lp ()
|
|
(or (%sleep-until when) (lp)))))
|
|
|
|
;;; JMG: I don't know whether time_t or long is correct...
|
|
(define-foreign %sleep-until (sleep_until (time_t secs))
|
|
desc)
|
|
|
|
(define-stubless-foreign %gethostname () "scm_gethostname")
|
|
|
|
(define system-name %gethostname)
|
|
|
|
(define-foreign errno-msg (errno_msg (integer i))
|
|
static-string)
|
|
|
|
(define-stubless-foreign %crypt (key salt) "scm_crypt")
|
|
|
|
(define (crypt key salt)
|
|
(let* ((allowed-char-set (rx (| alpha digit "." "/")))
|
|
(salt-regexp (rx (: ,allowed-char-set ,allowed-char-set))))
|
|
(if (not (= (string-length salt) 2)) (error "salt must have length 2"))
|
|
(if (not (regexp-search? salt-regexp salt))
|
|
(error "illegal char in salt " salt))
|
|
(if (> (string-length key) 8) (error "key too long " (string-length key)))
|
|
(%crypt key salt)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;
|
|
;;; Interface to syslog
|
|
;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(define-enum-constants-from-zero syslog-option
|
|
(default
|
|
cons
|
|
ndelay
|
|
pid))
|
|
|
|
(define-enum-constants-from-zero syslog-facility
|
|
(default
|
|
auth
|
|
daemon
|
|
kern
|
|
local0
|
|
local1
|
|
local2
|
|
local3
|
|
local4
|
|
local5
|
|
local6
|
|
local7
|
|
lpr
|
|
mail
|
|
user))
|
|
|
|
;;; sorted by priority
|
|
(define-enum-constants-from-zero syslog-level
|
|
(default
|
|
emerg
|
|
alert
|
|
crit
|
|
err
|
|
warning
|
|
notice
|
|
info
|
|
debug))
|
|
|
|
(define-stubless-foreign %openlog (ident option facility) "scm_openlog")
|
|
(define-stubless-foreign %syslog (facility level message) "scm_syslog")
|
|
(define-stubless-foreign closelog () "scm_closelog")
|
|
|
|
(define (openlog ident . args)
|
|
(let-optionals args ((option syslog-option/default)
|
|
(facility syslog-facility/default))
|
|
(%openlog ident option facility)))
|
|
|
|
(define (syslog message . args)
|
|
(let-optionals args ((level syslog-level/default)
|
|
(facility syslog-facility/default))
|
|
(%syslog facility level (double-char #\% message))))
|
|
|
|
|
|
(define (double-char the-char s)
|
|
(let* ((ans-len (string-fold (lambda (c sum)
|
|
(+ sum (if (char=? c the-char) 2 1)))
|
|
0 s))
|
|
(ans (make-string ans-len)))
|
|
(string-fold (lambda (c i)
|
|
(let ((i (if (char=? c the-char)
|
|
(begin (string-set! ans i the-char) (+ i 1))
|
|
i)))
|
|
(string-set! ans i c)
|
|
(+ i 1)))
|
|
0 s)
|
|
ans)) |