1207 lines
36 KiB
Scheme
1207 lines
36 KiB
Scheme
;;; 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 ()
|
||
(with-handler
|
||
(lambda (c more)
|
||
(display-condition c (current-error-port))
|
||
(exit 1))
|
||
(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)
|
||
(set-current-input-port! r))
|
||
(else ; Child
|
||
(close r)
|
||
(move->fdes w 1)
|
||
(if maybe-thunk
|
||
(with-current-output-port
|
||
w
|
||
(call-terminally maybe-thunk))
|
||
(set-current-output-port! w))))
|
||
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/<pid>.", where <pid> is the current process' id. The procedure
|
||
;;; scans through the files named <prefix>0, <prefix>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 (current-input-port) 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))
|
||
|