;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; process.scm - manage sub-processes. ;;; Copyright 2001 Rob Browning ;;; ;;; 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, contact: ;;; ;;; Free Software Foundation Voice: +1-617-542-5942 ;;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652 ;;; Boston, MA 02111-1307, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-module (gnucash process)) (export gnc:run-sub-process) (export gnc:cleanup-sub-process) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Run the program specified by path with the given args as a ;;; sub-proces. If envt is not #f, then use it as the sub-process ;;; environment (as per execle in the guile info pages). Note that ;;; you must specify the path explicitly. ;;; ;;; Returns #f on failure, or ;;; (pid child-output-pipe child-input-pipe child-standard-error-pipe) ;;; on success. Right now the standard-error pipe is always #f. ;;; ;;; For example: ;;; ;;; (run-sub-process #f "/bin/date" "/bin/date" "--rfc-822") ;;; (define (gnc:run-sub-process envt path . args) (let ((parent-to-child-pipe (false-if-exception (pipe))) (child-to-parent-pipe (false-if-exception (pipe)))) (if (not (and parent-to-child-pipe child-to-parent-pipe)) #f (let* ((parent-read-pipe (car child-to-parent-pipe)) (parent-write-pipe (cdr parent-to-child-pipe)) (child-read-pipe (car parent-to-child-pipe)) (child-write-pipe (cdr child-to-parent-pipe)) (pid (false-if-exception (primitive-fork)))) (setvbuf parent-write-pipe _IONBF) (setvbuf child-write-pipe _IONBF) (if (not (zero? pid)) ;; we're the parent (begin (close-input-port child-read-pipe) (close-output-port child-write-pipe) (list pid parent-read-pipe parent-write-pipe #f)) ;; else we're the child (begin ;; set standard-input and standard-output at the fd ;; level -- which is really all that matters since ;; we're about to exec... (set-batch-mode?! #t) (close-all-ports-except child-read-pipe child-write-pipe) ;;(close-input-port parent-read-pipe) ;;(close-output-port parent-write-pipe) (dup->fdes child-read-pipe 0) (dup->fdes child-write-pipe 1) ;; now launch the child process. (or (false-if-exception (if envt (apply execle path envt args) (apply execl path args))) (exit 1)))))))) (define (gnc:cleanup-sub-process pid clean-secs) ;; Try to be nice, until it's time not to be nice. If this function ;; returns, child is dead dead dead. Returns child result status ;; (i.e. the status from waitpid) (let ((waitopt (logior WNOHANG WUNTRACED))) (let loop ((wait-result (waitpid pid waitopt)) (kill-level #f)) (if (not (zero? (car wait-result))) wait-result (begin (cond ;; one more chance to die quietly. ((not kill-level) (sleep clean-secs) (loop (waitpid pid waitopt) SIGINT)) ;; whip out the hammer. ((= kill-level SIGINT) (kill pid SIGINT) (sleep clean-secs) (loop (waitpid pid waitopt) SIGKILL)) ;; cut the cord on the piano. (else (kill pid SIGKILL) (sleep clean-secs) (loop (waitpid pid waitopt) SIGKILL)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Random test code. ;;; ; (define (get-1-quote exchange . items) ; (let ((cmd (apply list 'fetch exchange items)) ; (quoter (run-sub-process #f ; "./scmio-finance-quote" ; "./scmio-finance-quote"))) ; (and quoter ; (write cmd (caddr quoter)) ; (newline (caddr quoter)) ; (force-output (caddr quoter)) ; (let ((result (read (cadr quoter)))) ; (close-input-port (cadr quoter)) ; (close-output-port (caddr quoter)) ; result)))) ; (define (parrot) ; (let loop ((input (false-if-exception (read)))) ; (cond ; ((eof-object? input) (quit 0)) ; ((not input) (quit 0)) ; (else (write input) ; (force-output) ; (loop (read)))))) ; (define (launch-parrot envt path args) ; ;; Returns (pid child-input-port child-output-port child-error-port) ; ;; Right now the error port is broken... ; (let* ((pid #f) ; (sockets (false-if-exception (socketpair AF_UNIX SOCK_STREAM 0)))) ; (if sockets ; (set! pid (false-if-exception (primitive-fork)))) ; (cond ; ((not pid) #f) ; ((= pid 0) ; ;; We're the child. ; ;; set standard-input and standard-output, swapping input and ; ;; output sockets from parent... ; (display 'foo) (newline) (flush-all-ports) ; ;;(redirect-port (car sockets) (current-input-port)) ; (set-current-input-port (cdr sockets)) ; (display 'bar) (newline) (flush-all-ports) ; ;;(redirect-port (cdr sockets) (current-output-port)) ; (set-current-output-port (cdr sockets)) ; (parrot)) ; ; (or (false-if-exception ; ; (if envt ; ; (apply execle path envt args) ; ; (apply execl path args))) ; ; (exit 1))) ; (else ; ;; we're the parent ; ;; child-input-port child-output-port child-error-port ; (list pid (car sockets) #f))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This code was part of an attempt to just return one ;;; read-write-port for the child, but I had some trouble getting it ;;; to work. I think either (1) this was misguided from the start ;;; since you can't hook up the plumbing this way, or (2) I was ;;; forgetting some flushing or something somewhere that kept it from ;;; working. At one point, I knew which of these two options was ;;; true, but I can't recall what I concluded now, so I'll leave the ;;; code here in case we want to resurrect it... ; (define (run-sub-process envt path . args) ; (let ((pid #f) ; (sockets (false-if-exception (socketpair AF_UNIX SOCK_STREAM 0)))) ; (if sockets ; (set! pid (false-if-exception (primitive-fork)))) ; (cond ; ((or (not sockets) (not pid)) #f) ; ((= pid 0) ; ;; We're the child: set standard-input and standard-output to be ; ;; the socket that's connected to the parent. ; (set-current-input-port (cdr sockets)) ; (set-current-output-port (cdr sockets)) ; (dup->fdes (cdr sockets) 0) ; (dup->fdes (cdr sockets) 1) ; ;; now launch the child process. ; (or (false-if-exception ; (if envt ; (apply execle path envt args) ; (apply execl path args))) ; (exit 1))) ; (else ; ;; we're the parent ; (list pid (car sockets) #f)))))