From c38bcd3ed70e88bfc026e758b4c68d08cd608b34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Andreas=20K=C3=B6hler?= Date: Sat, 28 Apr 2007 19:13:47 +0000 Subject: [PATCH] Drop process.scm and spawn perl to retrieve price quotes. 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-97b8803252fd --- src/scm/Makefile.am | 2 +- src/scm/price-quotes.scm | 114 ++++++++++---------- src/scm/process.scm | 221 --------------------------------------- 3 files changed, 54 insertions(+), 283 deletions(-) delete mode 100644 src/scm/process.scm diff --git a/src/scm/Makefile.am b/src/scm/Makefile.am index 8523333052..4d71c18620 100644 --- a/src/scm/Makefile.am +++ b/src/scm/Makefile.am @@ -4,7 +4,7 @@ SUBDIRS = gnumeric gncscmdir = ${GNC_SCM_INSTALL_DIR} gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash -gncscmmod_DATA = process.scm main.scm price-quotes.scm +gncscmmod_DATA = main.scm price-quotes.scm gnc_regular_scm_files = \ command-line.scm \ diff --git a/src/scm/price-quotes.scm b/src/scm/price-quotes.scm index e6a3039a8b..f4c6a49a9a 100644 --- a/src/scm/price-quotes.scm +++ b/src/scm/price-quotes.scm @@ -26,7 +26,6 @@ (export gnc:book-add-quotes) ;; called from gnome/dialog-price-edit-db.c (export gnc:price-quotes-install-sources) -(use-modules (gnucash process)) (use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing. (use-modules (gnucash gnc-module)) (use-modules (gnucash core-utils)) @@ -244,32 +243,30 @@ (g-find-program-in-path "gnc-fq-check")) (define (gnc:fq-check-sources) - (let ((program #f)) + (let ((program '()) + (from-child #f)) (define (start-program) - (set! program (gnc:run-sub-process #f - gnc:*finance-quote-check* - gnc:*finance-quote-check*))) + (if (not (null? gnc:*finance-quote-check*)) + (set! program (gnc-spawn-process-async + (list "perl" "-w" gnc:*finance-quote-check*) #t)))) (define (get-sources) - (and program - (let ((from-child (cadr program)) - (results #f)) - (catch - #t - (lambda () - (set! results (read from-child)) - (gnc:debug (list 'results results)) - results) - (lambda (key . args) - key))))) + (if (not (null? program)) + (let ((results #f)) + (set! from-child (fdes->inport (gnc-process-get-fd program 1))) + (catch + #t + (lambda () + (set! results (read from-child)) + (gnc:debug (list 'results results)) + results) + (lambda (key . args) + key))))) (define (kill-program) - (and program - (let ((pid (car program))) - (close-input-port (cadr program)) - (close-output-port (caddr program)) - (gnc:cleanup-sub-process (car program) 1)))) + (if (not (null? program)) + (gnc-detach-process program #t))) (dynamic-wind start-program @@ -329,46 +326,45 @@ ;; was unparsable. See the gnc-fq-helper for more details ;; about it's output. - (let ((quoter #f)) + (let ((quoter '()) + (to-child #f) + (from-child #f)) (define (start-quoter) - (set! quoter (gnc:run-sub-process #f - gnc:*finance-quote-helper* - gnc:*finance-quote-helper*))) + (if (not (null? gnc:*finance-quote-helper*)) + (set! quoter (gnc-spawn-process-async + (list "perl" "-w" gnc:*finance-quote-helper*) #t)))) (define (get-quotes) - (and quoter - (let ((to-child (caddr quoter)) - (from-child (cadr quoter)) - (results #f)) - (map - (lambda (request) - (catch - #t - (lambda () - (gnc:debug (list 'handling-request request)) - ;; we need to display the first element (the method, so it - ;; won't be quoted) and then write the rest - (display #\( to-child) - (display (car request) to-child) - (display " " to-child) - (for-each (lambda (x) (write x to-child)) (cdr request)) - (display #\) to-child) - (newline to-child) - (force-output to-child) - (set! results (read from-child)) - (gnc:debug (list 'results results)) - results) - (lambda (key . args) - key))) + (if (not (null? quoter)) + (let ((results #f)) + (set! to-child (fdes->outport (gnc-process-get-fd quoter 0))) + (set! from-child (fdes->inport (gnc-process-get-fd quoter 1))) + (map + (lambda (request) + (catch + #t + (lambda () + (gnc:debug (list 'handling-request request)) + ;; we need to display the first element (the method, so it + ;; won't be quoted) and then write the rest + (display #\( to-child) + (display (car request) to-child) + (display " " to-child) + (for-each (lambda (x) (write x to-child)) (cdr request)) + (display #\) to-child) + (newline to-child) + (force-output to-child) + (set! results (read from-child)) + (gnc:debug (list 'results results)) + results) + (lambda (key . args) + key))) requests)))) (define (kill-quoter) - (and quoter - (let ((pid (car quoter))) - (close-input-port (cadr quoter)) - (close-output-port (caddr quoter)) - (gnc:cleanup-sub-process (car quoter) 1)))) + (if (not (null? quoter)) + (gnc-detach-process quoter #t))) (dynamic-wind start-quoter @@ -519,13 +515,9 @@ (reverse result-list))))) (define (timestr->time-pair timestr time-zone) - (let ((broken-down (strptime "%Y-%m-%d %H:%M:%S" timestr))) - (if (not (= (string-length timestr) (cdr broken-down))) - #f - (cons (car (if time-zone - (mktime (car broken-down) time-zone) - (mktime (car broken-down)))) - 0)))) + ;; time-zone is ignored currently + (cons (gnc-parse-time-to-timet timestr "%Y-%m-%d %H:%M:%S") + 0)) (define (commodity-tz-quote-triple->price book c-tz-quote-triple) ;; return a string like "NASDAQ:CSCO" on error, or a price on diff --git a/src/scm/process.scm b/src/scm/process.scm deleted file mode 100644 index ddb97aaa51..0000000000 --- a/src/scm/process.scm +++ /dev/null @@ -1,221 +0,0 @@ -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 -;;; 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)))))