r16017 - gnucash/trunk/src/scm - Drop process.scm and spawn perl to retrieve price quotes.
Andreas Köhler
andi5 at cvs.gnucash.org
Sat Apr 28 15:13:51 EDT 2007
Author: andi5
Date: 2007-04-28 15:13:47 -0400 (Sat, 28 Apr 2007)
New Revision: 16017
Trac: http://svn.gnucash.org/trac/changeset/16017
Removed:
gnucash/trunk/src/scm/process.scm
Modified:
gnucash/trunk/src/scm/Makefile.am
gnucash/trunk/src/scm/price-quotes.scm
Log:
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.
Modified: gnucash/trunk/src/scm/Makefile.am
===================================================================
--- gnucash/trunk/src/scm/Makefile.am 2007-04-28 19:13:43 UTC (rev 16016)
+++ gnucash/trunk/src/scm/Makefile.am 2007-04-28 19:13:47 UTC (rev 16017)
@@ -4,7 +4,7 @@
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 \
Modified: gnucash/trunk/src/scm/price-quotes.scm
===================================================================
--- gnucash/trunk/src/scm/price-quotes.scm 2007-04-28 19:13:43 UTC (rev 16016)
+++ gnucash/trunk/src/scm/price-quotes.scm 2007-04-28 19:13:47 UTC (rev 16017)
@@ -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
Deleted: gnucash/trunk/src/scm/process.scm
===================================================================
--- gnucash/trunk/src/scm/process.scm 2007-04-28 19:13:43 UTC (rev 16016)
+++ gnucash/trunk/src/scm/process.scm 2007-04-28 19:13:47 UTC (rev 16017)
@@ -1,221 +0,0 @@
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; process.scm - manage sub-processes.
-;;; Copyright 2001 Rob Browning <rlb at 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 at 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)))))
More information about the gnucash-changes
mailing list