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 / process.scm < prev    next >
Text File  |  2000-05-13  |  12KB  |  377 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: process.scm,v 1.26 2000/05/14 03:31:11 cph Exp $
  4.  
  5. Copyright (c) 1989-2000 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. ;;;; Subprocess Support
  23. ;;; package: (runtime subprocess)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define subprocess-finalizer)
  28. (define scheme-subprocess-environment)
  29. (define global-status-tick)
  30.  
  31. (define (initialize-package!)
  32.   (set! subprocess-finalizer
  33.     (make-gc-finalizer (ucode-primitive process-delete 1) #t))
  34.   (reset-package!)
  35.   (add-event-receiver! event:after-restore reset-package!)
  36.   (add-event-receiver! event:before-exit delete-all-processes))
  37.  
  38. (define (reset-package!)
  39.   (set! scheme-subprocess-environment ((ucode-primitive scheme-environment 0)))
  40.   (set! global-status-tick (cons #f #f))
  41.   unspecific)
  42.  
  43. (define (delete-all-processes)
  44.   (for-each subprocess-delete (subprocess-list)))
  45.  
  46. (define (subprocess-list)
  47.   (gc-finalizer-elements subprocess-finalizer))
  48.  
  49. (define-structure (subprocess
  50.            (constructor %make-subprocess
  51.                 (filename arguments index pty-master
  52.                       input-channel output-channel))
  53.            (conc-name subprocess-))
  54.   (filename #f read-only #t)
  55.   (arguments #f read-only #t)
  56.   index
  57.   pty-master
  58.   input-channel
  59.   output-channel
  60.   (id ((ucode-primitive process-id 1) index) read-only #t)
  61.   (%i/o-port #f)
  62.   (%status #f)
  63.   (exit-reason #f)
  64.   (%status-tick #f)
  65.   (properties (make-1d-table) read-only #t))
  66.  
  67. (define (subprocess-get process key)
  68.   (1d-table/get (subprocess-properties process) key #f))
  69.  
  70. (define (subprocess-put! process key datum)
  71.   (1d-table/put! (subprocess-properties process) key datum))
  72.  
  73. (define (subprocess-remove! process key)
  74.   (1d-table/remove! (subprocess-properties process) key))
  75.  
  76. (define (subprocess-i/o-port process #!optional
  77.                  input-line-translation output-line-translation)
  78.   (let* ((input-line-translation
  79.       (if (default-object? input-line-translation)
  80.           'DEFAULT
  81.           input-line-translation))
  82.      (output-line-translation
  83.       (if (default-object? output-line-translation)
  84.           input-line-translation
  85.           output-line-translation)))
  86.     (without-interrupts
  87.      (lambda ()
  88.        (or (subprocess-%i/o-port process)
  89.        (let ((port
  90.           (let ((input-channel (subprocess-input-channel process))
  91.             (output-channel (subprocess-output-channel process)))
  92.             (if input-channel
  93.             (if output-channel
  94.                 (make-generic-i/o-port input-channel output-channel
  95.                            512 512
  96.                            input-line-translation
  97.                            output-line-translation)
  98.                 (make-generic-input-port input-channel
  99.                              512
  100.                              input-line-translation))
  101.             (if output-channel
  102.                 (make-generic-output-port output-channel
  103.                               512
  104.                               output-line-translation)
  105.                 #f)))))
  106.          (set-subprocess-%i/o-port! process port)
  107.          port))))))
  108.  
  109. (define (subprocess-input-port process)
  110.   (let ((port (subprocess-i/o-port process)))
  111.     (and (input-port? port)
  112.      port)))
  113.  
  114. (define (subprocess-output-port process)
  115.   (let ((port (subprocess-i/o-port process)))
  116.     (and (output-port? port)
  117.      port)))
  118.  
  119. (define (close-subprocess-i/o process)
  120.   (without-interrupts (lambda () (%close-subprocess-i/o process))))
  121.  
  122. (define (%close-subprocess-i/o process)
  123.   ;; Assumes that interrupts are locked.
  124.   (cond ((subprocess-%i/o-port process)
  125.      => (lambda (port)
  126.           (set-subprocess-%i/o-port! process #f)
  127.           (set-subprocess-input-channel! process #f)
  128.           (set-subprocess-output-channel! process #f)
  129.           (close-port port))))
  130.   (cond ((subprocess-input-channel process)
  131.      => (lambda (input-channel)
  132.           (set-subprocess-input-channel! process #f)
  133.           (channel-close input-channel))))
  134.   (cond ((subprocess-output-channel process)
  135.      => (lambda (output-channel)
  136.           (set-subprocess-output-channel! process #f)
  137.           (channel-close output-channel))))
  138.   (cond ((subprocess-pty-master process)
  139.      => (lambda (pty-master)
  140.           (set-subprocess-pty-master! process #f)
  141.           (channel-close pty-master)))))
  142.  
  143. (define (make-subprocess filename arguments environment
  144.              ctty stdin stdout stderr
  145.              pty-master input-channel output-channel)
  146.   (let ((process
  147.      (let ((ctty-allowed? (string? ctty)))
  148.        (define-integrable (convert-stdio-arg stdio)
  149.          (cond ((not stdio) #f)
  150.            ((eq? stdio 'INHERIT) -1)
  151.            ((and ctty-allowed? (eq? stdio 'CTTY)) -2)
  152.            ((channel? stdio) (channel-descriptor stdio))
  153.            (else
  154.             (error:wrong-type-argument stdio "process I/O channel"
  155.                            'MAKE-SUBPROCESS))))
  156.        (let ((working-directory #f)
  157.          (ctty
  158.           (cond ((eq? ctty 'BACKGROUND) -1)
  159.             ((eq? ctty 'FOREGROUND) -2)
  160.             ((or (not ctty) (string? ctty)) ctty)
  161.             (else
  162.              (error:wrong-type-argument
  163.               ctty
  164.               "process controlling terminal"
  165.               'MAKE-SUBPROCESS))))
  166.          (stdin (convert-stdio-arg stdin))
  167.          (stdout (convert-stdio-arg stdout))
  168.          (stderr (convert-stdio-arg stderr)))
  169.          (if (pair? environment)
  170.          (begin
  171.            (set! working-directory
  172.              (and (cdr environment)
  173.                   (->namestring (cdr environment))))
  174.            (set! environment (car environment))))
  175.          (without-interrupts
  176.           (lambda ()
  177.         (let ((index
  178.                (os/make-subprocess filename arguments environment
  179.                        working-directory ctty
  180.                        stdin stdout stderr)))
  181.           (let ((process
  182.              (%make-subprocess filename arguments index pty-master
  183.                        input-channel output-channel)))
  184.             (set-subprocess-%status!
  185.              process
  186.              ((ucode-primitive process-status 1) index))
  187.             (set-subprocess-exit-reason!
  188.              process
  189.              ((ucode-primitive process-reason 1) index))
  190.             (add-to-gc-finalizer! subprocess-finalizer process index)
  191.             process))))))))
  192.     (if (and (eq? ctty 'FOREGROUND)
  193.          (eqv? (%subprocess-status process) 0))
  194.     (subprocess-continue-foreground process))
  195.     process))
  196.  
  197. (define (subprocess-delete process)
  198.   (without-interrupts
  199.    (lambda ()
  200.      (if (subprocess-index process)
  201.      (begin
  202.        (remove-from-gc-finalizer! subprocess-finalizer process)
  203.        (set-subprocess-index! process #f)
  204.        (%close-subprocess-i/o process))))))
  205.  
  206. (define (subprocess-status process)
  207.   (convert-subprocess-status (%subprocess-status process)))
  208.  
  209. (define (subprocess-wait process)
  210.   (let loop ()
  211.     ((ucode-primitive process-wait 1) (subprocess-index process))
  212.     (let ((status (%subprocess-status process)))
  213.       (if (eqv? status 0)
  214.       (loop)
  215.       (convert-subprocess-status status)))))
  216.  
  217. (define (subprocess-continue-foreground process)
  218.   (let loop ()
  219.     ((ucode-primitive process-continue-foreground 1)
  220.      (subprocess-index process))
  221.     (let ((status (%subprocess-status process)))
  222.       (if (eqv? status 0)
  223.       (loop)
  224.       (convert-subprocess-status status)))))
  225.  
  226. (define (%subprocess-status process)
  227.   (without-interrupts
  228.    (lambda ()
  229.      (let ((index (subprocess-index process)))
  230.        (if (and index ((ucode-primitive process-status-sync 1) index))
  231.        (begin
  232.          (set-subprocess-%status!
  233.           process
  234.           ((ucode-primitive process-status 1) index))
  235.          (set-subprocess-exit-reason!
  236.           process
  237.           ((ucode-primitive process-reason 1) index))
  238.          (set-subprocess-%status-tick! process #f))))))
  239.   (subprocess-%status process))
  240.  
  241. (define (subprocess-status-tick process)
  242.   (or (subprocess-%status-tick process)
  243.       (let ((tick (cons #f #f)))
  244.     (set-subprocess-%status-tick! process tick)
  245.     tick)))
  246.  
  247. (define (subprocess-global-status-tick)
  248.   (without-interrupts
  249.    (lambda ()
  250.      (if ((ucode-primitive process-status-sync-all 0))
  251.      (let ((tick (cons #f #f)))
  252.        (set! global-status-tick tick)
  253.        tick)
  254.      global-status-tick))))
  255.  
  256. (define (convert-subprocess-status status)
  257.   (case status
  258.     ((0) 'RUNNING)
  259.     ((1) 'STOPPED)
  260.     ((2) 'EXITED)
  261.     ((3) 'SIGNALLED)
  262.     (else (error "Illegal process status:" status))))
  263.  
  264. (define (subprocess-job-control-status process)
  265.   (let ((n
  266.      ((ucode-primitive process-job-control-status 1)
  267.       (subprocess-index process))))
  268.     (case n
  269.       ((0) 'NO-CTTY)
  270.       ((1) 'UNRELATED-CTTY)
  271.       ((2) 'NO-JOB-CONTROL)
  272.       ((3) 'JOB-CONTROL)
  273.       (else (error "Illegal process job-control status:" n)))))
  274.  
  275. (define (handle-subprocess-status-change)
  276.   (if (eq? 'NT microcode-id/operating-system)
  277.       (for-each (lambda (process)
  278.           (if (memq (subprocess-status process) '(EXITED SIGNALLED))
  279.               (close-subprocess-i/o process)))
  280.         (subprocess-list))))
  281.  
  282. (define-integrable subprocess-job-control-available?
  283.   (ucode-primitive os-job-control? 0))
  284.  
  285. (define (subprocess-continue-background process)
  286.   ((ucode-primitive process-continue-background 1) (subprocess-index process)))
  287.  
  288. (define (subprocess-signal process signal)
  289.   ((ucode-primitive process-signal 2) (subprocess-index process) signal))
  290.  
  291. (define (subprocess-kill process)
  292.   ((ucode-primitive process-kill 1) (subprocess-index process))
  293.   (maybe-close-subprocess-i/o process))
  294.  
  295. (define (subprocess-interrupt process)
  296.   ((ucode-primitive process-interrupt 1) (subprocess-index process)))
  297.  
  298. (define (subprocess-quit process)
  299.   ((ucode-primitive process-quit 1) (subprocess-index process)))
  300.  
  301. (define (subprocess-hangup process)
  302.   ((ucode-primitive process-hangup 1) (subprocess-index process))
  303.   (maybe-close-subprocess-i/o process))
  304.  
  305. (define (maybe-close-subprocess-i/o process)
  306.   (if (eq? 'NT microcode-id/operating-system)
  307.       (close-subprocess-i/o process)))
  308.  
  309. (define (subprocess-stop process)
  310.   ((ucode-primitive process-stop 1) (subprocess-index process)))
  311.  
  312. (define (start-batch-subprocess filename arguments environment)
  313.   (make-subprocess filename arguments environment
  314.            #f #f #f #f
  315.            #f #f #f))
  316.  
  317. (define (start-subprocess-in-background filename arguments environment)
  318.   (make-subprocess filename arguments environment
  319.            'BACKGROUND 'INHERIT 'INHERIT 'INHERIT
  320.            #f #f #f))
  321.  
  322. (define (run-subprocess-in-foreground filename arguments environment)
  323.   (make-subprocess filename arguments environment
  324.            'FOREGROUND 'INHERIT 'INHERIT 'INHERIT
  325.            #f #f #f))
  326.  
  327. (define (start-pipe-subprocess filename arguments environment)
  328.   (with-values make-pipe
  329.     (lambda (child-read parent-write)
  330.       (with-values make-pipe
  331.     (lambda (parent-read child-write)
  332.       (let ((process
  333.          (make-subprocess filename arguments environment
  334.                   #f child-read child-write child-write
  335.                   #f parent-read parent-write)))
  336.         (channel-close child-read)
  337.         (channel-close child-write)
  338.         process))))))
  339.  
  340. (define (start-pty-subprocess filename arguments environment)
  341.   (with-values open-pty-master
  342.     (lambda (master-channel master-name slave-name)
  343.       master-name
  344.       (make-subprocess filename arguments environment
  345.                slave-name 'CTTY 'CTTY 'CTTY
  346.                master-channel master-channel master-channel))))
  347.  
  348. ;;;; Environment Bindings
  349.  
  350. (define (process-environment-bind environment . bindings)
  351.   (let ((bindings* (vector->list environment)))
  352.     (for-each (lambda (binding)
  353.         (let ((b
  354.                (find-environment-variable
  355.             (environment-binding-name binding)
  356.             bindings*)))
  357.           (if b
  358.               (set-car! b binding)
  359.               (begin
  360.             (set! bindings* (cons binding bindings*))
  361.             unspecific))))
  362.           bindings)
  363.     (list->vector bindings*)))
  364.  
  365. (define (environment-binding-name binding)
  366.   (let ((index (string-find-next-char binding #\=)))
  367.     (if (not index)
  368.     binding
  369.     (string-head binding index))))
  370.  
  371. (define (find-environment-variable name bindings)
  372.   (let ((prefix (string-append name "=")))
  373.     (let loop ((bindings bindings))
  374.       (and (not (null? bindings))
  375.        (if (string-prefix? prefix (car bindings))
  376.            bindings
  377.            (loop (cdr bindings)))))))