mirror of https://github.com/Gnucash/gnucash
Use gnc_spawn_process_async, gnc_process_get_fd, gnc_detach_process and gnc_parse_time_to_timet in price-quotes.scm, but leave the work-flow basically as before. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@16017 57a11ea4-9604-0410-9ed3-97b8803252fdzzzoldfeatures/dogtail
Andreas Köhler
19 years ago
parent
94dc306411
commit
c38bcd3ed7
@ -1,221 +0,0 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; process.scm - manage sub-processes.
|
||||
;;; Copyright 2001 Rob Browning <rlb@cs.utexas.edu>
|
||||
;;;
|
||||
;;; 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
|
||||
;;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
||||
;;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-module (gnucash process))
|
||||
|
||||
(use-modules (gnucash main))
|
||||
(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)))
|
||||
)
|
||||
|
||||
(if (not pid)
|
||||
(begin
|
||||
(gnc:error "Failed to fork child process.")
|
||||
#f)
|
||||
(begin
|
||||
(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)))))
|
||||
Loading…
Reference in new issue