From: Chris Hanson Date: Fri, 29 Jan 1999 22:45:54 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~4663 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a6016c935445c609f95e6157f2f1f3ab06a15f21;p=mit-scheme.git Initial revision --- diff --git a/v7/src/runtime/syncproc.scm b/v7/src/runtime/syncproc.scm new file mode 100644 index 000000000..10b08342c --- /dev/null +++ b/v7/src/runtime/syncproc.scm @@ -0,0 +1,255 @@ +#| -*-Scheme-*- + +$Id: syncproc.scm,v 1.1 1999/01/29 22:45:54 cph Exp $ + +Copyright (c) 1999 Massachusetts Institute of Technology + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at +your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +|# + +;;;; Synchronous Subprocess Support +;;; package: (runtime synchronous-subprocess) + +(declare (usual-integrations)) + +(define-structure (subprocess-context + (keyword-constructor make-subprocess-context) + (conc-name subprocess-context/)) + ;; Where to get input data to send to the subprocess. Either an + ;; input port, or #F meaning that nothing is to be sent. + (input #f read-only #t) + ;; How to do line translation on data sent to the subprocess. + (input-line-translation 'DEFAULT read-only #t) + ;; Where to put output data that is received from the subprocess. + ;; Either an output port, or #F meaning to discard any output. + (output (current-output-port) read-only #t) + ;; How to do line translation on data received from the subprocess. + (output-line-translation 'DEFAULT read-only #t) + ;; A thunk that is periodically called while the subprocess is + ;; running, to allow the calling program to notice output from the + ;; subprocess and show it to the user. Can also be #F. + (redisplay-hook #f read-only #t) + ;; An environment to pass to the subprocess. Usually #F. + (environment #f read-only #t) + ;; A working directory for the subprocess. #F means current working + ;; directory. + (working-directory #f read-only #t) + ;; Whether to use PTYs to talk to the subprocess (if supported by + ;; the operating system). + (use-pty? #f read-only #t) + ;; The name of the shell interpreter. + (shell-file-name (os/shell-file-name) read-only #t)) + +(define (run-shell-command command #!optional context) + (let ((context + (if (or (default-object? context) (not context)) + (make-subprocess-context) + context))) + (run-synchronous-process (subprocess-context/shell-file-name context) + (os/form-shell-command command) + context))) + +(define (run-synchronous-process program arguments #!optional context) + (let* ((context + (if (or (default-object? context) (not context)) + (make-subprocess-context) + context)) + (directory (subprocess-context/working-directory context)) + (process #f)) + (bind-condition-handler '() + (lambda (condition) + (if (and process (not (eq? process 'DELETED))) + (begin + (subprocess-delete process) + (set! process 'DELETED))) + (signal-condition condition)) + (lambda () + (set! process + ((if (and (subprocess-context/use-pty? context) + ((ucode-primitive have-ptys? 0))) + start-pty-subprocess + start-pipe-subprocess) + (os/find-program program directory) + (list->vector (cons (file-namestring program) arguments)) + (let ((environment (subprocess-context/environment context))) + (if directory + (cons environment (->namestring directory)) + environment)))) + (let loop () + (let* ((status (synchronous-process-wait process context)) + (reason (subprocess-exit-reason process))) + (subprocess-delete process) + (set! process 'DELETED) + (case status + ((EXITED) + (if (not (eqv? 0 reason)) + (error:subprocess-exited process reason))) + ((SIGNALLED) + (error:subprocess-signalled process reason)) + ((STOPPED) + (subprocess-kill process) + (subprocess-wait process) + (error:subprocess-stopped process reason)) + ((RUNNING) + (loop)) + (else + (error "Unknown subprocess status:" status))))))))) + +(define condition-type:subprocess-abnormal-termination + (make-condition-type 'SUBPROCESS-ABNORMAL-TERMINATION condition-type:error + '(SUBPROCESS REASON) + #f)) + +(define (abnormal-termination-type name message) + (make-condition-type name + condition-type:subprocess-abnormal-termination + '() + (lambda (condition port) + (write-string "Subprocess " port) + (write (access-condition condition 'SUBPROCESS) port) + (write-string " " port) + (write-string message port) + (write-string " " port) + (write (access-condition condition 'REASON) port) + (write-string "." port)))) + +(define condition-type:subprocess-stopped + (abnormal-termination-type 'SUBPROCESS-STOPPED "stopped with signal")) + +(define error:subprocess-stopped + (condition-signaller condition-type:subprocess-stopped + '(SUBPROCESS REASON) + standard-error-handler)) + +(define condition-type:subprocess-signalled + (abnormal-termination-type 'SUBPROCESS-SIGNALLED "terminated with signal")) + +(define error:subprocess-signalled + (condition-signaller condition-type:subprocess-signalled + '(SUBPROCESS REASON) + standard-error-handler)) + +(define condition-type:subprocess-exited + (abnormal-termination-type 'SUBPROCESS-EXITED "exited abnormally with code")) + +(define error:subprocess-exited + (condition-signaller condition-type:subprocess-exited + '(SUBPROCESS REASON) + standard-error-handler)) + +(define (synchronous-process-wait process context) + ;; Initialize the subprocess line-translation appropriately. + (subprocess-i/o-port process + (subprocess-context/output-line-translation context) + (subprocess-context/input-line-translation context)) + (let ((redisplay-hook (subprocess-context/redisplay-hook context))) + (call-with-input-copier process + (subprocess-context/input context) + (subprocess-context/output context) + 512 + (lambda (copy-input) + (call-with-output-copier process + (subprocess-context/output context) + (subprocess-context/input context) + 512 + (lambda (copy-output) + (if copy-input + (if copy-output + (begin + (if redisplay-hook (redisplay-hook)) + (let loop () + (copy-input) + (let ((n (copy-output))) + (cond ((not n) + (loop)) + ((> n 0) + (if redisplay-hook (redisplay-hook)) + (loop)))))) + (do () ((eqv? (copy-input) 0)))) + (if copy-output + (begin + (if redisplay-hook (redisplay-hook)) + (do () + ((= (copy-output) 0)) + (if redisplay-hook (redisplay-hook))))))))))) + (subprocess-wait process)) + +(define (call-with-input-copier process process-input nonblock? bsize receiver) + (let ((port (subprocess-output-port process))) + (let ((output-port/close (port/operation port 'CLOSE-OUTPUT))) + (if process-input + (handle-broken-pipe process + (lambda () + (if nonblock? + ((port/operation port 'SET-OUTPUT-BLOCKING-MODE) + port 'NONBLOCKING)) + (receiver + (let ((buffer (make-string bsize))) + (lambda () + (port/with-input-blocking-mode process-input 'BLOCKING + (lambda () + (let ((n + (input-port/read-string! process-input buffer))) + (if (> n 0) + (output-port/write-substring port buffer 0 n) + (begin + (output-port/close port) + 0)))))))))) + (begin + (output-port/close port) + (receiver #f)))))) + +(define (handle-broken-pipe process thunk) + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:system-call-error) + (lambda (condition) + (if (and (eq? 'WRITE (system-call-name condition)) + (eq? 'BROKEN-PIPE (system-call-error condition))) + (continuation (subprocess-wait process)))) + thunk)))) + +(define system-call-name + (condition-accessor condition-type:system-call-error 'SYSTEM-CALL)) + +(define system-call-error + (condition-accessor condition-type:system-call-error 'ERROR-TYPE)) + +(define (call-with-output-copier process process-output nonblock? bsize + receiver) + (let ((port (subprocess-input-port process))) + (let ((input-port/open? (port/operation port 'INPUT-OPEN?)) + (input-port/close (port/operation port 'CLOSE-INPUT))) + (if process-output + (let ((buffer (make-string bsize))) + (let ((copy-output + (lambda () + (let ((n (input-port/read-string! port buffer))) + (if (and n (> n 0)) + (port/with-output-blocking-mode process-output + 'BLOCKING + (lambda () + (output-port/write-substring + process-output buffer 0 n)))) + n)))) + (if nonblock? (port/set-input-blocking-mode port 'NONBLOCKING)) + (let ((status (receiver copy-output))) + (if (and nonblock? (input-port/open? port)) + (begin + (port/set-input-blocking-mode port 'BLOCKING) + (do () ((= (copy-output) 0))) + (input-port/close port))) + status))) + (receiver #f))))) \ No newline at end of file