home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / syncproc.scm < prev    next >
Text File  |  1999-04-19  |  9KB  |  255 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: syncproc.scm,v 1.8 1999/04/20 01:09:54 cph Exp $
  4.  
  5. Copyright (c) 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Synchronous Subprocess Support
  23. ;;; package: (runtime synchronous-subprocess)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (load-option 'SUBPROCESS)
  28.  
  29. (define-structure (subprocess-context
  30.            (keyword-constructor make-subprocess-context)
  31.            (conc-name subprocess-context/))
  32.   ;; Where to get input data to send to the subprocess.  Either an
  33.   ;; input port, or #F meaning that nothing is to be sent.
  34.   (input #f read-only #t)
  35.   ;; How to do line translation on data sent to the subprocess.
  36.   (input-line-translation 'DEFAULT read-only #t)
  37.   ;; What size is the input buffer?
  38.   (input-buffer-size 512 read-only #t)
  39.   ;; Where to put output data that is received from the subprocess.
  40.   ;; Either an output port, or #F meaning to discard any output.
  41.   (output (current-output-port) read-only #t)
  42.   ;; How to do line translation on data received from the subprocess.
  43.   (output-line-translation 'DEFAULT read-only #t)
  44.   ;; What size is the output buffer?
  45.   (output-buffer-size 512 read-only #t)
  46.   ;; A thunk that is periodically called while the subprocess is
  47.   ;; running, to allow the calling program to notice output from the
  48.   ;; subprocess and show it to the user.  Can also be #F.
  49.   (redisplay-hook #f read-only #t)
  50.   ;; An environment to pass to the subprocess.  Usually #F.
  51.   (environment #f read-only #t)
  52.   ;; A working directory for the subprocess.  #F means current working
  53.   ;; directory.
  54.   (working-directory #f read-only #t)
  55.   ;; Whether to use PTYs to talk to the subprocess (if supported by
  56.   ;; the operating system).
  57.   (use-pty? #f read-only #t)
  58.   ;; The name of the shell interpreter.
  59.   (shell-file-name (os/shell-file-name) read-only #t))
  60.  
  61. (define (run-shell-command command . options)
  62.   (let ((context (apply make-subprocess-context options)))
  63.     (run-synchronous-subprocess-1 (subprocess-context/shell-file-name context)
  64.                   (os/form-shell-command command)
  65.                   context)))
  66.  
  67. (define (run-synchronous-subprocess program arguments . options)
  68.   (run-synchronous-subprocess-1 program arguments
  69.                 (apply make-subprocess-context options)))
  70.  
  71. (define (run-synchronous-subprocess-1 program arguments context)
  72.   (let ((directory
  73.      (let ((directory (subprocess-context/working-directory context)))
  74.        (if directory
  75.            (merge-pathnames directory)
  76.            (working-directory-pathname))))
  77.     (process #f))
  78.     (bind-condition-handler '()
  79.     (lambda (condition)
  80.       (if (and process (not (eq? process 'DELETED)))
  81.           (begin
  82.         (subprocess-delete process)
  83.         (set! process 'DELETED)))
  84.       (signal-condition condition))
  85.       (lambda ()
  86.     (set! process
  87.           ((if (and (subprocess-context/use-pty? context)
  88.             ((ucode-primitive have-ptys? 0)))
  89.            start-pty-subprocess
  90.            start-pipe-subprocess)
  91.            (os/find-program program directory)
  92.            (list->vector (cons (file-namestring program) arguments))
  93.            (let ((environment (subprocess-context/environment context)))
  94.          (if directory
  95.              (cons environment (->namestring directory))
  96.              environment))))
  97.     (let loop ()
  98.       (let* ((status (synchronous-process-wait process context))
  99.          (reason (subprocess-exit-reason process))
  100.          (p process))
  101.         (subprocess-delete process)
  102.         (set! process 'DELETED)
  103.         (case status
  104.           ((EXITED)
  105.            reason)
  106.           ((SIGNALLED)
  107.            (error:subprocess-signalled p reason))
  108.           ((STOPPED)
  109.            (subprocess-kill p)
  110.            (subprocess-wait p)
  111.            (error:subprocess-stopped p reason))
  112.           ((RUNNING)
  113.            (loop))
  114.           (else
  115.            (error "Unknown subprocess status:" status)))))))))
  116.  
  117. (define condition-type:subprocess-abnormal-termination
  118.   (make-condition-type 'SUBPROCESS-ABNORMAL-TERMINATION condition-type:error
  119.       '(SUBPROCESS REASON)
  120.     #f))
  121.  
  122. (define (abnormal-termination-type name message)
  123.   (make-condition-type name
  124.       condition-type:subprocess-abnormal-termination
  125.       '()
  126.     (lambda (condition port)
  127.       (write-string "Subprocess " port)
  128.       (write (access-condition condition 'SUBPROCESS) port)
  129.       (write-string " " port)
  130.       (write-string message port)
  131.       (write-string " " port)
  132.       (write (access-condition condition 'REASON) port)
  133.       (write-string "." port))))
  134.  
  135. (define condition-type:subprocess-stopped
  136.   (abnormal-termination-type 'SUBPROCESS-STOPPED "stopped with signal"))
  137.  
  138. (define error:subprocess-stopped
  139.   (condition-signaller condition-type:subprocess-stopped
  140.                '(SUBPROCESS REASON)
  141.                standard-error-handler))
  142.  
  143. (define condition-type:subprocess-signalled
  144.   (abnormal-termination-type 'SUBPROCESS-SIGNALLED "terminated with signal"))
  145.  
  146. (define error:subprocess-signalled
  147.   (condition-signaller condition-type:subprocess-signalled
  148.                '(SUBPROCESS REASON)
  149.                standard-error-handler))
  150.  
  151. (define (synchronous-process-wait process context)
  152.   ;; Initialize the subprocess line-translation appropriately.
  153.   (subprocess-i/o-port process
  154.                (subprocess-context/output-line-translation context)
  155.                (subprocess-context/input-line-translation context))
  156.   (let ((redisplay-hook (subprocess-context/redisplay-hook context)))
  157.     (call-with-input-copier process
  158.                 (subprocess-context/input context)
  159.                 (subprocess-context/output context)
  160.                 (subprocess-context/input-buffer-size context)
  161.       (lambda (copy-input)
  162.     (call-with-output-copier process
  163.                  (subprocess-context/output context)
  164.                  (subprocess-context/input context)
  165.                  (subprocess-context/output-buffer-size
  166.                   context)
  167.       (lambda (copy-output)
  168.         (if copy-input
  169.         (if copy-output
  170.             (begin
  171.               (if redisplay-hook (redisplay-hook))
  172.               (let loop ()
  173.             (copy-input)
  174.             (let ((n (copy-output)))
  175.               (cond ((not n)
  176.                  (loop))
  177.                 ((> n 0)
  178.                  (if redisplay-hook (redisplay-hook))
  179.                  (loop))))))
  180.             (do () ((eqv? (copy-input) 0))))
  181.         (if copy-output
  182.             (begin
  183.               (if redisplay-hook (redisplay-hook))
  184.               (do ()
  185.               ((= (copy-output) 0))
  186.             (if redisplay-hook (redisplay-hook)))))))))))
  187.   (subprocess-wait process))
  188.  
  189. (define (call-with-input-copier process process-input nonblock? bsize receiver)
  190.   (let ((port (subprocess-output-port process)))
  191.     (let ((output-port/close (port/operation port 'CLOSE-OUTPUT)))
  192.       (if process-input
  193.       (handle-broken-pipe process
  194.         (lambda ()
  195.           (if nonblock?
  196.           ((port/operation port 'SET-OUTPUT-BLOCKING-MODE)
  197.            port 'NONBLOCKING))
  198.           (receiver
  199.            (let ((buffer (make-string bsize)))
  200.          (lambda ()
  201.            (port/with-input-blocking-mode process-input 'BLOCKING
  202.              (lambda ()
  203.                (let ((n
  204.                   (input-port/read-string! process-input buffer)))
  205.              (if (> n 0)
  206.                  (output-port/write-substring port buffer 0 n)
  207.                  (begin
  208.                    (output-port/close port)
  209.                    0))))))))))
  210.       (begin
  211.         (output-port/close port)
  212.         (receiver #f))))))
  213.  
  214. (define (handle-broken-pipe process thunk)
  215.   (call-with-current-continuation
  216.    (lambda (continuation)
  217.      (bind-condition-handler (list condition-type:system-call-error)
  218.      (lambda (condition)
  219.        (if (and (eq? 'WRITE (system-call-name condition))
  220.             (eq? 'BROKEN-PIPE (system-call-error condition)))
  221.            (continuation (subprocess-wait process))))
  222.        thunk))))
  223.  
  224. (define system-call-name
  225.   (condition-accessor condition-type:system-call-error 'SYSTEM-CALL))
  226.  
  227. (define system-call-error
  228.   (condition-accessor condition-type:system-call-error 'ERROR-TYPE))
  229.  
  230. (define (call-with-output-copier process process-output nonblock? bsize
  231.                  receiver)
  232.   (let ((port (subprocess-input-port process)))
  233.     (let ((input-port/open? (port/operation port 'INPUT-OPEN?))
  234.       (input-port/close (port/operation port 'CLOSE-INPUT)))
  235.       (if process-output
  236.       (let ((buffer (make-string bsize)))
  237.         (let ((copy-output
  238.            (lambda ()
  239.              (let ((n (input-port/read-string! port buffer)))
  240.                (if (and n (> n 0))
  241.                (port/with-output-blocking-mode process-output
  242.                                'BLOCKING
  243.                  (lambda ()
  244.                    (output-port/write-substring
  245.                 process-output buffer 0 n))))
  246.                n))))
  247.           (if nonblock? (port/set-input-blocking-mode port 'NONBLOCKING))
  248.           (let ((status (receiver copy-output)))
  249.         (if (and nonblock? (input-port/open? port))
  250.             (begin
  251.               (port/set-input-blocking-mode port 'BLOCKING)
  252.               (do () ((= (copy-output) 0)))
  253.               (input-port/close port)))
  254.         status)))
  255.       (receiver #f)))))