From 35f1ddd533a175fa8e10c21a363d4cb68ec41f62 Mon Sep 17 00:00:00 2001 From: sperber Date: Mon, 28 Apr 2003 08:33:46 +0000 Subject: [PATCH] Split scsh code into lots of modules. Note that this change doesn't represent any sort of design suggestion or decision: It merely represents an attempt to codify the dependencies between the parts of the code base. There's still lots of work to be done to actually make user-accessible modules. --- Makefile.in | 26 +- scsh/command-line.scm | 31 + scsh/continuation.scm | 21 + scsh/crypt.scm | 10 + scsh/directory.scm | 66 ++ scsh/environment.scm | 228 ++++++ scsh/fcntl.scm | 25 + scsh/fd-syscalls.scm | 23 + scsh/file-syscalls.scm | 64 ++ scsh/file.scm | 73 ++ scsh/fileinfo.scm | 47 ++ scsh/filesys.scm | 26 + scsh/fname-system.scm | 71 ++ scsh/fname.scm | 88 --- scsh/import-os-error-syscall.scm | 30 + scsh/newports.scm | 31 + scsh/port-collect.scm | 77 ++ scsh/process-high-level.scm | 123 +++ scsh/process-state.scm | 321 ++++++++ scsh/process.scm | 331 +++++++++ scsh/procobj.scm | 4 + scsh/resource.scm | 19 + scsh/rw.scm | 6 - scsh/scsh-interfaces.scm | 291 ++++++-- scsh/scsh-package.scm | 619 ++++++++++++--- scsh/scsh.scm | 1197 ------------------------------ scsh/signal.scm | 54 ++ scsh/stdio.scm | 22 + scsh/syntax.scm | 20 +- scsh/syscalls.scm | 761 ------------------- scsh/system.scm | 14 + scsh/temp-file.scm | 95 +++ scsh/top.scm | 16 +- scsh/user-group.scm | 119 +++ scsh/utilities.scm | 31 +- 35 files changed, 2756 insertions(+), 2224 deletions(-) create mode 100644 scsh/command-line.scm create mode 100644 scsh/continuation.scm create mode 100644 scsh/crypt.scm create mode 100644 scsh/directory.scm create mode 100644 scsh/environment.scm create mode 100644 scsh/fcntl.scm create mode 100644 scsh/fd-syscalls.scm create mode 100644 scsh/file-syscalls.scm create mode 100644 scsh/file.scm create mode 100644 scsh/fname-system.scm create mode 100644 scsh/import-os-error-syscall.scm create mode 100644 scsh/port-collect.scm create mode 100644 scsh/process-high-level.scm create mode 100644 scsh/process-state.scm create mode 100644 scsh/process.scm create mode 100644 scsh/resource.scm delete mode 100644 scsh/scsh.scm create mode 100644 scsh/signal.scm create mode 100644 scsh/stdio.scm delete mode 100644 scsh/syscalls.scm create mode 100644 scsh/system.scm create mode 100644 scsh/temp-file.scm create mode 100644 scsh/user-group.scm diff --git a/Makefile.in b/Makefile.in index fb3da76..d16cb4f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -771,22 +771,32 @@ $(CIG).image: $(IMAGE) $(VM) $(srcdir)/cig/cig.scm $(srcdir)/cig/libcig.scm scsh: scsh/scsh scsh/scsh.image SCHEME =scsh/awk.scm \ + scsh/command-line.scm \ + scsh/continuation.scm \ + scsh/crypt.scm \ scsh/defrec.scm \ + scsh/directory.scm \ + scsh/dot-locking.scm \ scsh/endian.scm \ scsh/enumconst.scm \ + scsh/environment.scm \ scsh/event.scm \ - scsh/low-interrupt.scm \ + scsh/fcntl.scm \ + scsh/fd-syscalls.scm \ scsh/fdports.scm \ + scsh/file.scm \ scsh/fileinfo.scm \ scsh/filemtch.scm \ scsh/filesys.scm \ scsh/flock.scm \ scsh/fname.scm \ + scsh/fname-system.scm \ scsh/fr.scm \ scsh/glob.scm \ - scsh/dot-locking.scm \ scsh/here.scm \ + scsh/import-os-error-syscall.scm \ scsh/libscsh.scm \ + scsh/low-interrupt.scm \ scsh/machine/bufpol.scm \ scsh/machine/errno.scm \ scsh/machine/fdflags.scm \ @@ -800,25 +810,33 @@ SCHEME =scsh/awk.scm \ scsh/meta-arg.scm \ scsh/network.scm \ scsh/newports.scm \ + scsh/port-collect.scm \ + scsh/process-high-level.scm \ + scsh/process-state.scm \ + scsh/process.scm \ scsh/procobj.scm \ scsh/pty.scm \ scsh/rdelim.scm \ + scsh/resource.scm \ scsh/rw.scm \ scsh/scsh-condition.scm \ scsh/scsh-interfaces.scm \ scsh/scsh-package.scm \ scsh/scsh-read.scm \ scsh/scsh-version.scm \ - scsh/scsh.scm \ scsh/sighandlers.scm \ + scsh/signal.scm \ scsh/startup.scm \ + scsh/stdio.scm \ scsh/stringcoll.scm \ scsh/syntax-helpers.scm \ scsh/syntax.scm \ - scsh/syscalls.scm \ + scsh/system.scm \ + scsh/temp-file.scm \ scsh/time.scm \ scsh/top.scm \ scsh/tty.scm \ + scsh/user-group.scm \ scsh/utilities.scm \ scsh/weaktables.scm \ scsh/rx/packages.scm \ diff --git a/scsh/command-line.scm b/scsh/command-line.scm new file mode 100644 index 0000000..fbc7abd --- /dev/null +++ b/scsh/command-line.scm @@ -0,0 +1,31 @@ +;;; Command-line argument access +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Some globals. +(define %command-line '()) ; Includes program. +(define command-line-arguments #f) ; Doesn't include program. + +(define (set-command-line-args! args) + (set! %command-line args) + (set! command-line-arguments (append (cdr args) '()))) + +(define (arg* arglist n . maybe-default-thunk) + (let ((oops (lambda () (error "argument out of bounds" arglist n)))) + (if (< n 1) (oops) + (let lp ((al arglist) (n n)) + (if (pair? al) + (if (= n 1) (car al) + (lp (cdr al) (- n 1))) + (if (and (pair? maybe-default-thunk) + (null? (cdr maybe-default-thunk))) + ((car maybe-default-thunk)) + (oops))))))) + +(define (arg arglist n . maybe-default) + (if maybe-default (arg* arglist n (lambda () (car maybe-default))) + (arg* arglist n))) + +(define (argv n . maybe-default) + (apply arg %command-line (+ n 1) maybe-default)) + +(define (command-line) (append %command-line '())) diff --git a/scsh/continuation.scm b/scsh/continuation.scm new file mode 100644 index 0000000..4c4ccce --- /dev/null +++ b/scsh/continuation.scm @@ -0,0 +1,21 @@ +;;; Move this to somewhere else as soon as Marc has published his SRFI +(define (continuation-capture receiver) + ((call-with-current-continuation + (lambda (cont) + (lambda () (receiver cont)))))) + +(define (continuation-graft cont thunk) + (cont thunk)) + +(define (continuation-return cont . returned-values) + (continuation-graft + cont + (lambda () (apply values returned-values)))) + +;;; Call THUNK, then die. + +(define (call-terminally thunk) + (with-continuation null-continuation thunk)) + +;; from shift-reset.scm: +(define null-continuation #f) diff --git a/scsh/crypt.scm b/scsh/crypt.scm new file mode 100644 index 0000000..13e4e49 --- /dev/null +++ b/scsh/crypt.scm @@ -0,0 +1,10 @@ +(import-os-error-syscall %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))) diff --git a/scsh/directory.scm b/scsh/directory.scm new file mode 100644 index 0000000..42a8fa2 --- /dev/null +++ b/scsh/directory.scm @@ -0,0 +1,66 @@ +;;; Directory stuff +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (directory-files . args) + (with-resources-aligned + (list cwd-resource euid-resource egid-resource) + (lambda () + (let-optionals args ((dir ".") + (dotfiles? #f)) + (check-arg string? dir directory-files) + (let* ((files (%open-dir (ensure-file-name-is-nondirectory dir))) + (files-sorted ((structure-ref sort sort-list!) files filename<=))) + (if dotfiles? + files-sorted + (filter (lambda (f) (not (dotfile? f))) + files-sorted))))))) + +(define (dotfile? f) + (char=? (string-ref f 0) #\.)) + +(define (filename<= f1 f2) + (if (dotfile? f1) + (if (dotfile? f2) + (string<= f1 f2) + #t) + (if (dotfile? f2) + #f + (string<= f1 f2)))) + +; A record for directory streams. It just has the name and a byte vector +; containing the C directory object. The name is used only for printing. + +(define-record directory-stream + name + c-dir) + +(define-record-discloser type/directory-stream + (lambda (ds) + (list 'directory-stream (directory-stream:name ds)))) + +; Directory streams are meaningless in a resumed image. +(define-record-resumer type/directory-stream #f) + +(define (open-directory-stream name) + (let ((dir (make-directory-stream + name + (with-resources-aligned + (list cwd-resource euid-resource egid-resource) + (lambda () + (open-dir name)))))) + (add-finalizer! dir close-directory-stream) + dir)) + +(define (read-directory-stream dir-stream) + (read-dir (directory-stream:c-dir dir-stream))) + +(define (close-directory-stream dir-stream) + (let ((c-dir (directory-stream:c-dir dir-stream))) + (if c-dir + (begin + (close-dir c-dir) + (set-directory-stream:c-dir dir-stream #f))))) + +(import-os-error-syscall open-dir (name) "scm_opendir") +(import-os-error-syscall close-dir (dir-stream) "scm_closedir") +(import-os-error-syscall read-dir (dir-stream) "scm_readdir") diff --git a/scsh/environment.scm b/scsh/environment.scm new file mode 100644 index 0000000..5f81666 --- /dev/null +++ b/scsh/environment.scm @@ -0,0 +1,228 @@ +;;; 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) "=" + (let ((val (cdr var.val))) + (if (string? val) val + (string-join val ":"))))) + alist))) + +;;; ENV->ALIST + +(import-os-error-syscall %load-env () "scm_envvec") + +(define (environ-env->alist) + (let ((env-list.envvec (%load-env))) + (cons (env-list->alist (car env-list.envvec)) + (cdr env-list.envvec)))) + + +;;; ALIST->ENV + +;;; (%create-env ((vector 'X) -> address)) +(import-os-error-syscall %create-env (envvec) "create_env") + +;;; assumes aligned env +(define (envvec-alist->env alist) + (%create-env (alist->env-vec alist))) + +(import-os-error-syscall %align-env (envvec) "align_env") + +(import-os-error-syscall %free-env (envvec) "free_envvec") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Environment per thread +(define *env-cache* 'uninitialized) +(define env-lock (make-lock)) + +(define (install-env) + (set! *env-cache* (environ**-read)) + (set! $env ;;; TODO The old thread-fluid will remain + (make-preserved-thread-fluid + (env-cache)))) +; (set! env-lock (make-lock))) + +(define (env-cache) + *env-cache*) + +;; Actually do the syscall and update the cache +;; assumes the env lock obtained +(define (change-and-cache-env env) + (environ**-set env) + (set! *env-cache* env)) + +;; The thread-specific env: A thread fluid + +(define $env 'empty-env-value) + +(define (thread-read-env) (thread-fluid $env)) +(define (thread-set-env! res) (set-thread-fluid! $env res)) +(define (let-env res thunk) + (let-thread-fluid $env res thunk)) + +(define (really-with-env* env thunk) + (with-lock env-lock + (lambda () + (change-and-cache-env env))) + (let-env env thunk)) + +(define (align-env!) + (let ((res (thread-read-env))) + (if (not (env=? res (env-cache))) + (change-and-cache-env res)))) + +(define (thread-change-env res) + (with-lock env-lock + (lambda () + (change-and-cache-env res) + (thread-set-env! (env-cache))))) + +(define environ-resource (make-resource align-env! env-lock)) + +(define env-reinitializer + (make-reinitializer install-env)) + +(define-record env + envvec + alist) ; Corresponding alist + +(define-record-resumer type/env + (lambda (env) + (set-env:envvec env #f))) + +(define (env=? e1 e2) + (and (env:envvec e1) + (eq? (env:envvec e1) + (env:envvec e2)))) + +(define-record envvec + environ ;; char** + ) + +(define (add-envvec-finalizer! envvec) + (add-finalizer! envvec envvec-finalizer)) + +(define-exported-binding "envvec-record-type" type/envvec) +(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!) + +(define (envvec-finalizer envvec) + (%free-env envvec)) + +(define (environ**-read) + (let ((alist.envvec (environ-env->alist))) + (make-env (cdr alist.envvec) (car alist.envvec)))) + +(define (environ**-set env) + (if (env:envvec env) + (%align-env (env:envvec env)) + (set-env:envvec env (envvec-alist->env (env:alist env))))) + +(define (getenv var) + (let* ((env (thread-read-env)) + (res (assoc var (env:alist env)))) + (if res (cdr res) res))) + +(define (env->alist) + (env:alist (thread-read-env))) + +(define (setenv var val) + (let* ((env (thread-read-env)) + (alist (if val + (alist-update + var + val + (env:alist env)) + (alist-delete + var + (env:alist env))))) + (thread-set-env! + (make-env + #f + alist)))) + +(define (alist->env alist) + (thread-set-env! + (make-env + #f + alist))) + +(define (with-env* alist-delta thunk) + (let ((new-env (fold (lambda (key/val alist) + (alist-update (car key/val) (cdr key/val) alist)) + (env->alist) + alist-delta))) + (with-total-env* new-env thunk))) + +(define (with-total-env* alist thunk) + (really-with-env* (make-env #f alist) thunk)) + +(define (alist-delete key alist) + (filter (lambda (key/val) (not (equal? key (car key/val)))) alist)) + +(define (alist-update key val alist) + (cons (cons key val) + (alist-delete key alist))) + +;;; Remove shadowed entries from ALIST. Preserves element order. +;;; (This version shares no structure.) + +(define (alist-compress alist) + (reverse (let compress ((alist alist) (ans '())) + (if (pair? alist) + (let ((key/val (car alist)) + (alist (cdr alist))) + (compress alist (if (assoc (car key/val) ans) ans + (cons key/val ans)))) + ans)))) + +(define (add-before elt before list) + (let rec ((list list)) + (if (pair? list) + (let ((x (car list))) + (if (equal? x before) + (cons elt list) + (cons x (rec (cdr list))))) + (cons elt list)))) + +;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER +;;; in LIST, and returns the list. However, if the LET finds no occurrence +;;; of AFTER in LIST, it returns #F instead. + +(define (add-after elt after list) + (or (let rec ((list list)) + (if (pair? list) + (let* ((x (car list)) + (tail (cdr list)) + (ans (rec tail))) ; #f if AFTER wasn't encountered. + (cond (ans (cons x ans)) + ((equal? x after) + (cons x (cons elt tail))) + (else #f))) ; AFTER doesn't appear in LIST. + #f)) ; AFTER doesn't appear in LIST. + (cons elt list))) + +(define-simple-syntax (with-env delta . body) + (with-env* `delta (lambda () . body))) + +(define-simple-syntax (with-total-env env . body) + (with-total-env* `env (lambda () . body))) + +(install-env) diff --git a/scsh/fcntl.scm b/scsh/fcntl.scm new file mode 100644 index 0000000..7eebd36 --- /dev/null +++ b/scsh/fcntl.scm @@ -0,0 +1,25 @@ +;;; 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)))) diff --git a/scsh/fd-syscalls.scm b/scsh/fd-syscalls.scm new file mode 100644 index 0000000..a219b38 --- /dev/null +++ b/scsh/fd-syscalls.scm @@ -0,0 +1,23 @@ +;;; Fd-ports +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(import-os-error-syscall %set-cloexec (fd val) "set_cloexec") + +;;; Some of fcntl() +;;;;;;;;;;;;;;;;;;; + +(import-os-error-syscall %fcntl-read (fd command) "fcntl_read") +(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write") + +(import-os-error-syscall %close-fdes (fd) "scsh_close") + +(import-os-error-syscall %dup (fd) "scsh_dup") + +(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2") + +(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek") + +(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes") + +(import-os-error-syscall %open (path flags mode) "scsh_open") + diff --git a/scsh/file-syscalls.scm b/scsh/file-syscalls.scm new file mode 100644 index 0000000..e9a7f56 --- /dev/null +++ b/scsh/file-syscalls.scm @@ -0,0 +1,64 @@ +(import-os-error-syscall %set-cloexec (fd val) "set_cloexec") + +(import-os-error-syscall %fcntl-read (fd command) "fcntl_read") +(import-os-error-syscall %fcntl-write (fd command val) "fcntl_write") + +(import-os-error-syscall %close-fdes (fd) "scsh_close") + +(import-os-error-syscall %dup (fd) "scsh_dup") + +(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2") + +(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek") + +(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes") + +(import-os-error-syscall %open (path flags mode) "scsh_open") + +(import-os-error-syscall %pipe-fdes () "scheme_pipe") + +(import-os-error-syscall %truncate-file (path length) "scsh_truncate") + +(import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate") + +(import-os-error-syscall %create-symlink (old-name new-name) "scsh_symlink") + +(import-os-error-syscall %read-symlink (path) "scsh_readlink") + +(import-os-error-syscall %rename-file (old-name new-name) "scsh_rename") + +(import-os-error-syscall %delete-directory (path) "scsh_rmdir") + +(import-os-error-syscall %%create-directory (path mode) "scsh_mkdir") + +(import-os-error-syscall %create-hard-link (original-name new-name) + "scsh_link") + +(import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo") + +(import-os-error-syscall %set-file-mode (path mode) "scsh_chmod") + +(import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod") + +(import-os-error-syscall %set-file-uid&gid (path uid gid) "scsh_chown") + +(import-os-error-syscall %set-fdes-uid&gid (fd uid gid) "scsh_fchown") + +(import-os-error-syscall %utime (path ac m) "scm_utime") + +(import-os-error-syscall %utime-now (path) "scm_utime_now") + +(import-os-error-syscall %stat-file (path data chase?) "scheme_stat") + +(import-os-error-syscall %stat-fdes (fd data) "scheme_fstat") + +(import-os-error-syscall %delete-file (path) "scsh_unlink") + +(import-os-error-syscall %sync-file (fd) "scsh_fsync") + +;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys. +(import-os-error-syscall %sync-file-system () "scsh_sync") + +(import-os-error-syscall %open-dir (dir-name) "directory_files") + + diff --git a/scsh/file.scm b/scsh/file.scm new file mode 100644 index 0000000..0534f4d --- /dev/null +++ b/scsh/file.scm @@ -0,0 +1,73 @@ +;;; 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) + (with-resources-aligned (list cwd-resource euid-resource egid-resource) + (lambda () (fname-op thing))) + (call/fdes thing fd-op))) + +(define (set-file-mode thing mode) + (generic-file-op thing + (lambda (fd) (%set-fdes-mode fd mode)) + (lambda (fname) (%set-file-mode fname mode)))) + +(define (set-file-owner thing uid) + (generic-file-op thing + (lambda (fd) (%set-fdes-uid&gid fd uid -1)) + (lambda (fname) (%set-file-uid&gid fname uid -1)))) + +(define (set-file-group thing gid) + (generic-file-op thing + (lambda (fd) (%set-fdes-uid&gid fd -1 gid)) + (lambda (fname) (%set-file-uid&gid fname -1 gid)))) + + +;(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)) + +;;; (SET-FILE-TIMES path [access-time mod-time]) + +(define (set-file-times path . maybe-times) + (with-resources-aligned + (list cwd-resource euid-resource egid-resource) + (lambda () + (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 path access-time + mod-time )) + (%utime-now path))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (truncate-file thing length) + (generic-file-op thing + (lambda (fd) (%truncate-fdes fd length)) + (lambda (fname) (%truncate-file fname length)))) + +(define (delete-file path) + (with-resources-aligned (list cwd-resource euid-resource egid-resource) + (lambda () (%delete-file path)))) + +(define (sync-file fd/port) + (if (output-port? fd/port) (force-output fd/port)) + (sleazy-call/fdes fd/port %sync-file)) + +(define sync-file-system %sync-file-system) + diff --git a/scsh/fileinfo.scm b/scsh/fileinfo.scm index e32745c..9441d55 100644 --- a/scsh/fileinfo.scm +++ b/scsh/fileinfo.scm @@ -36,6 +36,53 @@ ;;; ;;; Otherwise, signals an error. + +(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?) + (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.")) + (define (fd/port/fname-not-accessible? perms fd/port/fname) (with-errno-handler ((err data) ((errno/acces) 'search-denied) diff --git a/scsh/filesys.scm b/scsh/filesys.scm index 4c522f9..a363d62 100644 --- a/scsh/filesys.scm +++ b/scsh/filesys.scm @@ -64,6 +64,11 @@ ;;;;;;; +(define (%create-directory path . maybe-mode) + (let ((mode (:optional maybe-mode #o777)) + (fname (ensure-file-name-is-nondirectory path))) + (%%create-directory fname mode))) + (define (create-directory dir . rest) (let ((perms (if (null? rest) #o777 (car rest))) (override? (if (or (null? rest) (null? (cdr rest))) #f @@ -120,6 +125,27 @@ (lambda () (%rename-file old-fname new-fname)))))) +(define (y-or-n? question . maybe-eof-value) + (let loop ((count *y-or-n-eof-count*)) + (display question) + (display " (y/n)? ") + (let ((line (read-line))) + (cond ((eof-object? line) + (newline) + (if (= count 0) + (:optional maybe-eof-value (error "EOF in y-or-n?")) + (begin (display "I'll only ask another ") + (write count) + (display " times.") + (newline) + (loop (- count 1))))) + ((< (string-length line) 1) (loop count)) + ((char=? (string-ref line 0) #\y) #t) + ((char=? (string-ref line 0) #\n) #f) + (else (loop count)))))) + +(define *y-or-n-eof-count* 100) + (define (read-symlink path) (with-resources-aligned (list cwd-resource euid-resource egid-resource) diff --git a/scsh/fname-system.scm b/scsh/fname-system.scm new file mode 100644 index 0000000..bfbd80d --- /dev/null +++ b/scsh/fname-system.scm @@ -0,0 +1,71 @@ +;; user/group-dependent stuff + +(define (resolve-tilde-file-name fname) + (let ((len (string-length fname))) + (if (and (> len 0) (char=? #\~ (string-ref fname 0))) + (let ((tilde->homedir (lambda (end) + (if (= end 1) + home-directory ; Just ~ + (let* ((user (substring fname 1 end)) + (ui (name->user-info user))) + (user-info:home-dir ui)))))) + (cond ((string-index fname #\/ 1) => + (lambda (slash) + (string-append (tilde->homedir slash) "/" + (substring fname (+ slash 1) len)))) + (else (tilde->homedir len)))) + fname))) + +(define (resolve-file-name fname . maybe-root) + (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root "."))) + (fname (ensure-file-name-is-nondirectory fname))) + (if (zero? (string-length fname)) + "/" + (let ((c (string-ref fname 0))) + (cond ((char=? #\/ c) fname) ; Absolute file name. + + ((char=? #\~ c) ; ~ file name + (resolve-tilde-file-name fname)) + + (else (string-append (file-name-as-directory root) fname))))))) + +(define (expand-file-name fname . maybe-dir) + (simplify-file-name (apply resolve-file-name fname maybe-dir))) + +;; process-state-dependent stuff + +(define (absolute-file-name fname . maybe-root) + (let ((fname (ensure-file-name-is-nondirectory fname))) + (if (zero? (string-length fname)) + "/" + (simplify-file-name + (if (char=? #\/ (string-ref fname 0)) + fname ; Absolute file name. + (let ((root (:optional maybe-root (cwd)))) + (string-append (file-name-as-directory root) fname))))))) + +;;; Ugh. +(define (substitute-env-vars str) + (let lp ((ans '()) (s str)) + (let ((len (string-length s))) + (cond + ((zero? len) (apply string-append (reverse! ans))) + ((string-index s #\$) => + (lambda (i) + (let ((ans (cons (substring s 0 i) ans)) + (s (substring s (+ i 1) len)) + (len (- len (+ i 1)))) + (if (zero? len) + (lp ans "") + (let ((next-char (string-ref s 0))) + (cond ((char=? #\{ next-char) + (cond ((string-index s #\}) => + (lambda (i) + (lp (cons (getenv (substring s 1 i)) ans) + (substring s (+ i 1) len)))) + (else (error "Unbalanced ${ delimiter in string" s)))) + (else + (let ((i (or (string-index s #\/) len))) + (lp (cons (getenv (substring s 0 i)) ans) + (substring s i len)))))))))) + (else (lp (cons s ans) "")))))) diff --git a/scsh/fname.scm b/scsh/fname.scm index b7ed943..b776b0a 100644 --- a/scsh/fname.scm +++ b/scsh/fname.scm @@ -151,37 +151,6 @@ (define (replace-extension fname ext) (string-append (file-name-sans-extension fname) ext)) - -(define (resolve-tilde-file-name fname) - (let ((len (string-length fname))) - (if (and (> len 0) (char=? #\~ (string-ref fname 0))) - (let ((tilde->homedir (lambda (end) - (if (= end 1) - home-directory ; Just ~ - (let* ((user (substring fname 1 end)) - (ui (name->user-info user))) - (user-info:home-dir ui)))))) - (cond ((string-index fname #\/ 1) => - (lambda (slash) - (string-append (tilde->homedir slash) "/" - (substring fname (+ slash 1) len)))) - (else (tilde->homedir len)))) - fname))) - -(define (resolve-file-name fname . maybe-root) - (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root "."))) - (fname (ensure-file-name-is-nondirectory fname))) - (if (zero? (string-length fname)) - "/" - (let ((c (string-ref fname 0))) - (cond ((char=? #\/ c) fname) ; Absolute file name. - - ((char=? #\~ c) ; ~ file name - (resolve-tilde-file-name fname)) - - (else (string-append (file-name-as-directory root) fname))))))) - - ;;; - Remove leading and internal occurrences of dot. A trailing dot ;;; is left alone, in case the parent is a symlink. ;;; - Remove internal and trailing double-slashes. A leading double-slash @@ -225,63 +194,6 @@ (apply string-append ans)))) -(define (expand-file-name fname . maybe-dir) - (simplify-file-name (apply resolve-file-name fname maybe-dir))) -(define (absolute-file-name fname . maybe-root) - (let ((fname (ensure-file-name-is-nondirectory fname))) - (if (zero? (string-length fname)) - "/" - (simplify-file-name - (if (char=? #\/ (string-ref fname 0)) - fname ; Absolute file name. - (let ((root (:optional maybe-root (cwd)))) - (string-append (file-name-as-directory root) fname))))))) - -(define (home-dir . maybe-user) - (if (pair? maybe-user) - (let ((user (car maybe-user))) - (ensure-file-name-is-nondirectory - (or (%homedir user) - (error "Cannot get user's home directory" - user)))) - home-directory)) - - -;;; (home-file [user] fname) - -(define (home-file arg1 . maybe-arg2) - (receive (dir fname) - (if (pair? maybe-arg2) - (values (home-dir arg1) (car maybe-arg2)) - (values home-directory arg1)) - (string-append (file-name-as-directory dir) fname))) - - -;;; Ugh. -(define (substitute-env-vars str) - (let lp ((ans '()) (s str)) - (let ((len (string-length s))) - (cond - ((zero? len) (apply string-append (reverse! ans))) - ((string-index s #\$) => - (lambda (i) - (let ((ans (cons (substring s 0 i) ans)) - (s (substring s (+ i 1) len)) - (len (- len (+ i 1)))) - (if (zero? len) - (lp ans "") - (let ((next-char (string-ref s 0))) - (cond ((char=? #\{ next-char) - (cond ((string-index s #\}) => - (lambda (i) - (lp (cons (getenv (substring s 1 i)) ans) - (substring s (+ i 1) len)))) - (else (error "Unbalanced ${ delimiter in string" s)))) - (else - (let ((i (or (string-index s #\/) len))) - (lp (cons (getenv (substring s 0 i)) ans) - (substring s i len)))))))))) - (else (lp (cons s ans) "")))))) diff --git a/scsh/import-os-error-syscall.scm b/scsh/import-os-error-syscall.scm new file mode 100644 index 0000000..d7c8cd3 --- /dev/null +++ b/scsh/import-os-error-syscall.scm @@ -0,0 +1,30 @@ +(define-syntax import-os-error-syscall + (syntax-rules () + ((import-os-error-syscall syscall (%arg ...) c-name) + (begin + (import-lambda-definition syscall/eintr (%arg ...) c-name) + (define (syscall %arg ...) + (let ((arg %arg) ...) + (continuation-capture + (lambda (cont) + (let loop () + (with-handler + (lambda (condition more) + (if (and (exception? condition) (eq? (exception-reason condition) + 'os-error)) + (let ((stuff (exception-arguments condition))) + (if (= (cadr stuff) errno/intr) + (loop) + (continuation-graft + cont + (lambda () + (apply errno-error + (cadr stuff) ; errno + (caddr stuff) ;msg + syscall + (cdddr stuff)))))) ;packet + (more))) + (lambda () + (syscall/eintr %arg ...)))))))))))) + +(import-os-error-syscall errno-msg (i) "errno_msg") diff --git a/scsh/newports.scm b/scsh/newports.scm index 3741414..bb4d011 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -1037,3 +1037,34 @@ (port/fdes->output-channel write-port))) ready-write-channels)) write-list)))))) + +;;; I/O +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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)))) + (%fd-seek fd offset whence))) + +(define (tell fd/port) + (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port)))) + (%fd-seek fd 0 seek/delta))) + +(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666 + (with-resources-aligned + (list cwd-resource umask-resource euid-resource egid-resource) + (lambda () + (%open path flags (:optional maybe-mode #o666))))) + +(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))) \ No newline at end of file diff --git a/scsh/port-collect.scm b/scsh/port-collect.scm new file mode 100644 index 0000000..88b9c6e --- /dev/null +++ b/scsh/port-collect.scm @@ -0,0 +1,77 @@ +;;; Read characters from PORT until EOF, collect into a string. + +(define (port->string port) + (let ((sc (make-string-collector))) + (letrec ((lp (lambda () + (cond ((read-string 1024 port) => + (lambda (s) + (collect-string! sc s) + (lp))) + (else (string-collector->string sc)))))) + (lp)))) + +;;; (loop (initial (sc (make-string-collector))) +;;; (bind (s (read-string 1024 port))) +;;; (while s) +;;; (do (collect-string! sc s)) +;;; (result (string-collector->string sc))) + +;;; Read items from PORT with READER until EOF. Collect items into a list. + +(define (port->list reader port) + (let lp ((ans '())) + (let ((x (reader port))) + (if (eof-object? x) (reverse! ans) + (lp (cons x ans)))))) + +(define (port->sexp-list port) + (port->list read port)) + +(define (port->string-list port) + (port->list read-line port)) + +(define (port-fold port reader op . seeds) + (letrec ((fold (lambda seeds + (let ((x (reader port))) + (if (eof-object? x) (apply values seeds) + (call-with-values (lambda () (apply op x seeds)) + fold)))))) + (apply fold seeds))) + +(define reduce-port + (deprecated-proc port-fold 'reduce-port "Use port-fold instead.")) + +;;; Not defined: +;;; (field-reader field-delims record-delims) +;;; Returns a reader that reads strings delimited by 1 or more chars from +;;; the string FIELD-DELIMS. These strings are collected in a list until +;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the +;;; accumulated list of strings is returned. For example, if we want +;;; a procedure that reads one line of input, splitting it into +;;; whitespace-delimited strings, we can use +;;; (field-reader " \t" "\n") +;;; for a reader. + + + +;; Loop until EOF reading characters or strings and writing (FILTER char) +;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE. + +(define (make-char-port-filter filter) + (lambda () + (let lp () + (let ((c (read-char))) + (if (not (eof-object? c)) + (begin (write-char (filter c)) + (lp))))))) + +(define (make-string-port-filter filter . maybe-buflen) + (let* ((buflen (:optional maybe-buflen 1024)) + (buf (make-string buflen))) + (lambda () + (let lp () + (cond ((read-string! buf 0 buflen) => + (lambda (nread) + (display (filter (if (= nread buflen) buf + (substring buf 0 nread)))) ; last one. + (lp)))))))) diff --git a/scsh/process-high-level.scm b/scsh/process-high-level.scm new file mode 100644 index 0000000..26042c3 --- /dev/null +++ b/scsh/process-high-level.scm @@ -0,0 +1,123 @@ +;;;; Process->Scheme interface forms: run/collecting, run/port, run/string, ... + +;;; (run/collecting FDS . EPF) +;;; -------------------------- +;;; RUN/COLLECTING and RUN/COLLECTING* run processes that produce multiple +;;; output streams and return ports open on these streams. +;;; +;;; To avoid issues of deadlock, RUN/COLLECTING first runs the process +;;; with output to temp files, then returns the ports open on the temp files. +;;; +;;; (run/collecting (1 2) (ls)) +;;; runs ls with stdout (fd 1) and stderr (fd 2) redirected to temporary files. +;;; When ls is done, RUN/COLLECTING returns two ports open on the temporary +;;; files. The files are deleted before RUN/COLLECTING returns, so when +;;; the ports are closed, they vanish. +;;; +;;; The FDS list of file descriptors is implicitly backquoted. +;;; +;;; RUN/COLLECTING* is the procedural abstraction of RUN/COLLECTING. + +(define (run/collecting* fds thunk) + ;; First, generate a pair of ports for each communications channel. + ;; Each channel buffers through a temp file. + (let* ((channels (map (lambda (ignore) + (call-with-values temp-file-channel cons)) + fds)) + (read-ports (map car channels)) + (write-ports (map cdr channels)) + + ;; In a subprocess, close the read ports, redirect input from + ;; the write ports, and run THUNK. + (status (run (begin (for-each close-input-port read-ports) + (for-each move->fdes write-ports fds) + (thunk))))) + + ;; In this process, close the write ports and return the exit status + ;; and all the the read ports. + (for-each close-output-port write-ports) + (apply values status read-ports))) + + +;;; Single-stream collectors: +;;; Syntax: run/port, run/file, run/string, run/strings, run/sexp, run/sexps +;;; Procedures: run/port*, run/file*, run/string*, run/strings*, run/sexp*, +;;; run/sexps* +;;; port->string, port->string-list, port->sexp-list, +;;; port->list +;;; +;;; Syntax: +;;; (run/port . epf) +;;; Fork off the process EPF and return a port on its stdout. +;;; (run/file . epf) +;;; Run process EPF with stdout redirected into a temp file. +;;; When the process exits, return the name of the file. +;;; (run/string . epf) +;;; Read the process' stdout into a string and return it. +;;; (run/strings . epf) +;;; Run process EPF, reading newline-terminated strings from its stdout +;;; until EOF. After process exits, return list of strings read. Delimiting +;;; newlines are trimmed from the strings. +;;; (run/sexp . epf) +;;; Run process EPF, read and return one sexp from its stdout with READ. +;;; (run/sexps . epf) +;;; Run process EPF, read sexps from its stdout with READ until EOF. +;;; After process exits, return list of items read. +;;; +;;; Procedural abstractions: +;;; run/port*, run/file*, run/string*, run/strings*, run/sexp*, run/sexps* +;;; +;;; These are all procedural equivalents for the macros. They all take +;;; one argument: the process to be executed passed as a thunk. For example, +;;; (RUN/PORT . epf) expands into (RUN/PORT* (LAMBDA () (EXEC-EPF . epf))) +;;; +;;; Other useful procedures: +;;; +;;; (port->string port) +;;; Read characters from port until EOF; return string collected. +;;; (port->string-list port) +;;; Read newline-terminated strings from port until EOF. Return +;;; the list of strings collected. +;;; (port->sexp-list port) +;;; Read sexps from port with READ until EOF. Return list of items read. +;;; (port->list reader port) +;;; Repeatedly applies READER to PORT, accumulating results into a list. +;;; On EOF, returns the list of items thus collected. +;;; (port-fold port reader op . seeds) +;;; Repeatedly read things from PORT with READER. Each time you read +;;; some value V, compute a new set of seeds with (apply OP V SEEDS). +;;; (More than 1 seed means OP must return multiple values). +;;; On eof, return the seeds: (apply value SEEDS). +;;; PORT->LIST is just (PORT-FOLD PORT READ CONS '()) + +(define (run/port+proc* thunk) + (receive (r w) (pipe) + (let ((proc (fork (lambda () + (close r) + (move->fdes w 1) + (with-current-output-port* w thunk))))) + (close w) + (values r proc)))) + +(define (run/port* thunk) + (receive (port proc) (run/port+proc* thunk) + port)) + +(define (run/file* thunk) + (let ((fname (create-temp-file))) + (run (begin (thunk)) (> ,fname)) + fname)) + +(define (run/string* thunk) + (close-after (run/port* thunk) port->string)) + +(define (run/sexp* thunk) + (close-after (run/port* thunk) read)) + +(define (run/sexps* thunk) + (close-after (run/port* thunk) port->sexp-list)) + +(define (run/strings* thunk) + (close-after (run/port* thunk) port->string-list)) + + diff --git a/scsh/process-state.scm b/scsh/process-state.scm new file mode 100644 index 0000000..5a07690 --- /dev/null +++ b/scsh/process-state.scm @@ -0,0 +1,321 @@ +;;; UMASK + +(import-os-error-syscall set-process-umask (mask) "scsh_umask") + +(define (process-umask) + (let ((m (set-process-umask 0))) + (set-process-umask m) + m)) +;;; Working directory + +(import-os-error-syscall %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 dir))) + +;; TODO: we get an error if cwd does not exist on startup +(import-os-error-syscall process-cwd () "scheme_cwd") + +;;; GID + +(import-os-error-syscall user-gid () "scsh_getgid") + +(import-os-error-syscall process-user-effective-gid () "scsh_getegid") + +(import-os-error-syscall process-set-gid (gid) "scsh_setgid") + +(import-os-error-syscall set-process-user-effective-gid (gid) "scsh_setegid") + +(import-os-error-syscall user-supplementary-gids () "get_groups") + +;;; UID +(import-os-error-syscall user-uid () "scsh_getuid") + +(import-os-error-syscall process-user-effective-uid () "scsh_geteuid") + +(import-os-error-syscall process-set-uid (uid) "scsh_setuid") + +(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid") + +(import-os-error-syscall %user-login-name () "my_username") + +(define (user-login-name) + (or (%user-login-name) + (error "Cannot get your name"))) + + +;;; PID + +(import-os-error-syscall pid () "scsh_getpid") +(import-os-error-syscall parent-pid () "scsh_getppid") +;;; Process groups and session ids +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(import-os-error-syscall process-group () "scsh_getpgrp") + +(import-os-error-syscall %set-process-group (pid groupid) "scsh_setpgid") + +(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))) + + +(import-os-error-syscall become-session-leader () "scsh_setsid") + +;;; Miscellaneous process state +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; PROCESS TIMES + +;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away. + + +(import-os-error-syscall process-times/list () "process_times") + +(define (process-times) + (apply values (process-times/list))) + +(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec") + +;;; Resources + +;; Align the value of the Unix cwd with scsh's value. +;; Since another thread could disalign, this call and +;; any ensuring syscall that relies upon it should +;; be "glued together" with the cwd lock. + +(define cwd-lock (make-lock)) + +(define (align-cwd!) + (let ((thread-cwd (cwd))) + (if (not (string=? thread-cwd (cwd-cache))) + (change-and-cache-cwd thread-cwd)))) + +(define cwd-resource (make-resource align-cwd! cwd-lock)) + +;; example syscall +;; (define (exported-delete-file fname) +;; (with-cwd-aligned (really-delete-file fname))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; effective uid and gid per thread + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; working directory per thread + +(define *cwd-cache* 'uninitialized) + +(define (initialize-cwd) + (set! *cwd-cache* (process-cwd)) + (set! $cwd ;;; TODO The old thread-fluid will remain + (make-preserved-thread-fluid + (cwd-cache)))) +; (set! cwd-lock (make-lock))) + +(define (cwd-cache) + *cwd-cache*) + +;; Actually do the syscall and update the cache +;; assumes the cwd lock obtained +(define (change-and-cache-cwd new-cwd) + (if (not (file-name-absolute? new-cwd)) + (process-chdir (string-append (cwd) "/" new-cwd)) + (process-chdir new-cwd)) + (set! *cwd-cache* (process-cwd))) + +;; The thread-specific cwd: A thread fluid + +(define $cwd 'empty-cwd-value) + +(define (cwd) (thread-fluid $cwd)) +(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd)) +(define (let-cwd cwd thunk) + (let-thread-fluid $cwd cwd thunk)) + +(define (with-cwd* new-cwd thunk) + (let ((changed-cwd + (with-lock cwd-lock + (lambda () + (change-and-cache-cwd new-cwd) + (cwd-cache))))) + (let-cwd changed-cwd thunk))) + +(define (chdir . maybe-dir) + (let ((dir (:optional maybe-dir (home-dir)))) + (with-lock cwd-lock + (lambda () + (change-and-cache-cwd dir) + (thread-set-cwd! (cwd-cache)))))) + +(define cwd-reinitializer + (make-reinitializer (lambda () (initialize-cwd)))) + +(initialize-cwd) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; umask per thread +(define *umask-cache* 'uninitialized) +(define umask-lock (make-lock)) + +(define (initialize-umask) + (set! *umask-cache* (process-umask)) + (set! $umask ;;; TODO The old thread-fluid will remain + (make-preserved-thread-fluid + (umask-cache)))) +; (set! umask-lock (make-lock))) + +(define (umask-cache) + *umask-cache*) + +;; Actually do the syscall and update the cache +;; assumes the resource lock obtained +(define (change-and-cache-umask new-umask) + (set-process-umask new-umask) + (set! *umask-cache* (process-umask))) + +;; The thread-specific umask: A thread fluid + +(define $umask 'empty-umask-value) + +(define (umask) (thread-fluid $umask)) +(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask)) +(define (let-umask new-umask thunk) + (let-thread-fluid $umask new-umask thunk)) + +(define (with-umask* new-umask thunk) + (let ((changed-umask + (with-lock umask-lock + (lambda () + (change-and-cache-umask new-umask) + (umask-cache))))) + (let-umask changed-umask thunk))) + +(define (align-umask!) + (let ((thread-umask (umask))) + (if (not (= thread-umask (umask-cache))) + (change-and-cache-umask thread-umask)))) + +(define (set-umask new-umask) + (with-lock umask-lock + (lambda () + (change-and-cache-umask new-umask) + (thread-set-umask! (umask-cache))))) + +(define umask-resource (make-resource align-umask! umask-lock)) + +(define umask-reinitializer + (make-reinitializer (lambda () (initialize-umask)))) + + +(initialize-umask) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ensure S48 is aligned too + +(set-with-fs-context-aligned*! + (lambda (thunk) + (with-resources-aligned + (list cwd-resource umask-resource euid-resource egid-resource) + thunk))) + +;; Sugar: + +(define-simple-syntax (with-cwd dir . body) + (with-cwd* dir (lambda () . body))) + +(define-simple-syntax (with-umask mask . body) + (with-umask* mask (lambda () . body))) + +(define-simple-syntax (with-user-effective-uid uid . body) + (with-user-effective-uid* uid (lambda () . body))) + +(define-simple-syntax (with-user-effective-gid gid . body) + (with-user-effective-gid* gid (lambda () . body))) + +(define-syntax make-Xid-resource + (syntax-rules () + ((make-Xid-resource + process-user-effective-Xid set-process-user-effective-Xid + process-set-Xid set-Xid + align-eXid! eXid-resource + user-effective-Xid set-user-effective-Xid with-user-effective-Xid*) + (begin + (define *eXid-cache* 'uninitialized) + (define eXid-lock (make-lock)) + + (define (initialize-eXid) + (set! *eXid-cache* (process-user-effective-Xid)) + (set! $eXid + (make-preserved-thread-fluid + (eXid-cache)))) + + (define (eXid-cache) + *eXid-cache*) + +;; Actually do the syscall and update the cache +;; assumes the resource lock obtained + (define (change-and-cache-eXid new-eXid) + (set-process-user-effective-Xid new-eXid) + (set! *eXid-cache* (process-user-effective-Xid))) + +;; The thread-specific eXid: A thread fluid + + (define $eXid 'empty-eXid-value) + + (define (user-effective-Xid) (thread-fluid $eXid)) + (define (thread-set-eXid! new-eXid) (set-thread-fluid! $eXid new-eXid)) + (define (let-eXid new-eXid thunk) + (let-thread-fluid $eXid new-eXid thunk)) + +;; set-Xid will affect the effective X id + (define (set-Xid Xid) + (with-lock eXid-lock + (lambda () + (process-set-Xid Xid) + (set! *eXid-cache* (process-user-effective-Xid)) + (thread-set-eXid! *eXid-cache*)))) + + (define (with-user-effective-Xid* new-eXid thunk) + (let ((changed-eXid + (with-lock eXid-lock + (lambda () + (change-and-cache-eXid new-eXid) + (eXid-cache))))) + (let-eXid changed-eXid thunk))) + + (define (align-eXid!) + (let ((thread-eXid (user-effective-Xid))) + (if (not (= thread-eXid (eXid-cache))) + (change-and-cache-eXid thread-eXid)))) + + (define (set-user-effective-Xid new-eXid) + (with-lock eXid-lock + (lambda () + (change-and-cache-eXid new-eXid) + (thread-set-eXid! (eXid-cache))))) + + (define eXid-resource (make-resource align-eXid! eXid-lock)) + + (define eXid-reinitializer + (make-reinitializer (lambda () (initialize-eXid)))) + + (initialize-eXid) + )))) + +(make-Xid-resource + process-user-effective-uid set-process-user-effective-uid + process-set-uid set-uid + align-euid! euid-resource + user-effective-uid set-user-effective-uid with-user-effective-uid*) + +(make-Xid-resource + process-user-effective-gid set-process-user-effective-gid + process-set-gid set-gid + align-egid! egid-resource + user-effective-gid set-user-effective-gid with-user-effective-gid*) diff --git a/scsh/process.scm b/scsh/process.scm new file mode 100644 index 0000000..9aa5f71 --- /dev/null +++ b/scsh/process.scm @@ -0,0 +1,331 @@ + +;;; Process +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; we can't algin env here, because exec-path/env calls +;; %%exec/errno directly F*&% *P +(import-os-error-syscall %%exec (prog argv env) "scheme_exec") + +(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))) + + +(import-os-error-syscall exit/errno ; errno -- misnomer. + (status) "scsh_exit") + +(import-os-error-syscall %exit/errno ; errno -- misnomer + (status) "scsh__exit") + +(define (%exit . maybe-status) + (%exit/errno (:optional maybe-status 0)) + (error "Yikes! %exit returned.")) + +(import-os-error-syscall %%fork () "scsh_fork") + +;;; EXEC support +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Assumes a low-level %exec procedure: +;;; (%exec prog arglist env) +;;; ENV is either #t, meaning the current environment, or a string->string +;;; alist. +;;; %EXEC stringifies PROG and the elements of ARGLIST. + +(define (exec-path-search prog path-list) + (cond + ((not (file-name-absolute? prog)) + (let loop ((path-list path-list)) + (if (not (null? path-list)) + (let* ((dir (car path-list)) + (fname (string-append dir "/" prog))) + (if (file-executable? fname) + fname + (loop (cdr path-list))))))) + ((file-executable? prog) + prog) + (else #f))) + +(define (exec/env prog env . arglist) + (flush-all-ports) + (with-resources-aligned + (list environ-resource cwd-resource umask-resource euid-resource egid-resource) + (lambda () + (%exec prog (cons prog arglist) env)))) + +;;; Some globals: +(define exec-path-list) + +(define (init-exec-path-list quietly?) + (set! exec-path-list + (make-preserved-thread-fluid + (cond ((getenv "PATH") => split-colon-list) + (else (if (not quietly?) + (warn "Starting up with no path ($PATH).")) + '()))))) + +;;; We keep SPLIT-COLON-LIST defined internally so the top-level +;;; startup code (INIT-SCSH) can use it to split up $PATH without +;;; requiring the field-splitter or regexp code. + +(define (split-colon-list clist) + (let ((len (string-length clist))) + (if (= 0 len) '() ; Special case "" -> (). + + ;; Main loop. + (let split ((i 0)) + (cond ((string-index clist #\: i) => + (lambda (colon) + (cons (substring clist i colon) + (split (+ colon 1))))) + (else (list (substring clist i len)))))))) + +;(define (exec-path/env prog env . arglist) +; (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) => +; (lambda (binary) +; (apply exec/env binary env arglist))) +; (else (error "No executable found." prog arglist)))) + +;;; This procedure is bummed by tying in directly to %%exec/errno +;;; and pulling some of %exec's code out of the inner loop so that +;;; the inner loop will be fast. Folks don't like waiting... + +(define (exec-path/env prog env . arglist) + (flush-all-ports) + (with-resources-aligned + (list environ-resource cwd-resource umask-resource euid-resource egid-resource) + (lambda () + (let ((prog (stringify prog))) + (if (string-index prog #\/) + + ;; Contains a slash -- no path search. + (%exec prog (cons prog arglist) env) + + ;; Try each directory in PATH-LIST. + (let ((argv (list->vector (cons prog (map stringify arglist))))) + (for-each (lambda (dir) + (let ((binary (string-append dir "/" prog))) + (%%exec binary argv env))) + (thread-fluid exec-path-list))))) + + (error "No executable found." prog arglist)))) + +(define (exec-path prog . arglist) + (apply exec-path/env prog #t arglist)) + +(define (exec prog . arglist) + (apply exec/env prog #t arglist)) + + +;;; Assumes niladic primitive %%FORK. + +(define (fork . stuff) + (apply fork-1 #t stuff)) + +(define (%fork . stuff) + (apply fork-1 #f stuff)) + +(define (fork-1 clear-interactive? . rest) + (let-optionals rest ((maybe-thunk #f) + (dont-narrow? #f)) + (really-fork clear-interactive? + (not dont-narrow?) + maybe-thunk))) + +(define (preserve-ports thunk) + (let ((current-input (current-input-port)) + (current-output (current-output-port)) + (current-error (current-error-port))) + (lambda () + (with-current-input-port* + current-input + (lambda () + (with-current-output-port* + current-output + (lambda () + (with-current-error-port* + current-error + thunk)))))))) + +(define (really-fork clear-interactive? narrow? maybe-thunk) + (let ((proc #f) + (maybe-narrow + (if narrow? + (lambda (thunk) + ;; narrow loses the thread fluids and the dynamic environment + (narrow (preserve-ports (preserve-thread-fluids thunk)) + 'forking)) + (lambda (thunk) (thunk))))) + (maybe-narrow + (lambda () + + (if clear-interactive? + (flush-all-ports)) + + ;; There was an atomicity problem/race condition -- if a child + ;; process died after it was forked, but before the scsh fork + ;; procedure could register the child's procobj in the + ;; pid/procobj table, then when the SIGCHLD signal-handler reaped + ;; the process, there would be no procobj for it. We now lock + ;; out interrupts across the %%FORK and NEW-CHILD-PROC + ;; operations. + + (((structure-ref interrupts with-interrupts-inhibited) + (lambda () + ;; with-env-aligned is not neccessary here but it will + ;; create the environ object in the parent process which + ;; could reuse it on further forks + (let ((pid (with-resources-aligned + (list environ-resource) + %%fork))) + (if (zero? pid) + ;; Child + (lambda () ; Do all this outside the WITH-INTERRUPTS. + ;; There is no session if parent was started in batch-mode + (if (and (session-started?) clear-interactive?) + (set-batch-mode?! #t)) ; Children are non-interactive. + (if maybe-thunk + (call-and-exit maybe-thunk))) + ;; Parent + (begin + (set! proc (new-child-proc pid)) + (lambda () + (values)))))))))) + proc)) + +(define (exit . maybe-status) + (let ((status (:optional maybe-status 0))) + (if (not (integer? status)) + (error "non-integer argument to exit")) + (call-exit-hooks-and-narrow + (lambda () + (exit/errno status) + (display "The evil undead walk the earth." 2) + (if #t (error "(exit) returned.")))))) + + +(define (call-and-exit thunk) + (call-terminally + (lambda () + (dynamic-wind + values + thunk + (lambda () (exit 0)))))) + +;;; Like FORK, but the parent and child communicate via a pipe connecting +;;; the parent's stdin to the child's stdout. This function side-effects +;;; the parent by changing his stdin. + +(define (fork/pipe . stuff) + (really-fork/pipe fork stuff)) + +(define (%fork/pipe . stuff) + (really-fork/pipe %fork stuff)) + +;;; Common code for FORK/PIPE and %FORK/PIPE. +(define (really-fork/pipe forker rest) + (let-optionals rest ((maybe-thunk #f) + (no-new-command-level? #f)) + (receive (r w) (pipe) + (let ((proc (forker #f no-new-command-level?))) + (cond (proc ; Parent + (close w) + (move->fdes r 0)) + (else ; Child + (close r) + (move->fdes w 1) + (if maybe-thunk + (call-and-exit maybe-thunk)))) + proc)))) + + +;;; FORK/PIPE with a connection list. +;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t) + +(define (%fork/pipe+ conns . stuff) + (really-fork/pipe+ %fork conns stuff)) + +(define (fork/pipe+ conns . stuff) + (really-fork/pipe+ fork conns stuff)) + +;;; Common code. +(define (really-fork/pipe+ forker conns rest) + (let-optionals rest ((maybe-thunk #f) + (no-new-command-level? #f)) + (let* ((pipes (map (lambda (conn) (call-with-values pipe cons)) + conns)) + (rev-conns (map reverse conns)) + (froms (map (lambda (conn) (reverse (cdr conn))) + rev-conns)) + (tos (map car rev-conns))) + + (let ((proc (forker #f no-new-command-level?))) + (cond (proc ; Parent + (for-each (lambda (to r/w) + (let ((w (cdr r/w)) + (r (car r/w))) + (close w) + (move->fdes r to))) + tos pipes)) + + (else ; Child + (for-each (lambda (from r/w) + (let ((r (car r/w)) + (w (cdr r/w))) + (close r) + (for-each (lambda (fd) (dup w fd)) from) + (close w))) ; Unrevealed ports win. + froms pipes) + (if maybe-thunk + (call-and-exit maybe-thunk)))) + proc)))) + +(define (tail-pipe a b) + (fork/pipe a) + (call-and-exit b)) + +(define (tail-pipe+ conns a b) + (fork/pipe+ conns a) + (call-and-exit b)) + +;;; Lay a pipeline, one process for each thunk. Last thunk is called +;;; in this process. PIPE* never returns. + +(define (pipe* . thunks) + (letrec ((lay-pipe (lambda (thunks) + (let ((thunk (car thunks)) + (thunks (cdr thunks))) + (if (pair? thunks) + (begin (fork/pipe thunk) + (lay-pipe thunks)) + (call-and-exit thunk)))))) ; Last one. + (if (pair? thunks) + (lay-pipe thunks) + (error "No thunks passed to PIPE*")))) + +;;; The classic T 2.0 primitive. +;;; This definition works for procedures running on top of Unix systems. +(define (halts? proc) #t) + +; SIGTSTP blows s48 away. ??? +(define (suspend) (signal-process 0 signal/stop)) + + +;;; 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 (process-sleep secs) (process-sleep-until (+ secs (time)))) + +(define (process-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))))) + +(import-os-error-syscall %sleep-until (secs) "sleep_until") \ No newline at end of file diff --git a/scsh/procobj.scm b/scsh/procobj.scm index f2c7723..4acd6e6 100644 --- a/scsh/procobj.scm +++ b/scsh/procobj.scm @@ -331,7 +331,11 @@ (else (error "mismatch in really-wait" return_pid pid))))) +;;; Posix waitpid(2) call. +(import-os-error-syscall %wait-pid/list (pid options) "wait_pid") +(define (%wait-pid pid options) + (apply values (%wait-pid/list pid options))) ;;; All you have to do, if pid was reaped ;;; proc_obj is maybe no longer alive diff --git a/scsh/resource.scm b/scsh/resource.scm new file mode 100644 index 0000000..2b9e2d2 --- /dev/null +++ b/scsh/resource.scm @@ -0,0 +1,19 @@ +(define-record-type resource :resource + (make-resource align! lock) + resource? + (align! resource-align!) + (lock resource-lock)) + +(define (with-resources-aligned resources thunk) + (let ((locks (map resource-lock resources))) + (apply obtain-all-or-none locks) + (for-each + (lambda (align!) (align!)) + (map resource-align! resources)) + (let ((val (with-handler + (lambda (cond more) + (for-each release-lock locks) + (more)) + thunk))) + (for-each release-lock locks) + val))) \ No newline at end of file diff --git a/scsh/rw.scm b/scsh/rw.scm index f184ea5..f16cf20 100644 --- a/scsh/rw.scm +++ b/scsh/rw.scm @@ -3,12 +3,6 @@ ;;; Note: read ops should check to see if their string args are mutable. -(define (bogus-substring-spec? s start end) - (or (< start 0) - (< (string-length s) end) - (< end start))) - - ;;; Best-effort/forward-progress reading ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/scsh/scsh-interfaces.scm b/scsh/scsh-interfaces.scm index a208b96..5bb711f 100644 --- a/scsh/scsh-interfaces.scm +++ b/scsh/scsh-interfaces.scm @@ -101,13 +101,132 @@ :values)) (with-errno-handler :syntax))) +(define-interface scsh-continuations-interface + (export continuation-capture + continuation-graft + continuation-return + call-terminally)) +(define-interface scsh-import-os-error-syscalls-interface + (export (import-os-error-syscall :syntax) + errno-msg)) + +(define-interface scsh-file-syscalls-interface + (export %set-cloexec + %fcntl-read %fcntl-write + %open %close-fdes %dup %dup2 %pipe-fdes + %fd-seek + %char-ready-fdes? + %truncate-file %truncate-fdes + %create-symlink %read-symlink + %delete-file %rename-file + %%create-directory %delete-directory + %create-hard-link + %create-fifo + %set-file-mode %set-fdes-mode + %set-file-uid&gid %set-fdes-uid&gid + %utime %utime-now + %stat-file %stat-fdes + %sync-file %sync-file-system + %open-dir)) (define buffered-io-flags-interface (export ((bufpol/block bufpol/line bufpol/none) :number))) +(define-interface scsh-newports-interface + (export call/fdes + sleazy-call/fdes + fdes->inport + set-port-buffering + fdes->outport + evict-ports + fdport? + %move-fdport + close-fdes + make-input-fdport + make-output-fdport + open-fdes + fdport-data:fd + close + fdport-data + select + fdport-data:channel + seek/set + open-file + pipe + with-current-output-port* + close-after + set-current-input-port! + set-current-output-port! + set-current-error-port! + with-current-error-port + with-current-output-port + with-current-input-port + flush-all-ports + with-current-error-port* + with-current-input-port* + close-after + with-current-error-port + with-current-output-port + flush-all-ports + error-output-port + close + release-port-handle + flush-all-ports-no-threads + select! + set-error-output-port! + with-error-output-port* + release-port-handle + seek/end + port-revealed + select-port-channels + with-error-output-port + init-fdports! + seek/delta + tell + seek + init-fdports! + port->fdes select-ports + + char-ready? + read-char + display write newline write-char + force-output + open-input-file + with-output-to-file with-input-from-file + call-with-input-file call-with-output-file + open-output-file)) + +(define-interface scsh-fcntl-interface + (export fdes-flags set-fdes-flags + fdes-status set-fdes-status)) + +(define-interface scsh-read/write-interface + (export read-string/partial + read-string!/partial + read-string read-string! + write-string + write-string/partial)) + +(define-interface scsh-flock-interface + (export lock-region? + lock-region:exclusive? + lock-region:whence + lock-region:start + lock-region:len + lock-region:pid ; Deprecated proc. + lock-region:proc + make-lock-region + + lock-region + lock-region/no-block + get-lock-region + unlock-region + with-region-lock* + (with-region-lock :syntax))) + (define-interface scsh-io-interface (compound-interface buffered-io-flags-interface (export close @@ -126,7 +245,6 @@ set-fdes-status init-fdports! ;added by JMG - port->channel ;overwrites channel-i/o force-output set-port-buffering @@ -142,8 +260,6 @@ flush-all-ports flush-all-ports-no-threads - y-or-n? - *y-or-n-eof-count* ;; R4RS I/O procedures that scsh provides. write char-ready? @@ -301,40 +417,24 @@ file-exists? sync-file - sync-file-system + sync-file-system)) - open-directory-stream - close-directory-stream - read-directory-stream - - directory-files - glob +(define-interface scsh-globbing-interface + (export glob glob-quote - file-match + maybe-directory-files)) - create-temp-file +(define-interface scsh-file-matching-interface + (export file-match)) + +(define-interface scsh-temp-files-interface + (export create-temp-file temp-file-iterate temp-file-channel *temp-file-template*)) - -(define-interface scsh-process-interface - (export exec - exec-path - exec/env - exec-path/env - %exec - exec-path-search - - exit - %exit - - suspend - - fork - %fork - - proc? +(define-interface scsh-process-objects-interface + (export proc? proc:pid pid->proc @@ -352,12 +452,45 @@ wait/poll wait/stopped-children + new-child-proc)) + +(define-interface scsh-processes-interface + (export exec + exec-path + exec/env + exec-path/env + %exec + exec-path-search + + exit + %exit + + suspend + + fork + %fork + process-sleep process-sleep-until call-terminally - halts?)) + halts? + fork/pipe + %fork/pipe + fork/pipe+ + %fork/pipe+ + tail-pipe + tail-pipe+ + + init-exec-path-list)) ; ### should be internal + +(define-interface scsh-fdports-interface + (export move->fdes + dup + dup->fdes dup->inport dup->outport + shell-open + open/create+trunc)) (define-interface scsh-process-state-interface (export with-resources-aligned @@ -399,13 +532,13 @@ euid-resource egid-resource - system-name process-times cpu-ticks/sec)) (define-interface scsh-user/group-db-interface - (export user-info + (export name->user-info + user-info user-info:name user-info:uid user-info:gid @@ -415,6 +548,12 @@ ->uid ->username + %homedir ; #### for scsh.scm + + init-home-directory + home-directory + home-dir home-file + group-info group-info:name group-info:gid @@ -423,15 +562,14 @@ ->gid ->groupname)) - (define-interface scsh-command-line-interface - (export command-line-arguments + (export set-command-line-args! + command-line-arguments command-line arg arg* argv)) - (define-interface scsh-signals-interface (export signal-process signal-process-group @@ -441,12 +579,12 @@ )) -(define-interface scsh-environment-interface - (export install-env - setenv +(define-interface scsh-environments-interface + (export setenv getenv env->alist alist->env + alist->env-vec ; #### for %EXEC alist-delete alist-update alist-compress @@ -458,12 +596,6 @@ add-after environ-resource)) - -(define-interface scsh-home-interface - (export home-directory - exec-path-list)) - - ;;; Kill me? (define-interface scsh-regexp-interface (export string-match @@ -480,11 +612,6 @@ regexp-quote)) -(define-interface scsh-string-interface - (export substitute-env-vars - ;string-index string-index-right ; Now in string-lib - )) - (define-interface scsh-file-names-interface (export file-name-as-directory file-name-directory? @@ -493,20 +620,24 @@ file-name-absolute? file-name-directory file-name-nondirectory + + ensure-file-name-is-nondirectory + ensure-file-name-is-directory + split-file-name path-list->file-name file-name-extension file-name-sans-extension replace-extension parse-file-name - expand-file-name - simplify-file-name - resolve-tilde-file-name - resolve-file-name - absolute-file-name - home-dir - home-file)) + simplify-file-name)) +(define scsh-file-names-system-interface + (export resolve-tilde-file-name + resolve-file-name + expand-file-name + absolute-file-name + substitute-env-vars)) (define-interface scsh-time-interface (export make-date @@ -582,12 +713,6 @@ (run/sexp :syntax) (run/sexps :syntax) - fork/pipe - %fork/pipe - fork/pipe+ - %fork/pipe+ - tail-pipe - tail-pipe+ run/collecting* run/port+proc* run/port* @@ -595,12 +720,18 @@ run/string* run/sexp* run/sexps* - run/strings* + run/strings*)) +(define-interface scsh-collect-ports-interface + (export port->string + port->list + port->sexp-list + port->string-list + port-fold + reduce-port make-char-port-filter make-string-port-filter)) - (define-interface scsh-version-interface (export scsh-major-version scsh-minor-version @@ -631,14 +762,27 @@ skip-char-set)) (define-interface scsh-utilities-interface - (export mapv mapv! vector-every? copy-vector initialize-vector vector-append + (export (define-simple-syntax :syntax) + mapv mapv! vector-every? copy-vector initialize-vector vector-append vfold vfold-right check-arg deprecated-proc real->exact-integer make-reinitializer run-as-long-as - obtain-all-or-none)) + obtain-all-or-none with-lock + stringify + bogus-substring-spec?)) + +(define-interface scsh-resources-interface + (export with-resources-aligned + make-resource)) + +(define-interface scsh-directories-interface + (export open-directory-stream + close-directory-stream + read-directory-stream + directory-files)) (define-interface weak-tables-interface (export make-weak-table weak-table-set! weak-table-ref weak-table-walk @@ -1044,6 +1188,19 @@ control-tty-file-name ))) +(define-interface scsh-stdio-interface + (export stdports->stdio + stdio->stdports + with-stdio-ports* + (with-stdio-ports :syntax))) + +(define-interface scsh-ptys-interface + (export fork-pty-session + open-pty + pty-name->tty-name + tty-name->pty-name + make-pty-generator)) + (define-interface signal-handler-interface (export signal->interrupt interrupt-set diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 7465e20..8cec0f0 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -1,9 +1,6 @@ ;;; The packages that scsh uses/defines. ;;; Copyright (c) 1994 by Olin Shivers. -;;; Note: field-reader package (fr.scm) and here docs use READ-LINE. -;;; It is defined in rdelim.scm. - ;;; You link up a scsh package by defining a package named OS-DEPENDENT ;;; that satisfies the interfaces for packages ;;; buffered-io-flags @@ -22,10 +19,6 @@ ;;; -Olin -;;; The LET-OPT package for optional argument parsing & defaulting -;;; is found in the let-opt.scm file. - - (define-structure error-package (export error warn) (open signals) ; (optimize auto-integrate) @@ -40,6 +33,14 @@ ; (optimize auto-integrate) ) +(define-structure scsh-resources scsh-resources-interface + (open scheme + define-record-types + handle + locks + scsh-utilities) + (files resource)) + (define-structure weak-tables weak-tables-interface (open scheme weak @@ -74,7 +75,7 @@ (open receiving ; receive error-package names ; generated? by JMG - scsh-utilities ; check-arg + (subset scsh-utilities (check-arg)) scheme ) (files syntax-helpers) @@ -98,6 +99,24 @@ ; (optimize auto-integrate) ) +(define-structure scsh-continuations scsh-continuations-interface + (open scheme + escapes) + (files continuation)) + +(define-structure scsh-import-os-error-syscalls scsh-import-os-error-syscalls-interface + (open scheme + handle conditions + external-calls + (subset os-dependent (errno/intr)) + (subset scsh-errors (errno-error)) + scsh-continuations) + (files import-os-error-syscall)) + +(define-structure scsh-file-syscalls scsh-file-syscalls-interface + (open scheme + scsh-import-os-error-syscalls) + (files file-syscalls)) (define-structure scsh-version scsh-version-interface (open scheme) @@ -115,6 +134,421 @@ bitwise) (files endian)) +(define-structure scsh-environments scsh-environments-interface + (open scheme + locks thread-fluids + (subset primitives (add-finalizer!)) + defrec-package records + (subset signals (error)) + (subset srfi-1 (fold filter)) + (subset srfi-13 (string-index string-join)) + (subset scsh-utilities + (with-lock make-reinitializer define-simple-syntax)) + shared-bindings + scsh-import-os-error-syscalls + scsh-resources) + (files environment)) + +(define-structure scsh-file-names scsh-file-names-interface + (open scheme + receiving + let-opt + signals + (subset srfi-1 (reverse!)) + (subset srfi-13 (string-index string-index-right))) + (files fname)) + +(define-structure scsh-directories scsh-directories-interface + (open scheme + structure-refs + (subset primitives (add-finalizer!)) + (subset srfi-1 (filter)) + (subset srfi-13 (string<=)) + (subset scsh-utilities (check-arg)) + defrec-package records + let-opt + (subset scsh-file-syscalls (%open-dir)) + scsh-import-os-error-syscalls + scsh-file-names + scsh-resources + scsh-process-state) + (access sort) + (files directory)) + +(define-structure scsh-user/group-db scsh-user/group-db-interface + (open scheme + defrec-package + receiving + handle (subset signals (error)) + scsh-import-os-error-syscalls + scsh-file-names + scsh-environments) + (files user-group)) + +(define-structure scsh-process-state scsh-process-state-interface + (open scheme + receiving + let-opt + locks thread-fluids + (subset channels (set-with-fs-context-aligned*!)) + (subset signals (error)) + (subset scsh-utilities (with-lock make-reinitializer define-simple-syntax)) + scsh-resources + scsh-file-names + scsh-user/group-db + scsh-import-os-error-syscalls) + (files process-state)) + +(define-structure scsh-time scsh-time-interface + (open scheme + receiving + let-opt + formats + bitwise + signals + external-calls + defrec-package + (subset scsh-utilities (check-arg real->exact-integer)) + scsh-import-os-error-syscalls) + (files time + (machine time_dep))) + +(define-structure scsh-signal-handlers signal-handler-interface + (open scheme + external-calls + signals + enumerated + threads + interrupts low-interrupt + structure-refs + (subset scsh-utilities (define-simple-syntax run-as-long-as)) + (subset os-dependent (signals-ignored-by-default signal/alrm))) + (access threads-internal sigevents) + (files sighandlers)) + +(define-structure scsh-newports scsh-newports-interface + (open (modify scheme (hide call-with-input-file + call-with-output-file + with-input-from-file + with-output-to-file + open-input-file + open-output-file)) + structure-refs + defrec-package define-record-types + bitwise + ascii + tables weak-tables + enumerated + byte-vectors + fluids + placeholders + receiving + let-opt + i/o i/o-internal channels channel-i/o low-channels ports + (subset architecture (channel-status-option)) + (subset primitives (add-pending-channel copy-bytes!)) + extended-ports + scsh-utilities os-dependent buffered-io-flags + signals + threads + (subset srfi-1 (any filter)) + scsh-file-syscalls + scsh-resources + scsh-process-state) + (access scheme + formats + i/o + threads-internal + interrupts) + (files newports)) + +(define-structure scsh-file scsh-file-interface + (open scheme + bitwise + defrec-package + let-opt + i/o + (subset scsh-utilities (define-simple-syntax deprecated-proc real->exact-integer)) + os-dependent + scsh-errors + scsh-file-syscalls + scsh-file-names + scsh-process-state + delimited-readers + scsh-newports) + (files fileinfo + file + filesys)) + +(define-structure scsh-temp-files scsh-temp-files-interface + (open scheme + receiving + let-opt + bitwise + formats + os-dependent + fluids + (subset scsh-utilities (make-reinitializer)) + scsh-errors + scsh-environments + scsh-process-state + scsh-file + scsh-newports) + (files temp-file)) + +(define-structure scsh-globbing scsh-globbing-interface + (open scheme + ascii + receiving + (subset srfi-1 (filter fold)) + srfi-14 + re-level-0 + scsh-errors + scsh-file-names + scsh-file + scsh-directories) + (files glob)) + +(define-structure scsh-file-matching scsh-file-matching-interface + (open scheme + re-level-0 + signals handle conditions + (subset srfi-1 (filter)) + (subset srfi-13 (string-index-right)) + scsh-file-names + scsh-globbing) + (files filemtch)) + +(define-structure scsh-fcntl scsh-fcntl-interface + (open scheme + scsh-file-syscalls + scsh-newports + (subset os-dependent (export fcntl/get-fdes-flags + fcntl/set-fdes-flags + fcntl/get-status-flags + fcntl/set-status-flags))) + (files fcntl)) + +(define-structure scsh-read/write scsh-read/write-interface + (open scheme + bitwise + (subset primitives (copy-bytes!)) + let-opt + signals + scsh-newports + scsh-fcntl + buffered-io-flags + (subset scsh-utilities (bogus-substring-spec?)) + (subset i/o (read-block write-block)) + (subset i/o-internal (open-input-port?)) + (subset os-dependent (open/non-blocking))) + (files rw)) + +(define-structure scsh-process-objects scsh-process-objects-interface + (open scheme + receiving + threads + locks placeholders + signals + bitwise + tables weak-tables + weak + let-opt + structure-refs + defrec-package + (subset primitives (add-finalizer!)) + (subset srfi-1 (delete filter)) + (subset scsh-utilities (make-reinitializer + with-lock run-as-long-as)) + low-interrupt + (subset os-dependent (errno/child)) + scsh-import-os-error-syscalls + scsh-file-names + scsh-errors) + (access sigevents + threads-internal) + (files procobj + (machine waitcodes))) + +(define-structure scsh-fdports scsh-fdports-interface + (open scheme + signals + bitwise + (subset scsh-utilities (check-arg stringify)) + os-dependent + scsh-file-syscalls + scsh-fcntl + scsh-newports) + (files fdports)) + +(define-structure scsh-signals scsh-signals-interface + (open scheme + signals + structure-refs + scsh-import-os-error-syscalls + scsh-process-objects) + (access sigevents) + (files signal)) + +(define-structure scsh-processes scsh-processes-interface + (open scheme + receiving + signals + i/o + let-opt + threads thread-fluids + structure-refs + (subset srfi-13 (string-index)) + (subset command-levels (session-started? set-batch-mode?!)) + (subset scsh-utilities (mapv! stringify)) + scsh-import-os-error-syscalls + (subset scsh-environments (alist->env-vec)) + scsh-continuations + scsh-resources + scsh-environments + scsh-process-state + scsh-process-objects + scsh-file-names + scsh-newports + scsh-file + scsh-fdports + exit-hooks + scsh-signals + scsh-time + (subset os-dependent (signal/stop))) + (access interrupts) + (files process)) + +(define-structure scsh-ttys tty-interface + (open scheme + ascii + i/o + signals + bitwise + let-opt + defrec-package + tty-flags scsh-internal-tty-flags + scsh-import-os-error-syscalls + scsh-newports + (subset os-dependent (open/read+write open/access-mask open/read)) + scsh-process-objects) + (files tty)) + +(define-structure scsh-stdio scsh-stdio-interface + (open scheme + (subset i/o (current-error-port)) + (subset scsh-utilities (define-simple-syntax)) + scsh-fdports + scsh-newports) + (files stdio)) + +(define-structure scsh-ptys scsh-ptys-interface + (open scheme + receiving + scsh-processes + scsh-fdports + scsh-errors + scsh-newports + scsh-stdio + scsh-ttys + scsh-process-state + (subset os-dependent (open/read+write))) + (files pty)) + +(define-structure scsh-flock scsh-flock-interface + (open scheme + signals + let-opt + threads + defrec-package + scsh-import-os-error-syscalls + os-dependent + (subset scsh-utilities (check-arg deprecated-proc)) + scsh-errors + (subset scsh-newports (seek/set)) + scsh-process-objects) + (files flock)) + +(define-structure scsh-crypt crypt-interface + (open scheme + signals + re-level-0 rx-syntax + scsh-import-os-error-syscalls) + (files crypt)) + +(define-structure scsh-system (compound-interface uname-interface + (export system-name) ; #### + ) + (open scheme + defrec-package + shared-bindings + scsh-import-os-error-syscalls) + (files system)) + +(define-structure scsh-networking (compound-interface sockets-network-interface + scsh-sockets-interface) + (open scheme + structure-refs + receiving + let-opt + handle signals + external-calls shared-bindings + defrec-package + channel-i/o ports + (subset scsh-utilities (bogus-substring-spec?)) + scsh-import-os-error-syscalls + scsh-errors + scsh-fdports + scsh-newports + scsh-fcntl + os-dependent) + (access interrupts) + (files network)) + +(define-structure scsh-file-names-system scsh-file-names-system-interface + (open scheme + signals + let-opt + (subset srfi-1 (reverse!)) + (subset srfi-13 (string-index)) + scsh-file-names + scsh-environments + scsh-user/group-db + scsh-process-state) + (files fname-system)) + +(define-structure scsh-collect-ports scsh-collect-ports-interface + (open scheme + let-opt + (subset scsh-utilities (deprecated-proc)) + (subset srfi-1 (reverse!)) + scsh-read/write + delimited-readers + string-collectors) + (files port-collect)) + +(define-structure scsh-high-level-processes scsh-high-level-process-interface + (for-syntax (open scsh-syntax-helpers scheme)) + (open scheme + signals + receiving + let-opt + (subset scsh-utilities (define-simple-syntax)) + (subset srfi-1 (fold)) + scsh-temp-files + scsh-processes scsh-process-objects + scsh-stdio + scsh-newports + scsh-fdports + scsh-collect-ports) + (files syntax + process-high-level)) + +(define-structure scsh-command-line scsh-command-line-interface + (open scheme + signals) + (files command-line)) + ;;; The scsh-level-0 package is for implementation convenience. ;;; The scsh startup and top-level modules need access to scsh ;;; procedures, but they export procedures that are themselves @@ -133,14 +567,19 @@ scsh-errors-interface scsh-io-interface scsh-file-interface - scsh-process-interface + scsh-fcntl-interface + scsh-read/write-interface + scsh-globbing-interface + scsh-file-matching-interface + scsh-temp-files-interface + scsh-directories-interface scsh-process-state-interface + scsh-process-objects-interface + scsh-processes-interface scsh-user/group-db-interface scsh-command-line-interface scsh-signals-interface - scsh-environment-interface - scsh-home-interface - scsh-string-interface + scsh-environments-interface scsh-file-names-interface scsh-misc-interface scsh-high-level-process-interface @@ -151,6 +590,8 @@ scsh-version-interface (interface-of srfi-14) ;; export this here for (export ->char-set) ;; this kludge + (export system-name) ; #### has nowhere else to go for now + scsh-file-names-system-interface signal-handler-interface ;; This stuff would probably be better off kept ;; in separate modules, but we'll toss it in for now. @@ -161,20 +602,16 @@ uname-interface )) (scsh-level-0-internals (export set-command-line-args! - init-scsh-hindbrain - initialize-cwd - init-scsh-vars)) + init-home-directory + init-exec-path-list)) ; (scsh-regexp-package scsh-regexp-interface) ) (for-syntax (open scsh-syntax-helpers scheme)) (access rts-sigevents sigevents threads) (open enumerated defenum-package - external-calls ;JMG new FFI - structure-refs receiving defrec-package - define-record-types formats string-collectors delimited-readers @@ -188,93 +625,60 @@ bigbit bitwise signals - conditions - (subset srfi-1 (filter reverse! fold delete any)) - scsh-utilities - handle - fluids thread-fluids - weak-tables srfi-14 -; scsh-regexp-package -; scsh-regexp-internals + scsh-version tty-flags - scsh-internal-tty-flags ; Not exported - syslog - - let-opt ; optional-arg parsing & defaulting + scsh-continuations + scsh-import-os-error-syscalls + scsh-file-syscalls + scsh-resources + scsh-environments + scsh-file-names + scsh-directories + scsh-user/group-db + scsh-process-state + scsh-time + scsh-signal-handlers + scsh-newports + scsh-file + scsh-read/write + scsh-fcntl + scsh-temp-files + scsh-globbing + scsh-file-matching + scsh-process-objects + scsh-processes + scsh-fdports + scsh-signals + scsh-ttys + scsh-stdio + scsh-ptys + scsh-flock + scsh-crypt + scsh-system + scsh-networking + scsh-file-names-system + scsh-high-level-processes + scsh-collect-ports + scsh-command-line - architecture ; Was this by JMG ?? + syslog re-level-0 rx-syntax srfi-13 - thread-fluids ; For exec-path-list - loopholes ; For my bogus CALL-TERMINALLY implementation. - - (modify scheme (hide call-with-input-file - call-with-output-file - with-input-from-file - with-output-to-file - open-input-file - open-output-file)) + (subset scheme (define + input-port? output-port?)) - low-interrupt ; for sighandler and procobj - ;; all these seem to be for scsh-0.6 JMG - i/o - i/o-internal - channels channel-i/o - low-channels - byte-vectors - threads locks placeholders - primitives - escapes - command-levels - features - general-tables - simple-syntax - exit-hooks + (subset i/o (current-error-port)) scsh-errors - scsh-endian) - (for-syntax (open scsh-syntax-helpers scheme)) - (access interrupts - sort - command-processor - escapes - i/o ; S48's force-output - exceptions ; signal-exception - formats - threads-internal - records ; I don't think this is necessary. !!! - scheme) ; For accessing the normal I/O operators. - (files syntax - syscalls - fname - rw - newports - fdports - procobj ; New in release 0.4. - (machine waitcodes) ; OS dependent code. - filesys - fileinfo - glob - filemtch - time ; New in release 0.2. - (machine time_dep) - network ; New in release 0.3. - flock ; New in release 0.4. - tty ; New in release 0.4. - pty ; New in release 0.4. - sighandlers ; New in release 0.5. - scsh -; re - ) -; (optimize auto-integrate) + scsh-endian) (begin ;; work around for SRFI 14 naming fuckage (define ->char-set x->char-set)) @@ -305,7 +709,9 @@ make-scsh-starter scsh-stand-alone-resumer) (open scsh-level-0-internals ; init-scsh-* set-command-line-args! - scsh-level-0 ; error-output-port command-line-arguments + (subset scsh-level-0 (init-fdports! + error-output-port current-error-port + command-line command-line-arguments)) scsh-top-package ; parse-switches-and-execute handle ; with-handler command-levels ; user-context @@ -358,9 +764,34 @@ packages receiving scsh-version - scsh-level-0 ; with-current-input-port error-output-port - ; with-current-output-port exit - scsh-level-0-internals ; set-command-line-args! init-scsh-vars + (subset scsh-level-0 (error-output-port + with-current-input-port with-current-output-port + exit + fdes->inport + release-port-handle + getenv + user-uid + user-info + user-info:home-dir + init-home-directory + init-exec-path-list + with-autoreaping + with-scsh-sighandlers + command-line + flush-all-ports-no-threads + file-name-absolute? + file-name-directory + file-name-directory? + absolute-file-name + directory-files + file-directory? + resolve-file-name + substitute-env-vars + skip-char-set + char->ascii + ascii->char)) + + (subset scsh-level-0-internals (set-command-line-args! init-scsh-vars)) threads (subset srfi-1 (any)) (subset srfi-14 (char-set diff --git a/scsh/scsh.scm b/scsh/scsh.scm deleted file mode 100644 index dc72cd1..0000000 --- a/scsh/scsh.scm +++ /dev/null @@ -1,1197 +0,0 @@ -;;; A Scheme shell. -;;; Copyright (c) 1992 by Olin Shivers. -;;; Copyright (c) 1994 by Brian D. Carlstrom. - -;;; Call THUNK, then die. -;;; A clever definition in a clever implementation allows the caller's stack -;;; and dynamic env to be gc'd away, since this procedure never returns. - -(define (call-terminally thunk) - (with-continuation - null-continuation - (lambda () - (dynamic-wind - (lambda () (values)) - thunk - (lambda () (exit 0)))))) - -;; from shift-reset.scm: -(define null-continuation #f) - -;;; Like FORK, but the parent and child communicate via a pipe connecting -;;; the parent's stdin to the child's stdout. This function side-effects -;;; the parent by changing his stdin. - -(define (fork/pipe . stuff) - (really-fork/pipe fork stuff)) - -(define (%fork/pipe . stuff) - (really-fork/pipe %fork stuff)) - -;;; Common code for FORK/PIPE and %FORK/PIPE. -(define (really-fork/pipe forker rest) - (let-optionals rest ((maybe-thunk #f) - (no-new-command-level? #f)) - (receive (r w) (pipe) - (let ((proc (forker #f no-new-command-level?))) - (cond (proc ; Parent - (close w) - (move->fdes r 0)) - (else ; Child - (close r) - (move->fdes w 1) - (if maybe-thunk - (call-terminally maybe-thunk)))) - proc)))) - - -;;; FORK/PIPE with a connection list. -;;; (FORK/PIPE . m-t) = (apply fork/pipe+ '((1 0)) m-t) - -(define (%fork/pipe+ conns . stuff) - (really-fork/pipe+ %fork conns stuff)) - -(define (fork/pipe+ conns . stuff) - (really-fork/pipe+ fork conns stuff)) - -;;; Common code. -(define (really-fork/pipe+ forker conns rest) - (let-optionals rest ((maybe-thunk #f) - (no-new-command-level? #f)) - (let* ((pipes (map (lambda (conn) (call-with-values pipe cons)) - conns)) - (rev-conns (map reverse conns)) - (froms (map (lambda (conn) (reverse (cdr conn))) - rev-conns)) - (tos (map car rev-conns))) - - (let ((proc (forker #f no-new-command-level?))) - (cond (proc ; Parent - (for-each (lambda (to r/w) - (let ((w (cdr r/w)) - (r (car r/w))) - (close w) - (move->fdes r to))) - tos pipes)) - - (else ; Child - (for-each (lambda (from r/w) - (let ((r (car r/w)) - (w (cdr r/w))) - (close r) - (for-each (lambda (fd) (dup w fd)) from) - (close w))) ; Unrevealed ports win. - froms pipes) - (if maybe-thunk - (call-terminally maybe-thunk)))) - proc)))) - -(define (tail-pipe a b) - (fork/pipe a) - (call-terminally b)) - -(define (tail-pipe+ conns a b) - (fork/pipe+ conns a) - (call-terminally b)) - -;;; Lay a pipeline, one process for each thunk. Last thunk is called -;;; in this process. PIPE* never returns. - -(define (pipe* . thunks) - (letrec ((lay-pipe (lambda (thunks) - (let ((thunk (car thunks)) - (thunks (cdr thunks))) - (if (pair? thunks) - (begin (fork/pipe thunk) - (lay-pipe thunks)) - (call-terminally thunk)))))) ; Last one. - (if (pair? thunks) - (lay-pipe thunks) - (error "No thunks passed to PIPE*")))) - -;;; Splice the processes into the i/o flow upstream from us. -;;; First thunk's process reads from our stdin; last thunk's process' -;;; output becomes our new stdin. Essentially, n-ary fork/pipe. -;;; -;;; This procedure is so trivial it isn't included. -;;; (define (pipe-splice . thunks) (for-each fork/pipe thunks)) - - - - -;;; Should be moved to somewhere else -(define (with-lock lock thunk) - (dynamic-wind - (lambda () - (release-lock lock)) - thunk - (lambda () - (release-lock lock)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; working directory per thread - -(define *cwd-cache* 'uninitialized) -(define cwd-lock (make-lock)) - -(define (initialize-cwd) - (set! *cwd-cache* (process-cwd)) - (set! $cwd ;;; TODO The old thread-fluid will remain - (make-preserved-thread-fluid - (cwd-cache)))) -; (set! cwd-lock (make-lock))) - -(define (cwd-cache) - *cwd-cache*) - -;; Actually do the syscall and update the cache -;; assumes the cwd lock obtained -(define (change-and-cache-cwd new-cwd) - (if (not (file-name-absolute? new-cwd)) - (process-chdir (string-append (cwd) "/" new-cwd)) - (process-chdir new-cwd)) - (set! *cwd-cache* (process-cwd))) - -;; The thread-specific cwd: A thread fluid - -(define $cwd 'empty-cwd-value) - -(define (cwd) (thread-fluid $cwd)) -(define (thread-set-cwd! cwd) (set-thread-fluid! $cwd cwd)) -(define (let-cwd cwd thunk) - (let-thread-fluid $cwd cwd thunk)) - -(define (with-cwd* new-cwd thunk) - (let ((changed-cwd - (with-lock cwd-lock - (lambda () - (change-and-cache-cwd new-cwd) - (cwd-cache))))) - (let-cwd changed-cwd thunk))) - -;; Align the value of the Unix cwd with scsh's value. -;; Since another thread could disalign, this call and -;; any ensuring syscall that relies upon it should -;; be "glued together" with the cwd lock. - -(define (align-cwd!) - (let ((thread-cwd (cwd))) - (if (not (string=? thread-cwd (cwd-cache))) - (change-and-cache-cwd thread-cwd)))) - -(define (chdir . maybe-dir) - (let ((dir (:optional maybe-dir (home-dir)))) - (with-lock cwd-lock - (lambda () - (change-and-cache-cwd dir) - (thread-set-cwd! (cwd-cache)))))) - -(define-record-type resource :resource - (make-resource align! lock) - resource? - (align! resource-align!) - (lock resource-lock)) - -(define (with-resources-aligned resources thunk) - (let ((locks (map resource-lock resources))) - (apply obtain-all-or-none locks) - (for-each - (lambda (align!) (align!)) - (map resource-align! resources)) - (let ((val (with-handler - (lambda (cond more) - (for-each release-lock locks) - (more)) - thunk))) - (for-each release-lock locks) - val))) - -(define cwd-resource (make-resource align-cwd! cwd-lock)) - -;; example syscall -;; (define (exported-delete-file fname) -;; (with-cwd-aligned (really-delete-file fname))) - -(define cwd-reinitializer - (make-reinitializer (lambda () (initialize-cwd)))) - - -(initialize-cwd) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; umask per thread -(define *umask-cache* 'uninitialized) -(define umask-lock (make-lock)) - -(define (initialize-umask) - (set! *umask-cache* (process-umask)) - (set! $umask ;;; TODO The old thread-fluid will remain - (make-preserved-thread-fluid - (umask-cache)))) -; (set! umask-lock (make-lock))) - -(define (umask-cache) - *umask-cache*) - -;; Actually do the syscall and update the cache -;; assumes the resource lock obtained -(define (change-and-cache-umask new-umask) - (set-process-umask new-umask) - (set! *umask-cache* (process-umask))) - -;; The thread-specific umask: A thread fluid - -(define $umask 'empty-umask-value) - -(define (umask) (thread-fluid $umask)) -(define (thread-set-umask! new-umask) (set-thread-fluid! $umask new-umask)) -(define (let-umask new-umask thunk) - (let-thread-fluid $umask new-umask thunk)) - -(define (with-umask* new-umask thunk) - (let ((changed-umask - (with-lock umask-lock - (lambda () - (change-and-cache-umask new-umask) - (umask-cache))))) - (let-umask changed-umask thunk))) - -(define (align-umask!) - (let ((thread-umask (umask))) - (if (not (= thread-umask (umask-cache))) - (change-and-cache-umask thread-umask)))) - -(define (set-umask new-umask) - (with-lock umask-lock - (lambda () - (change-and-cache-umask new-umask) - (thread-set-umask! (umask-cache))))) - -(define umask-resource (make-resource align-umask! umask-lock)) - -(define umask-reinitializer - (make-reinitializer (lambda () (initialize-umask)))) - - -(initialize-umask) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; effective uid and gid per thread - -(define-syntax make-Xid-resource - (syntax-rules () - ((make-Xid-resource - process-user-effective-Xid set-process-user-effective-Xid - process-set-Xid set-Xid - align-eXid! eXid-resource - user-effective-Xid set-user-effective-Xid with-user-effective-Xid*) - (begin - (define *eXid-cache* 'uninitialized) - (define eXid-lock (make-lock)) - - (define (initialize-eXid) - (set! *eXid-cache* (process-user-effective-Xid)) - (set! $eXid - (make-preserved-thread-fluid - (eXid-cache)))) - - (define (eXid-cache) - *eXid-cache*) - -;; Actually do the syscall and update the cache -;; assumes the resource lock obtained - (define (change-and-cache-eXid new-eXid) - (set-process-user-effective-Xid new-eXid) - (set! *eXid-cache* (process-user-effective-Xid))) - -;; The thread-specific eXid: A thread fluid - - (define $eXid 'empty-eXid-value) - - (define (user-effective-Xid) (thread-fluid $eXid)) - (define (thread-set-eXid! new-eXid) (set-thread-fluid! $eXid new-eXid)) - (define (let-eXid new-eXid thunk) - (let-thread-fluid $eXid new-eXid thunk)) - -;; set-Xid will affect the effective X id - (define (set-Xid Xid) - (with-lock eXid-lock - (lambda () - (process-set-Xid Xid) - (set! *eXid-cache* (process-user-effective-Xid)) - (thread-set-eXid! *eXid-cache*)))) - - (define (with-user-effective-Xid* new-eXid thunk) - (let ((changed-eXid - (with-lock eXid-lock - (lambda () - (change-and-cache-eXid new-eXid) - (eXid-cache))))) - (let-eXid changed-eXid thunk))) - - (define (align-eXid!) - (let ((thread-eXid (user-effective-Xid))) - (if (not (= thread-eXid (eXid-cache))) - (change-and-cache-eXid thread-eXid)))) - - (define (set-user-effective-Xid new-eXid) - (with-lock eXid-lock - (lambda () - (change-and-cache-eXid new-eXid) - (thread-set-eXid! (eXid-cache))))) - - (define eXid-resource (make-resource align-eXid! eXid-lock)) - - (define eXid-reinitializer - (make-reinitializer (lambda () (initialize-eXid)))) - - (initialize-eXid) - )))) - -(make-Xid-resource - process-user-effective-uid set-process-user-effective-uid - process-set-uid set-uid - align-euid! euid-resource - user-effective-uid set-user-effective-uid with-user-effective-uid*) - -(make-Xid-resource - process-user-effective-gid set-process-user-effective-gid - process-set-gid set-gid - align-egid! egid-resource - user-effective-gid set-user-effective-gid with-user-effective-gid*) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ensure S48 is aligned too - -(set-with-fs-context-aligned*! - (lambda (thunk) - (with-resources-aligned - (list cwd-resource umask-resource euid-resource egid-resource) - thunk))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Environment per thread -(define *env-cache* 'uninitialized) -(define env-lock (make-lock)) - -(define (install-env) - (set! *env-cache* (environ**-read)) - (set! $env ;;; TODO The old thread-fluid will remain - (make-preserved-thread-fluid - (env-cache)))) -; (set! env-lock (make-lock))) - -(define (env-cache) - *env-cache*) - -;; Actually do the syscall and update the cache -;; assumes the env lock obtained -(define (change-and-cache-env env) - (environ**-set env) - (set! *env-cache* env)) - -;; The thread-specific env: A thread fluid - -(define $env 'empty-env-value) - -(define (thread-read-env) (thread-fluid $env)) -(define (thread-set-env! res) (set-thread-fluid! $env res)) -(define (let-env res thunk) - (let-thread-fluid $env res thunk)) - -(define (really-with-env* env thunk) - (with-lock env-lock - (lambda () - (change-and-cache-env env))) - (let-env env thunk)) - -(define (align-env!) - (let ((res (thread-read-env))) - (if (not (env=? res (env-cache))) - (change-and-cache-env res)))) - -(define (thread-change-env res) - (with-lock env-lock - (lambda () - (change-and-cache-env res) - (thread-set-env! (env-cache))))) - -(define environ-resource (make-resource align-env! env-lock)) - -(define env-reinitializer - (make-reinitializer install-env)) - - -(define-record env - envvec - alist) ; Corresponding alist - -(define-record-resumer type/env - (lambda (env) - (set-env:envvec env #f))) - -(define (env=? e1 e2) - (and (env:envvec e1) - (eq? (env:envvec e1) - (env:envvec e2)))) - -(define-record envvec - environ ;; char** - ) - -(define (add-envvec-finalizer! envvec) - (add-finalizer! envvec envvec-finalizer)) - -(define-exported-binding "envvec-record-type" type/envvec) -(define-exported-binding "add-envvec-finalizer!" add-envvec-finalizer!) - -(define (envvec-finalizer envvec) - (%free-env envvec)) - -(define (environ**-read) - (let ((alist.envvec (environ-env->alist))) - (make-env (cdr alist.envvec) (car alist.envvec)))) - -(define (environ**-set env) - (if (env:envvec env) - (%align-env (env:envvec env)) - (set-env:envvec env (envvec-alist->env (env:alist env))))) - -(define (getenv var) - (let* ((env (thread-read-env)) - (res (assoc var (env:alist env)))) - (if res (cdr res) res))) - -(define (env->alist) - (env:alist (thread-read-env))) - -(define (setenv var val) - (let* ((env (thread-read-env)) - (alist (if val - (alist-update - var - val - (env:alist env)) - (alist-delete - var - (env:alist env))))) - (thread-set-env! - (make-env - #f - alist)))) - -(define (alist->env alist) - (thread-set-env! - (make-env - #f - alist))) - -(define (with-env* alist-delta thunk) - (let ((new-env (fold (lambda (key/val alist) - (alist-update (car key/val) (cdr key/val) alist)) - (env->alist) - alist-delta))) - (with-total-env* new-env thunk))) - -(define (with-total-env* alist thunk) - (really-with-env* (make-env #f alist) thunk)) - - -;;; These two functions are obsoleted by the more general INFIX-SPLITTER and -;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined -;;; internally so the top-level startup code (INIT-SCSH) can use it -;;; to split up $PATH without requiring the field-splitter or regexp code. - -(define (split-colon-list clist) - (let ((len (string-length clist))) - (if (= 0 len) '() ; Special case "" -> (). - - ;; Main loop. - (let split ((i 0)) - (cond ((string-index clist #\: i) => - (lambda (colon) - (cons (substring clist i colon) - (split (+ colon 1))))) - (else (list (substring clist i len)))))))) - -;;; Unix colon lists typically use colons as separators, which -;;; is not as clean to deal with as terminators, but that's Unix. -;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "". - -; (define (string-list->colon-list slist) -; (if (pair? slist) -; (apply string-append -; (let colonise ((lis slist)) ; LIS is always -; (let ((tail (cdr lis))) ; a pair. -; (cons (car lis) -; (if (pair? tail) -; (cons ":" (colonise tail)) -; '()))))) -; "")) ; () case. - - -(define (alist-delete key alist) - (filter (lambda (key/val) (not (equal? key (car key/val)))) alist)) - -(define (alist-update key val alist) - (cons (cons key val) - (alist-delete key alist))) - -;;; Remove shadowed entries from ALIST. Preserves element order. -;;; (This version shares no structure.) - -(define (alist-compress alist) - (reverse (let compress ((alist alist) (ans '())) - (if (pair? alist) - (let ((key/val (car alist)) - (alist (cdr alist))) - (compress alist (if (assoc (car key/val) ans) ans - (cons key/val ans)))) - ans)))) - -(define (add-before elt before list) - (let rec ((list list)) - (if (pair? list) - (let ((x (car list))) - (if (equal? x before) - (cons elt list) - (cons x (rec (cdr list))))) - (cons elt list)))) - -;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER -;;; in LIST, and returns the list. However, if the LET finds no occurrence -;;; of AFTER in LIST, it returns #F instead. - -(define (add-after elt after list) - (or (let rec ((list list)) - (if (pair? list) - (let* ((x (car list)) - (tail (cdr list)) - (ans (rec tail))) ; #f if AFTER wasn't encountered. - (cond (ans (cons x ans)) - ((equal? x after) - (cons x (cons elt tail))) - (else #f))) ; AFTER doesn't appear in LIST. - #f)) ; AFTER doesn't appear in LIST. - (cons elt list))) - -;;; Sugar: - -(define-simple-syntax (with-cwd dir . body) - (with-cwd* dir (lambda () . body))) - -(define-simple-syntax (with-umask mask . body) - (with-umask* mask (lambda () . body))) - -(define-simple-syntax (with-env delta . body) - (with-env* `delta (lambda () . body))) - -(define-simple-syntax (with-total-env env . body) - (with-total-env* `env (lambda () . body))) - -(define-simple-syntax (with-user-effective-uid uid . body) - (with-user-effective-uid* uid (lambda () . body))) - -(define-simple-syntax (with-user-effective-gid gid . body) - (with-user-effective-gid* gid (lambda () . body))) - -(define (call/temp-file writer user) - (let ((fname #f)) - (dynamic-wind - (lambda () (if fname (error "Can't wind back into a CALL/TEMP-FILE") - (set! fname (create-temp-file)))) - (lambda () - (with-output-to-file fname writer) - (user fname)) - (lambda () (if fname (delete-file fname)))))) - -;;; Create a new temporary file and return its name. -;;; The optional argument specifies the filename prefix to use, and defaults -;;; to "/tmp/.", where is the current process' id. The procedure -;;; scans through the files named 0, 1, ... until it finds a -;;; filename that doesn't exist in the filesystem. It creates the file with -;;; permission #o600, and returns the filename. -;;; - -(define (create-temp-file . maybe-prefix) - (let ((oflags (bitwise-ior open/write - (bitwise-ior open/create open/exclusive)))) - (apply temp-file-iterate - (lambda (fname) - (close-fdes (open-fdes fname oflags #o600)) - fname) - (if (null? maybe-prefix) '() - (list (string-append (constant-format-string (car maybe-prefix)) - ".~a")))))) - -(define (initial-temp-file) - (let ((tmpdir (getenv "TMPDIR"))) - (string-append - (if tmpdir - tmpdir - "/var/tmp") - "/" - (number->string (pid)) - "~a"))) - -(define *temp-file-template* (make-fluid 'not-initialized-temp-file-template)) - -(define temp-file-reinitializer - (make-reinitializer - (lambda () - (set-fluid! *temp-file-template* (initial-temp-file))))) - -(define (temp-file-iterate maker . maybe-template) - (let ((template (:optional maybe-template (fluid *temp-file-template*)))) - (let loop ((i 0)) - (if (> i 1000) (error "Can't create temp-file") - (let ((fname (format #f template (number->string i)))) - (receive retvals (with-errno-handler - ((errno data) - ((errno/exist errno/acces) #f)) - (maker fname)) - (if (car retvals) (apply values retvals) - (loop (+ i 1))))))))) - - -;; Double tildes in S. -;; Using the return value as a format string will output exactly S. -(define (constant-format-string s) ; Ugly code. Would be much clearer - (let* ((len (string-length s)) ; if written with string SRFI. - (tilde? (lambda (s i) (char=? #\~ (string-ref s i)))) - (newlen (do ((i (- len 1) (- i 1)) - (ans 0 (+ ans (if (tilde? s i) 2 1)))) - ((< i 0) ans))) - (fs (make-string newlen))) - (let lp ((i 0) (j 0)) - (cond ((< i len) - (let ((j (cond ((tilde? s i) (string-set! fs j #\~) (+ j 1)) - (else j)))) - (string-set! fs j (string-ref s i)) - (lp (+ i 1) (+ j 1)))))) - fs)) - - -;;; Roughly equivalent to (pipe). -;;; Returns two file ports [iport oport] open on a temp file. -;;; Use this when you may have to buffer large quantities between -;;; writing and reading. Note that if the consumer gets ahead of the -;;; producer, it won't hang waiting for input, it will just return -;;; EOF. To play it safe, make sure that the producer runs to completion -;;; before starting the consumer. -;;; -;;; The temp file is deleted before TEMP-FILE-CHANNEL returns, so as soon -;;; as the ports are closed, the file's disk storage is reclaimed. - -(define (temp-file-channel) - (let* ((fname (create-temp-file)) - (iport (open-input-file fname)) - (oport (open-output-file fname))) - (delete-file fname) - (values iport oport))) - - -;; Return a Unix port such that reads on it get the chars produced by -;; DISPLAYing OBJ. For example, if OBJ is a string, then reading from -;; the port produces the characters of OBJ. -;; -;; This implementation works by writing the string out to a temp file, -;; but that isn't necessary. It could work, for example, by forking off a -;; writer process that outputs to a pipe, i.e., -;; (run/port (begin (display obj (fdes->outport 1)))) - -(define (open-string-source obj) - (receive (inp outp) (temp-file-channel) - (display obj outp) - (close-output-port outp) - inp)) - - -;;;; Process->Scheme interface forms: run/collecting, run/port, run/string, ... - -;;; (run/collecting FDS . EPF) -;;; -------------------------- -;;; RUN/COLLECTING and RUN/COLLECTING* run processes that produce multiple -;;; output streams and return ports open on these streams. -;;; -;;; To avoid issues of deadlock, RUN/COLLECTING first runs the process -;;; with output to temp files, then returns the ports open on the temp files. -;;; -;;; (run/collecting (1 2) (ls)) -;;; runs ls with stdout (fd 1) and stderr (fd 2) redirected to temporary files. -;;; When ls is done, RUN/COLLECTING returns two ports open on the temporary -;;; files. The files are deleted before RUN/COLLECTING returns, so when -;;; the ports are closed, they vanish. -;;; -;;; The FDS list of file descriptors is implicitly backquoted. -;;; -;;; RUN/COLLECTING* is the procedural abstraction of RUN/COLLECTING. - -(define (run/collecting* fds thunk) - ;; First, generate a pair of ports for each communications channel. - ;; Each channel buffers through a temp file. - (let* ((channels (map (lambda (ignore) - (call-with-values temp-file-channel cons)) - fds)) - (read-ports (map car channels)) - (write-ports (map cdr channels)) - - ;; In a subprocess, close the read ports, redirect input from - ;; the write ports, and run THUNK. - (status (run (begin (for-each close-input-port read-ports) - (for-each move->fdes write-ports fds) - (thunk))))) - - ;; In this process, close the write ports and return the exit status - ;; and all the the read ports. - (for-each close-output-port write-ports) - (apply values status read-ports))) - - -;;; Single-stream collectors: -;;; Syntax: run/port, run/file, run/string, run/strings, run/sexp, run/sexps -;;; Procedures: run/port*, run/file*, run/string*, run/strings*, run/sexp*, -;;; run/sexps* -;;; port->string, port->string-list, port->sexp-list, -;;; port->list -;;; -;;; Syntax: -;;; (run/port . epf) -;;; Fork off the process EPF and return a port on its stdout. -;;; (run/file . epf) -;;; Run process EPF with stdout redirected into a temp file. -;;; When the process exits, return the name of the file. -;;; (run/string . epf) -;;; Read the process' stdout into a string and return it. -;;; (run/strings . epf) -;;; Run process EPF, reading newline-terminated strings from its stdout -;;; until EOF. After process exits, return list of strings read. Delimiting -;;; newlines are trimmed from the strings. -;;; (run/sexp . epf) -;;; Run process EPF, read and return one sexp from its stdout with READ. -;;; (run/sexps . epf) -;;; Run process EPF, read sexps from its stdout with READ until EOF. -;;; After process exits, return list of items read. -;;; -;;; Procedural abstractions: -;;; run/port*, run/file*, run/string*, run/strings*, run/sexp*, run/sexps* -;;; -;;; These are all procedural equivalents for the macros. They all take -;;; one argument: the process to be executed passed as a thunk. For example, -;;; (RUN/PORT . epf) expands into (RUN/PORT* (LAMBDA () (EXEC-EPF . epf))) -;;; -;;; Other useful procedures: -;;; -;;; (port->string port) -;;; Read characters from port until EOF; return string collected. -;;; (port->string-list port) -;;; Read newline-terminated strings from port until EOF. Return -;;; the list of strings collected. -;;; (port->sexp-list port) -;;; Read sexps from port with READ until EOF. Return list of items read. -;;; (port->list reader port) -;;; Repeatedly applies READER to PORT, accumulating results into a list. -;;; On EOF, returns the list of items thus collected. -;;; (port-fold port reader op . seeds) -;;; Repeatedly read things from PORT with READER. Each time you read -;;; some value V, compute a new set of seeds with (apply OP V SEEDS). -;;; (More than 1 seed means OP must return multiple values). -;;; On eof, return the seeds: (apply value SEEDS). -;;; PORT->LIST is just (PORT-FOLD PORT READ CONS '()) - -(define (run/port+proc* thunk) - (receive (r w) (pipe) - (let ((proc (fork (lambda () - (close r) - (move->fdes w 1) - (with-current-output-port* w thunk))))) - (close w) - (values r proc)))) - -(define (run/port* thunk) - (receive (port proc) (run/port+proc* thunk) - port)) - -(define (run/file* thunk) - (let ((fname (create-temp-file))) - (run (begin (thunk)) (> ,fname)) - fname)) - -(define (run/string* thunk) - (close-after (run/port* thunk) port->string)) - -(define (run/sexp* thunk) - (close-after (run/port* thunk) read)) - -(define (run/sexps* thunk) - (close-after (run/port* thunk) port->sexp-list)) - -(define (run/strings* thunk) - (close-after (run/port* thunk) port->string-list)) - - -;;; Read characters from PORT until EOF, collect into a string. - -(define (port->string port) - (let ((sc (make-string-collector))) - (letrec ((lp (lambda () - (cond ((read-string 1024 port) => - (lambda (s) - (collect-string! sc s) - (lp))) - (else (string-collector->string sc)))))) - (lp)))) - -;;; (loop (initial (sc (make-string-collector))) -;;; (bind (s (read-string 1024 port))) -;;; (while s) -;;; (do (collect-string! sc s)) -;;; (result (string-collector->string sc))) - -;;; Read items from PORT with READER until EOF. Collect items into a list. - -(define (port->list reader port) - (let lp ((ans '())) - (let ((x (reader port))) - (if (eof-object? x) (reverse! ans) - (lp (cons x ans)))))) - -(define (port->sexp-list port) - (port->list read port)) - -(define (port->string-list port) - (port->list read-line port)) - -(define (port-fold port reader op . seeds) - (letrec ((fold (lambda seeds - (let ((x (reader port))) - (if (eof-object? x) (apply values seeds) - (call-with-values (lambda () (apply op x seeds)) - fold)))))) - (apply fold seeds))) - -(define reduce-port - (deprecated-proc port-fold 'reduce-port "Use port-fold instead.")) - -;;; Not defined: -;;; (field-reader field-delims record-delims) -;;; Returns a reader that reads strings delimited by 1 or more chars from -;;; the string FIELD-DELIMS. These strings are collected in a list until -;;; eof or until 1 or more chars from RECORD-DELIMS are read. Then the -;;; accumulated list of strings is returned. For example, if we want -;;; a procedure that reads one line of input, splitting it into -;;; whitespace-delimited strings, we can use -;;; (field-reader " \t" "\n") -;;; for a reader. - - - -;; Loop until EOF reading characters or strings and writing (FILTER char) -;; or (FILTER string). Useful as an arg to FORK or FORK/PIPE. - -(define (make-char-port-filter filter) - (lambda () - (let lp () - (let ((c (read-char))) - (if (not (eof-object? c)) - (begin (write-char (filter c)) - (lp))))))) - -(define (make-string-port-filter filter . maybe-buflen) - (let* ((buflen (:optional maybe-buflen 1024)) - (buf (make-string buflen))) - (lambda () - (let lp () - (cond ((read-string! buf 0 buflen) => - (lambda (nread) - (display (filter (if (= nread buflen) buf - (substring buf 0 nread)))) ; last one. - (lp)))))))) - -(define (y-or-n? question . maybe-eof-value) - (let loop ((count *y-or-n-eof-count*)) - (display question) - (display " (y/n)? ") - (let ((line (read-line))) - (cond ((eof-object? line) - (newline) - (if (= count 0) - (:optional maybe-eof-value (error "EOF in y-or-n?")) - (begin (display "I'll only ask another ") - (write count) - (display " times.") - (newline) - (loop (- count 1))))) - ((< (string-length line) 1) (loop count)) - ((char=? (string-ref line 0) #\y) #t) - ((char=? (string-ref line 0) #\n) #f) - (else (loop count)))))) - -(define *y-or-n-eof-count* 100) - - -;;; Stdio/stdport sync procedures -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (stdio->stdports) - (set-current-input-port! (fdes->inport 0)) - (set-current-output-port! (fdes->outport 1)) - (set-current-error-port! (fdes->outport 2))) - -(define (with-stdio-ports* thunk) - (with-current-input-port (fdes->inport 0) - (with-current-output-port (fdes->outport 1) - (with-current-error-port (fdes->outport 2) - (thunk))))) - -(define-simple-syntax (with-stdio-ports body ...) - (with-stdio-ports* (lambda () body ...))) - - -(define (stdports->stdio) - (dup (current-input-port) 0) - (dup (current-output-port) 1) - (dup (current-error-port) 2)) - - -;;; Command-line argument access -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Some globals. -(define %command-line '()) ; Includes program. -(define command-line-arguments #f) ; Doesn't include program. - -(define (set-command-line-args! args) - (set! %command-line args) - (set! command-line-arguments (append (cdr args) '()))) - -(define (arg* arglist n . maybe-default-thunk) - (let ((oops (lambda () (error "argument out of bounds" arglist n)))) - (if (< n 1) (oops) - (let lp ((al arglist) (n n)) - (if (pair? al) - (if (= n 1) (car al) - (lp (cdr al) (- n 1))) - (if (and (pair? maybe-default-thunk) - (null? (cdr maybe-default-thunk))) - ((car maybe-default-thunk)) - (oops))))))) - -(define (arg arglist n . maybe-default) - (if maybe-default (arg* arglist n (lambda () (car maybe-default))) - (arg* arglist n))) - -(define (argv n . maybe-default) - (apply arg %command-line (+ n 1) maybe-default)) - -(define (command-line) (append %command-line '())) - -;;; EXEC support -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Assumes a low-level %exec procedure: -;;; (%exec prog arglist env) -;;; ENV is either #t, meaning the current environment, or a string->string -;;; alist. -;;; %EXEC stringifies PROG and the elements of ARGLIST. - -(define (stringify thing) - (cond ((string? thing) thing) - ((symbol? thing) - (symbol->string thing)) -; ((symbol? thing) -; (list->string (map char-downcase -; (string->list (symbol->string thing))))) - ((integer? thing) - (number->string thing)) - (else (error "Can only stringify strings, symbols, and integers." - thing)))) - -(define (exec-path-search prog path-list) - (cond - ((not (file-name-absolute? prog)) - (let loop ((path-list path-list)) - (if (not (null? path-list)) - (let* ((dir (car path-list)) - (fname (string-append dir "/" prog))) - (if (file-executable? fname) - fname - (loop (cdr path-list))))))) - ((file-executable? prog) - prog) - (else #f))) - -(define (exec/env prog env . arglist) - (flush-all-ports) - (with-resources-aligned - (list environ-resource cwd-resource umask-resource euid-resource egid-resource) - (lambda () - (%exec prog (cons prog arglist) env)))) - -;(define (exec-path/env prog env . arglist) -; (cond ((exec-path-search (stringify prog) (fluid exec-path-list)) => -; (lambda (binary) -; (apply exec/env binary env arglist))) -; (else (error "No executable found." prog arglist)))) - -;;; This procedure is bummed by tying in directly to %%exec/errno -;;; and pulling some of %exec's code out of the inner loop so that -;;; the inner loop will be fast. Folks don't like waiting... - -(define (exec-path/env prog env . arglist) - (flush-all-ports) - (with-resources-aligned - (list environ-resource cwd-resource umask-resource euid-resource egid-resource) - (lambda () - (let ((prog (stringify prog))) - (if (string-index prog #\/) - - ;; Contains a slash -- no path search. - (%exec prog (cons prog arglist) env) - - ;; Try each directory in PATH-LIST. - (let ((argv (list->vector (cons prog (map stringify arglist))))) - (for-each (lambda (dir) - (let ((binary (string-append dir "/" prog))) - (%%exec binary argv env))) - (thread-fluid exec-path-list))))) - - (error "No executable found." prog arglist)))) - -(define (exec-path prog . arglist) - (apply exec-path/env prog #t arglist)) - -(define (exec prog . arglist) - (apply exec/env prog #t arglist)) - - -;;; Assumes niladic primitive %%FORK. - -(define (fork . stuff) - (apply fork-1 #t stuff)) - -(define (%fork . stuff) - (apply fork-1 #f stuff)) - -(define (fork-1 clear-interactive? . rest) - (let-optionals rest ((maybe-thunk #f) - (dont-narrow? #f)) - (really-fork clear-interactive? - (not dont-narrow?) - maybe-thunk))) - -(define (preserve-ports thunk) - (let ((current-input (current-input-port)) - (current-output (current-output-port)) - (current-error (current-error-port))) - (lambda () - (with-current-input-port* - current-input - (lambda () - (with-current-output-port* - current-output - (lambda () - (with-current-error-port* - current-error - thunk)))))))) - -(define (really-fork clear-interactive? narrow? maybe-thunk) - (let ((proc #f) - (maybe-narrow - (if narrow? - (lambda (thunk) - ;; narrow loses the thread fluids and the dynamic environment - (narrow (preserve-ports (preserve-thread-fluids thunk)) - 'forking)) - (lambda (thunk) (thunk))))) - (maybe-narrow - (lambda () - - (if clear-interactive? - (flush-all-ports)) - - ;; There was an atomicity problem/race condition -- if a child - ;; process died after it was forked, but before the scsh fork - ;; procedure could register the child's procobj in the - ;; pid/procobj table, then when the SIGCHLD signal-handler reaped - ;; the process, there would be no procobj for it. We now lock - ;; out interrupts across the %%FORK and NEW-CHILD-PROC - ;; operations. - - (((structure-ref interrupts with-interrupts-inhibited) - (lambda () - ;; with-env-aligned is not neccessary here but it will - ;; create the environ object in the parent process which - ;; could reuse it on further forks - (let ((pid (with-resources-aligned - (list environ-resource) - %%fork))) - (if (zero? pid) - ;; Child - (lambda () ; Do all this outside the WITH-INTERRUPTS. - ;; There is no session if parent was started in batch-mode - (if (and (session-started?) clear-interactive?) - (set-batch-mode?! #t)) ; Children are non-interactive. - (if maybe-thunk - (call-terminally maybe-thunk))) - ;; Parent - (begin - (set! proc (new-child-proc pid)) - (lambda () - (values)))))))))) - proc)) - -(define (exit . maybe-status) - (let ((status (:optional maybe-status 0))) - (if (not (integer? status)) - (error "non-integer argument to exit")) - (call-exit-hooks-and-narrow - (lambda () - (exit/errno status) - (display "The evil undead walk the earth." 2) - (if #t (error "(exit) returned.")))))) - - -;;; The classic T 2.0 primitive. -;;; This definition works for procedures running on top of Unix systems. -(define (halts? proc) #t) - - -;;; Low-level init absolutely required for any scsh program. - -(define (init-scsh-hindbrain relink-ff?) - (if #t (error "call to init-scsh-hindbrain which is dead")) -; (if relink-ff? (lookup-all-externals)) ; Re-link C calls. -; (init-fdports!) -; (%install-unix-scsh-handlers) -) - - -;;; Some globals: -(define home-directory "") -(define exec-path-list) - -(define (init-scsh-vars quietly?) - (set! home-directory - (cond ((getenv "HOME") => ensure-file-name-is-nondirectory) - ;; loosing at this point would be really bad, so some - ;; paranoia comes in order - (else (call-with-current-continuation - (lambda (k) - (with-handler - (lambda (condition more) - (cond ((not quietly?) - (display "Starting up with no home directory ($HOME).") - (newline))) - (k "/")) - (lambda () - (user-info:home-dir (user-info (user-uid)))))))))) - - (set! exec-path-list - (make-preserved-thread-fluid - (cond ((getenv "PATH") => split-colon-list) - (else (if (not quietly?) - (warn "Starting up with no path ($PATH).")) - '()))))) - - -; SIGTSTP blows s48 away. ??? -(define (suspend) (signal-process 0 signal/stop)) - diff --git a/scsh/signal.scm b/scsh/signal.scm new file mode 100644 index 0000000..55335db --- /dev/null +++ b/scsh/signal.scm @@ -0,0 +1,54 @@ +;;; Signals (rather incomplete) +;;; --------------------------- + +(import-os-error-syscall 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 sigevents 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) + + + + +;;; 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)))))) diff --git a/scsh/stdio.scm b/scsh/stdio.scm new file mode 100644 index 0000000..aadc536 --- /dev/null +++ b/scsh/stdio.scm @@ -0,0 +1,22 @@ +;;; Stdio/stdport sync procedures +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (stdio->stdports) + (set-current-input-port! (fdes->inport 0)) + (set-current-output-port! (fdes->outport 1)) + (set-current-error-port! (fdes->outport 2))) + +(define (with-stdio-ports* thunk) + (with-current-input-port (fdes->inport 0) + (with-current-output-port (fdes->outport 1) + (with-current-error-port (fdes->outport 2) + (thunk))))) + +(define-simple-syntax (with-stdio-ports body ...) + (with-stdio-ports* (lambda () body ...))) + + +(define (stdports->stdio) + (dup (current-input-port) 0) + (dup (current-output-port) 1) + (dup (current-error-port) 2)) diff --git a/scsh/syntax.scm b/scsh/syntax.scm index 4ff7ccc..3a82273 100644 --- a/scsh/syntax.scm +++ b/scsh/syntax.scm @@ -2,11 +2,6 @@ ;;; Translating process forms into Scheme code. ;;; Copyright (c) 1993 by Olin Shivers. -(define-syntax define-simple-syntax - (syntax-rules () - ((define-simple-syntax (name . pattern) result) - (define-syntax name (syntax-rules () ((name . pattern) result)))))) - ;;; The three basic forms for running an extended process form: ;;; EXEC-EPF, &, and RUN. EXEC-EPF is the foundation. @@ -73,3 +68,18 @@ ;(define-simple-syntax (test-mac trans . form) ; (pp (expand-mac trans (quote form)))) + +;; Return a Unix port such that reads on it get the chars produced by +;; DISPLAYing OBJ. For example, if OBJ is a string, then reading from +;; the port produces the characters of OBJ. +;; +;; This implementation works by writing the string out to a temp file, +;; but that isn't necessary. It could work, for example, by forking off a +;; writer process that outputs to a pipe, i.e., +;; (run/port (begin (display obj (fdes->outport 1)))) + +(define (open-string-source obj) + (receive (inp outp) (temp-file-channel) + (display obj outp) + (close-output-port outp) + inp)) diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm deleted file mode 100644 index fa77b92..0000000 --- a/scsh/syscalls.scm +++ /dev/null @@ -1,761 +0,0 @@ -;;; POSIX system-call Scheme binding. -;;; Copyright (c) 1993 by Olin Shivers. - -;;; Scheme48 implementation. - -;;; Need to rationalise names here. getgid. get-gid. "effective" as morpheme? - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Import a C function and convert the exception os-error to a syscall-error -;;; -;;; 1.) Import a C function -;;; 2.) Turn os-error into syscall-error -;;; 3.) Retry on EINTR -;;; The call/cc and the record is due to S48's broken exception system: -;;; You can't throw an error within a handler -;;; - -;;; Move this to somewhere else as soon as Marc has published his SRFI -(define (continuation-capture receiver) - ((call-with-current-continuation - (lambda (cont) - (lambda () (receiver cont)))))) - -(define (continuation-graft cont thunk) - (cont thunk)) - -(define (continuation-return cont . returned-values) - (continuation-graft - cont - (lambda () (apply values returned-values)))) - -(define-syntax import-os-error-syscall - (syntax-rules () - ((import-os-error-syscall syscall (%arg ...) c-name) - (begin - (import-lambda-definition syscall/eintr (%arg ...) c-name) - (define (syscall %arg ...) - (let ((arg %arg) ...) - (continuation-capture - (lambda (cont) - (let loop () - (with-handler - (lambda (condition more) - (if (and (exception? condition) (eq? (exception-reason condition) - 'os-error)) - (let ((stuff (exception-arguments condition))) - (if (= (cadr stuff) errno/intr) - (loop) - (continuation-graft - cont - (lambda () - (apply errno-error - (cadr stuff) ; errno - (caddr stuff) ;msg - syscall - (cdddr stuff)))))) ;packet - (more))) - (lambda () - (syscall/eintr %arg ...)))))))))))) - -;;; Process -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; we can't algin env here, because exec-path/env calls -;; %%exec/errno directly F*&% *P -(import-os-error-syscall %%exec (prog argv env) "scheme_exec") - -(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))) - - -(import-os-error-syscall exit/errno ; errno -- misnomer. - (status) "scsh_exit") - -(import-os-error-syscall %exit/errno ; errno -- misnomer - (status) "scsh__exit") - -(define (%exit . maybe-status) - (%exit/errno (:optional maybe-status 0)) - (error "Yikes! %exit returned.")) - - -(import-os-error-syscall %%fork () "scsh_fork") - -;;; Posix waitpid(2) call. -(import-os-error-syscall %wait-pid/list (pid options) "wait_pid") - -(define (%wait-pid pid options) - (apply values (%wait-pid/list pid options))) - -;;; Miscellaneous process state -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Working directory - -(import-os-error-syscall %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 -(import-os-error-syscall process-cwd () "scheme_cwd") - -;;; GID - -(import-os-error-syscall user-gid () "scsh_getgid") - -(import-os-error-syscall process-user-effective-gid () "scsh_getegid") - -(import-os-error-syscall process-set-gid (gid) "scsh_setgid") - -(import-os-error-syscall set-process-user-effective-gid (gid) "scsh_setegid") - -(import-os-error-syscall user-supplementary-gids () "get_groups") - -;;; UID -(import-os-error-syscall user-uid () "scsh_getuid") - -(import-os-error-syscall process-user-effective-uid () "scsh_geteuid") - -(import-os-error-syscall process-set-uid (uid) "scsh_setuid") - -(import-os-error-syscall set-process-user-effective-uid (uid) "scsh_seteuid") - -(import-os-error-syscall %user-login-name () "my_username") - -(define (user-login-name) - (or (%user-login-name) - (error "Cannot get your name"))) - -;;; PID - -(import-os-error-syscall pid () "scsh_getpid") -(import-os-error-syscall parent-pid () "scsh_getppid") -;;; Process groups and session ids -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import-os-error-syscall process-group () "scsh_getpgrp") - -(import-os-error-syscall %set-process-group (pid groupid) "scsh_setpgid") - -(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))) - - -(import-os-error-syscall become-session-leader () "scsh_setsid") - -;;; UMASK - -(import-os-error-syscall set-process-umask (mask) "scsh_umask") - -(define (process-umask) - (let ((m (set-process-umask 0))) - (set-process-umask m) - m)) - - -;;; PROCESS TIMES - -;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away. - - -(import-os-error-syscall process-times/list () "process_times") - -(define (process-times) - (apply values (process-times/list))) - -(import-os-error-syscall cpu-ticks/sec () "cpu_clock_ticks_per_sec") - -;;; 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) - (with-resources-aligned (list cwd-resource euid-resource egid-resource) - (lambda () (fname-op thing))) - (call/fdes thing fd-op))) - - -(import-os-error-syscall %set-file-mode (path mode) "scsh_chmod") - -(import-os-error-syscall %set-fdes-mode (path mode) "scsh_fchmod") - -(define (set-file-mode thing mode) - (generic-file-op thing - (lambda (fd) (%set-fdes-mode fd mode)) - (lambda (fname) (%set-file-mode fname mode)))) - - -(import-os-error-syscall set-file-uid&gid (path uid gid) "scsh_chown") - -(import-os-error-syscall set-fdes-uid&gid (fd uid gid) "scsh_fchown") - -(define (set-file-owner thing uid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid fd uid -1)) - (lambda (fname) (set-file-uid&gid fname uid -1)))) - -(define (set-file-group thing gid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid fd -1 gid)) - (lambda (fname) (set-file-uid&gid fname -1 gid)))) - - -;;; Uses real uid and gid, not effective. I don't use this anywhere. - -(import-os-error-syscall %file-ruid-access-not? (path perms) "scsh_access") - -;(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)) - - -(import-os-error-syscall %create-hard-link (original-name new-name) - "scsh_link") - -(import-os-error-syscall %create-fifo (path mode) "scsh_mkfifo") - -(import-os-error-syscall %%create-directory (path mode) "scsh_mkdir") - -(define (%create-directory path . maybe-mode) - (let ((mode (:optional maybe-mode #o777)) - (fname (ensure-file-name-is-nondirectory path))) - (%%create-directory fname mode))) - -(import-os-error-syscall %read-symlink (path) "scsh_readlink") - -(import-os-error-syscall %rename-file (old-name new-name) "scsh_rename") - -(import-os-error-syscall %delete-directory (path) "scsh_rmdir") - -(import-os-error-syscall %utime (path ac m) "scm_utime") - -(import-os-error-syscall %utime-now (path) "scm_utime_now") - -;;; (SET-FILE-TIMES path [access-time mod-time]) - -(define (set-file-times path . maybe-times) - (with-resources-aligned - (list cwd-resource euid-resource egid-resource) - (lambda () - (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 path access-time - mod-time )) - (%utime-now path))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; STAT - -(import-os-error-syscall stat-file (path data chase?) "scheme_stat") - -(import-os-error-syscall 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?) - (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. - -(import-os-error-syscall %create-symlink (old-name new-name) "scsh_symlink") - -;;; "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. - -(import-os-error-syscall %truncate-file (path length) "scsh_truncate") - -(import-os-error-syscall %truncate-fdes (path length) "scsh_ftruncate") - -(define (truncate-file thing length) - (generic-file-op thing - (lambda (fd) (%truncate-fdes fd length)) - (lambda (fname) (%truncate-file fname length)))) - -(import-os-error-syscall %delete-file (path) "scsh_unlink") - -(define (delete-file path) - (with-resources-aligned (list cwd-resource euid-resource egid-resource) - (lambda () (%delete-file path)))) - -(import-os-error-syscall %sync-file (fd) "scsh_fsync") - -(define (sync-file fd/port) - (if (output-port? fd/port) (force-output fd/port)) - (sleazy-call/fdes fd/port %sync-file)) - - -;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys. -(import-os-error-syscall sync-file-system () "scsh_sync") - -;;; I/O -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import-os-error-syscall %close-fdes (fd) "scsh_close") - -(import-os-error-syscall %dup (fd) "scsh_dup") - -(import-os-error-syscall %dup2 (fd-from fd-to) "scsh_dup2") - -(import-os-error-syscall %fd-seek (fd offset whence) "scsh_lseek") - - -(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)))) - (%fd-seek fd offset whence))) - -(define (tell fd/port) - (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port)))) - (%fd-seek fd 0 seek/delta))) - -(import-os-error-syscall %char-ready-fdes? (fd) "char_ready_fdes") - -(import-os-error-syscall %open (path flags mode) "scsh_open") - -(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666 - (with-resources-aligned - (list cwd-resource umask-resource euid-resource egid-resource) - (lambda () - (%open path flags (:optional maybe-mode #o666))))) - - -(import-os-error-syscall 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))) - -;;; Signals (rather incomplete) -;;; --------------------------- - -(import-os-error-syscall 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 sigevents 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) - - -;;; 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-os-error-syscall - %uid->user-info - (uid user-info-record) - "user_info_uid") - -(import-os-error-syscall - %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-os-error-syscall - %gid->group-info - (gid group-info-record) - "group_info_gid") - -(import-os-error-syscall - %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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import-os-error-syscall %open-dir (dir-name) "directory_files") - -(define (directory-files . args) - (with-resources-aligned - (list cwd-resource euid-resource egid-resource) - (lambda () - (let-optionals args ((dir ".") - (dotfiles? #f)) - (check-arg string? dir directory-files) - (let* ((files (%open-dir (ensure-file-name-is-nondirectory dir))) - (files-sorted ((structure-ref sort sort-list!) files filename<=))) - (if dotfiles? files-sorted - (filter (lambda (f) (not (dotfile? f))) - files-sorted))))))) - -(define (dotfile? f) - (char=? (string-ref f 0) #\.)) - -(define (filename<= f1 f2) - (if (dotfile? f1) - (if (dotfile? f2) - (string<= f1 f2) - #t) - (if (dotfile? f2) - #f - (string<= f1 f2)))) - -; A record for directory streams. It just has the name and a byte vector -; containing the C directory object. The name is used only for printing. - -(define-record directory-stream - name - c-dir) - -(define-record-discloser type/directory-stream - (lambda (ds) - (list 'directory-stream (directory-stream:name ds)))) - -; Directory streams are meaningless in a resumed image. -(define-record-resumer type/directory-stream #f) - -(define (open-directory-stream name) - (let ((dir (make-directory-stream - name - (with-resources-aligned - (list cwd-resource euid-resource egid-resource) - (lambda () - (open-dir name)))))) - (add-finalizer! dir close-directory-stream) - dir)) - -(define (read-directory-stream dir-stream) - (read-dir (directory-stream:c-dir dir-stream))) - -(define (close-directory-stream dir-stream) - (let ((c-dir (directory-stream:c-dir dir-stream))) - (if c-dir - (begin - (close-dir c-dir) - (set-directory-stream:c-dir dir-stream #f))))) - -(import-os-error-syscall open-dir (name) "scm_opendir") -(import-os-error-syscall close-dir (dir-stream) "scm_closedir") -(import-os-error-syscall read-dir (dir-stream) "scm_readdir") - - -;;; 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) "=" - (let ((val (cdr var.val))) - (if (string? val) val - (string-join val ":"))))) - alist))) - -;;; ENV->ALIST - -(import-os-error-syscall %load-env () "scm_envvec") - -(define (environ-env->alist) - (let ((env-list.envvec (%load-env))) - (cons (env-list->alist (car env-list.envvec)) - (cdr env-list.envvec)))) - - -;;; ALIST->ENV - -;;; (%create-env ((vector 'X) -> address)) -(import-os-error-syscall %create-env (envvec) "create_env") - -;;; assumes aligned env -(define (envvec-alist->env alist) - (%create-env (alist->env-vec alist))) - -(import-os-error-syscall %align-env (envvec) "align_env") - -(import-os-error-syscall %free-env (envvec) "free_envvec") - - -;;; Fd-ports -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import-os-error-syscall %set-cloexec (fd val) "set_cloexec") - -;;; Some of fcntl() -;;;;;;;;;;;;;;;;;;; - -(import-os-error-syscall %fcntl-read (fd command) "fcntl_read") -(import-os-error-syscall %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 (process-sleep secs) (process-sleep-until (+ secs (time)))) - -(define (process-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))))) - -(import-os-error-syscall %sleep-until (secs) "sleep_until") - -(import-os-error-syscall %gethostname () "scm_gethostname") - -(define system-name %gethostname) - -(import-os-error-syscall errno-msg (i) "errno_msg") - -(import-os-error-syscall %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))) - -(define-record uname - os-name - node-name - release - version - machine) - -(define-exported-binding "uname-record-type" type/uname) - -(import-os-error-syscall uname () "scm_uname") diff --git a/scsh/system.scm b/scsh/system.scm new file mode 100644 index 0000000..a3e3e52 --- /dev/null +++ b/scsh/system.scm @@ -0,0 +1,14 @@ +(import-os-error-syscall %gethostname () "scm_gethostname") + +(define system-name %gethostname) + +(define-record uname + os-name + node-name + release + version + machine) + +(define-exported-binding "uname-record-type" type/uname) + +(import-os-error-syscall uname () "scm_uname") diff --git a/scsh/temp-file.scm b/scsh/temp-file.scm new file mode 100644 index 0000000..e404915 --- /dev/null +++ b/scsh/temp-file.scm @@ -0,0 +1,95 @@ +(define (call/temp-file writer user) + (let ((fname #f)) + (dynamic-wind + (lambda () (if fname (error "Can't wind back into a CALL/TEMP-FILE") + (set! fname (create-temp-file)))) + (lambda () + (with-output-to-file fname writer) + (user fname)) + (lambda () (if fname (delete-file fname)))))) + +;;; Create a new temporary file and return its name. +;;; The optional argument specifies the filename prefix to use, and defaults +;;; to "/tmp/.", where is the current process' id. The procedure +;;; scans through the files named 0, 1, ... until it finds a +;;; filename that doesn't exist in the filesystem. It creates the file with +;;; permission #o600, and returns the filename. +;;; + +(define (create-temp-file . maybe-prefix) + (let ((oflags (bitwise-ior open/write + (bitwise-ior open/create open/exclusive)))) + (apply temp-file-iterate + (lambda (fname) + (close-fdes (open-fdes fname oflags #o600)) + fname) + (if (null? maybe-prefix) '() + (list (string-append (constant-format-string (car maybe-prefix)) + ".~a")))))) + +(define (initial-temp-file) + (let ((tmpdir (getenv "TMPDIR"))) + (string-append + (if tmpdir + tmpdir + "/var/tmp") + "/" + (number->string (pid)) + "~a"))) + +(define *temp-file-template* (make-fluid 'not-initialized-temp-file-template)) + +(define temp-file-reinitializer + (make-reinitializer + (lambda () + (set-fluid! *temp-file-template* (initial-temp-file))))) + +(define (temp-file-iterate maker . maybe-template) + (let ((template (:optional maybe-template (fluid *temp-file-template*)))) + (let loop ((i 0)) + (if (> i 1000) (error "Can't create temp-file") + (let ((fname (format #f template (number->string i)))) + (receive retvals (with-errno-handler + ((errno data) + ((errno/exist errno/acces) #f)) + (maker fname)) + (if (car retvals) (apply values retvals) + (loop (+ i 1))))))))) + + + +;; Double tildes in S. +;; Using the return value as a format string will output exactly S. +(define (constant-format-string s) ; Ugly code. Would be much clearer + (let* ((len (string-length s)) ; if written with string SRFI. + (tilde? (lambda (s i) (char=? #\~ (string-ref s i)))) + (newlen (do ((i (- len 1) (- i 1)) + (ans 0 (+ ans (if (tilde? s i) 2 1)))) + ((< i 0) ans))) + (fs (make-string newlen))) + (let lp ((i 0) (j 0)) + (cond ((< i len) + (let ((j (cond ((tilde? s i) (string-set! fs j #\~) (+ j 1)) + (else j)))) + (string-set! fs j (string-ref s i)) + (lp (+ i 1) (+ j 1)))))) + fs)) + + +;;; Roughly equivalent to (pipe). +;;; Returns two file ports [iport oport] open on a temp file. +;;; Use this when you may have to buffer large quantities between +;;; writing and reading. Note that if the consumer gets ahead of the +;;; producer, it won't hang waiting for input, it will just return +;;; EOF. To play it safe, make sure that the producer runs to completion +;;; before starting the consumer. +;;; +;;; The temp file is deleted before TEMP-FILE-CHANNEL returns, so as soon +;;; as the ports are closed, the file's disk storage is reclaimed. + +(define (temp-file-channel) + (let* ((fname (create-temp-file)) + (iport (open-input-file fname)) + (oport (open-output-file fname))) + (delete-file fname) + (values iport oport))) diff --git a/scsh/top.scm b/scsh/top.scm index db17937..ae48c1f 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -323,7 +323,21 @@ (lambda () ;; environment,umask and cwd are already installed by resumers ;; c.f. {env,umask,env}-reinitializer in scsh.scm - (init-scsh-vars interactive?) + (init-home-directory + (cond ((getenv "HOME")) + ;; loosing at this point would be really bad, so some + ;; paranoia comes in order + (else (call-with-current-continuation + (lambda (k) + (with-handler + (lambda (condition more) + (cond ((not interactive?) + (display "Starting up with no home directory ($HOME).") + (newline))) + (k "/")) + (lambda () + (user-info:home-dir (user-info (user-uid)))))))))) + (init-exec-path-list interactive?) (start-new-session context (current-input-port) (current-output-port) diff --git a/scsh/user-group.scm b/scsh/user-group.scm new file mode 100644 index 0000000..80eaf9f --- /dev/null +++ b/scsh/user-group.scm @@ -0,0 +1,119 @@ +;;; 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-os-error-syscall + %uid->user-info + (uid user-info-record) + "user_info_uid") + +(import-os-error-syscall + %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))) + +(define home-directory "") + +(define (init-home-directory home) + (set! home-directory home)) + +(define (home-dir . maybe-user) + (if (pair? maybe-user) + (let ((user (car maybe-user))) + (ensure-file-name-is-nondirectory + (or (%homedir user) + (error "Cannot get user's home directory" + user)))) + home-directory)) + +;;; (home-file [user] fname) + +(define (home-file arg1 . maybe-arg2) + (receive (dir fname) + (if (pair? maybe-arg2) + (values (home-dir arg1) (car maybe-arg2)) + (values home-directory arg1)) + (string-append (file-name-as-directory dir) fname))) + +;;; 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-os-error-syscall + %gid->group-info + (gid group-info-record) + "group_info_gid") + +(import-os-error-syscall + %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))) + diff --git a/scsh/utilities.scm b/scsh/utilities.scm index 817cf7d..2e2b024 100644 --- a/scsh/utilities.scm +++ b/scsh/utilities.scm @@ -1,6 +1,11 @@ ;;; Random useful utilities. ;;; Copyright (c) 1993 by Olin Shivers. +(define-syntax define-simple-syntax + (syntax-rules () + ((define-simple-syntax (name . pattern) result) + (define-syntax name (syntax-rules () ((name . pattern) result)))))) + (define (mapv f v) (let* ((len (vector-length v)) (ans (make-vector len))) @@ -131,4 +136,28 @@ (obtain-lock next) (lp (list next) (delete next locks eq?)))))))) - +;;; Should be moved to somewhere else +(define (with-lock lock thunk) + (dynamic-wind + (lambda () + (release-lock lock)) + thunk + (lambda () + (release-lock lock)))) + +(define (stringify thing) + (cond ((string? thing) thing) + ((symbol? thing) + (symbol->string thing)) +; ((symbol? thing) +; (list->string (map char-downcase +; (string->list (symbol->string thing))))) + ((integer? thing) + (number->string thing)) + (else (error "Can only stringify strings, symbols, and integers." + thing)))) + +(define (bogus-substring-spec? s start end) + (or (< start 0) + (< (string-length s) end) + (< end start))) \ No newline at end of file