;;; 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 " "#include " "#include " "#include " "#include /* for O_RDWR */" ; ??? "#include " "#include " "#include " "#include " "" "/* 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)) ;;; 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))