gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Tue Aug 13 06:52:20 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/2a6a4e34 (commit)
via https://github.com/Gnucash/gnucash/commit/e15f2610 (commit)
via https://github.com/Gnucash/gnucash/commit/4a4f81b3 (commit)
via https://github.com/Gnucash/gnucash/commit/5e866377 (commit)
via https://github.com/Gnucash/gnucash/commit/d5122c97 (commit)
via https://github.com/Gnucash/gnucash/commit/fab1c8db (commit)
via https://github.com/Gnucash/gnucash/commit/112cf99d (commit)
via https://github.com/Gnucash/gnucash/commit/a42f1211 (commit)
via https://github.com/Gnucash/gnucash/commit/81b20d0a (commit)
via https://github.com/Gnucash/gnucash/commit/0c3f460e (commit)
from https://github.com/Gnucash/gnucash/commit/55e196ab (commit)
commit 2a6a4e34d608f227ceff37d5383c73c182289e80
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Aug 11 09:06:35 2019 +0800
[price-quotes] compact commodity-tz-quote-triple->price
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index f7ffb9574..c8ec2cbdb 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -335,26 +335,18 @@
(string? symbol)
(gnc-commodity-table-lookup commodity-table "ISO4217"
(string-upcase symbol)))))
- (set! commodity other-curr))
- )
- (or-map (lambda (price-sym)
- (let ((p (assq-ref quote-data price-sym)))
- (if p
- (begin (set! price p)
- (set! price-type price-sym)
- #t)
- #f)))
- '(last nav price))
-
- (set! price-type
- (case price-type
- ((last) "last")
- ((nav) "nav")
- ((price) "unknown")
- (else #f)))
-
- (if price
- (set! price (gnc-scm-to-numeric price)))
+ (set! commodity other-curr)))
+
+ (let lp ((price-syms '(last nav price))
+ (price-types '("last" "nav" "unknown")))
+ (unless (null? price-syms)
+ (cond
+ ((assq-ref quote-data (car price-syms)) =>
+ (lambda (p)
+ (set! price (gnc-scm-to-numeric p))
+ (set! price-type (car price-types))))
+ (else (lp (cdr price-syms) (cdr price-types))))))
+
(if gnc-time
(set! gnc-time (timestr->time64 gnc-time time-zone))
(set! gnc-time (gnc:get-today)))
@@ -402,11 +394,9 @@
(let ((pricedb (gnc-pricedb-get-db book)))
(for-each
(lambda (price)
- (if price
- (begin
- (gnc-pricedb-add-price pricedb price)
- (gnc-price-unref price)
- #f)))
+ (when price
+ (gnc-pricedb-add-price pricedb price)
+ (gnc-price-unref price)))
prices)))
(define (show-error msg)
commit e15f2610ba712bb26a5885c290d1f2aaede6b510
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Aug 10 23:33:00 2019 +0800
[price-quotes] compact gnc:book-add-quotes
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index e6df019f6..f7ffb9574 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -409,149 +409,125 @@
#f)))
prices)))
+ (define (show-error msg)
+ (gnc:gui-error msg (_ msg)))
+
;; Add the alphavantage api key to the environment. This value is taken from
;; the Online Quotes preference tab
- (let* ((alphavantage-api-key (gnc-prefs-get-string "general.finance-quote" "alphavantage-api-key")))
- (gnc:debug (string-concatenate (list "ALPHAVANTAGE_API_KEY=" alphavantage-api-key)))
- (if (not (string-null? alphavantage-api-key))
- (setenv "ALPHAVANTAGE_API_KEY" alphavantage-api-key)))
-
- ;; FIXME: uses of gnc:warn in here need to be cleaned up. Right
- ;; now, they'll result in funny formatting.
+ (let ((alphavantage-api-key
+ (gnc-prefs-get-string "general.finance-quote" "alphavantage-api-key")))
+ (gnc:debug "ALPHAVANTAGE_API_KEY=" alphavantage-api-key)
+ (unless (string-null? alphavantage-api-key)
+ (setenv "ALPHAVANTAGE_API_KEY" alphavantage-api-key)))
(let* ((fq-call-data (book->commodity->fq-call-data book))
(fq-calls (and fq-call-data
- (apply append
- (map fq-call-data->fq-calls fq-call-data))))
+ (append-map fq-call-data->fq-calls fq-call-data)))
(fq-results (and fq-calls (gnc:fq-get-quotes fq-calls)))
- (commod-tz-quote-triples
- (and fq-results (list? (car fq-results))
- (fq-results->commod-tz-quote-triples fq-call-data fq-results)))
+ (commod-tz-quote-triples (and fq-results (list? (car fq-results))
+ (fq-results->commod-tz-quote-triples
+ fq-call-data fq-results)))
;; At this point commod-tz-quote-triples will either be #f or a
;; list of items. Each item will either be (commodity
;; timezone quote-data) or (#f . problem-commodity)
- (problem-syms
- (and commod-tz-quote-triples
- (filter-map (lambda (cq-pair)
- (if (car cq-pair)
- #f
- (string-append
- (gnc-commodity-get-namespace (cdr cq-pair))
- ":"
- (gnc-commodity-get-mnemonic (cdr cq-pair)))))
- commod-tz-quote-triples)))
+ (problem-syms (and commod-tz-quote-triples
+ (filter-map
+ (lambda (cq-pair)
+ (and (not (car cq-pair))
+ (string-append
+ (gnc-commodity-get-namespace (cdr cq-pair))
+ ":"
+ (gnc-commodity-get-mnemonic (cdr cq-pair)))))
+ commod-tz-quote-triples)))
;; strip out the "bad" ones from above.
- (ok-syms
- (and commod-tz-quote-triples
- (filter car commod-tz-quote-triples)))
+ (ok-syms (and commod-tz-quote-triples (filter car commod-tz-quote-triples)))
(keep-going? #t))
(cond
- ((eq? fq-call-data #f)
+ ((not fq-call-data)
(set! keep-going? #f)
- (if (gnucash-ui-is-running)
- (gnc-error-dialog window (_ "No commodities marked for quote retrieval."))
- (gnc:warn "No commodities marked for quote retrieval.")))
- ((eq? fq-results #f)
+ (show-error (N_ "No commodities marked for quote retrieval.")))
+
+ ((not fq-results)
(set! keep-going? #f)
- (if (gnucash-ui-is-running)
- (gnc-error-dialog window (_ "Unable to get quotes or diagnose the problem."))
- (gnc:warn "Unable to get quotes or diagnose the problem.")))
- ((member 'missing-lib fq-results)
+ (show-error (N_ "Unable to get quotes or diagnose the problem.")))
+
+ ((memq 'missing-lib fq-results)
(set! keep-going? #f)
- (if (gnucash-ui-is-running)
- (gnc-error-dialog window
- (_ "You are missing some needed Perl libraries.
-Run 'gnc-fq-update' as root to install them."))
- (gnc:warn "You are missing some needed Perl libraries.
-Run 'gnc-fq-update' as root to install them." "\n")))
- ((member 'system-error fq-results)
+ (show-error (N_ "You are missing some needed Perl libraries.
+Run 'gnc-fq-update' as root to install them.")))
+
+ ((memq 'system-error fq-results)
(set! keep-going? #f)
- (if (gnucash-ui-is-running)
- (gnc-error-dialog window
- (_ "There was a system error while retrieving the price quotes."))
- (gnc:warn "There was a system error while retrieving the price quotes." "\n")))
+ (show-error (N_ "There was a system error while retrieving the price quotes.")))
+
((not (list? (car fq-results)))
(set! keep-going? #f)
- (if (gnucash-ui-is-running)
- (gnc-error-dialog window
- (_ "There was an unknown error while retrieving the price quotes."))
- (gnc:warn "There was an unknown error while retrieving the price quotes." "\n")))
- ((and (not commod-tz-quote-triples) (gnucash-ui-is-running))
- (gnc-error-dialog window
- (_ "Unable to get quotes or diagnose the problem."))
- (set! keep-going? #f))
+ (show-error (N_ "There was an unknown error while retrieving the price quotes.")))
+
((not commod-tz-quote-triples)
- (gnc:warn "Unable to get quotes or diagnose the problem.")
- (set! keep-going? #f))
- ((not (null? problem-syms))
- (if (gnucash-ui-is-running)
- (if (and ok-syms (not (null? ok-syms)))
- (set!
- keep-going?
- (gnc-verify-dialog window #t
- (call-with-output-string
- (lambda (p)
- (display (_ "Unable to retrieve quotes for these items:") p)
- (newline p)
- (display " " p)
- (display (string-join problem-syms "\n ") p)
- (newline p)
- (display (_ "Continue using only the good quotes?") p)))))
- (begin
- (gnc-error-dialog window
- (call-with-output-string
- (lambda (p)
- (display
- (_ "Unable to retrieve quotes for these items:") p)
- (newline p)
- (display " " p)
- (display (string-join problem-syms "\n ") p))))
- (set! keep-going? #f)))
- (gnc:warn
- (call-with-output-string
- (lambda (p)
- (display "Unable to retrieve quotes for these items:" p)
- (newline p)
- (display " " p)
- (display (string-join problem-syms "\n ") p)
- (newline p)
- (display "Continuing with good quotes." p)
- (newline p)))))))
-
- (if
- keep-going?
- (let ((prices (map (lambda (triple)
- (commodity-tz-quote-triple->price book triple))
- ok-syms)))
- (if (any string? prices)
- (if (gnucash-ui-is-running)
- (set!
- keep-going?
- (gnc-verify-dialog window #t
- (call-with-output-string
- (lambda (p)
- (display (_ "Unable to create prices for these items:") p)
- (newline p)
- (display " " p)
- (display (string-join (filter string? prices) "\n ") p)
- (newline p)
- (display (_ "Add remaining good quotes?") p)))))
- (gnc:warn
- (call-with-output-string
- (lambda (p)
- (display "Unable to create prices for these items:" p)
- (newline p)
- (display " " p)
- (display (string-join (filter string? prices) "\n ") p)
- (newline p)
- (display "Adding remaining good quotes." p)
- (newline p))))))
-
- (if keep-going?
- (book-add-prices! book (filter
- (lambda (x) (not (string? x)))
- prices)))))))
+ (set! keep-going? #f)
+ (show-error (N_ "Unable to get quotes or diagnose the problem.")))
+
+ ((pair? problem-syms)
+ (cond
+ ((not (gnucash-ui-is-running))
+ (gnc:warn
+ (with-output-to-string
+ (lambda ()
+ (display "Unable to retrieve quotes for these items:\n")
+ (display (string-join problem-syms "\n "))
+ (newline)
+ (display "Continuing with good quotes.")
+ (newline)))))
+
+ ((and ok-syms (not (null? ok-syms)))
+ (set! keep-going?
+ (gnc-verify-dialog
+ window #t (with-output-to-string
+ (lambda ()
+ (display (_ "Unable to retrieve quotes for these items:"))
+ (display "\n ")
+ (display (string-join problem-syms "\n "))
+ (newline)
+ (display (_ "Continue using only the good quotes?")))))))
+
+ (else
+ (set! keep-going? #f)
+ (gnc-error-dialog
+ window (with-output-to-string
+ (lambda ()
+ (display (_ "Unable to retrieve quotes for these items:"))
+ (display "\n ")
+ (display (string-join problem-syms "\n ")))))))))
+
+ (when keep-going?
+ (let ((prices (map (lambda (triple)
+ (commodity-tz-quote-triple->price book triple))
+ ok-syms)))
+ (when (any string? prices)
+ (if (gnucash-ui-is-running)
+ (set! keep-going?
+ (gnc-verify-dialog
+ window #t
+ (with-output-to-string
+ (lambda ()
+ (display (_ "Unable to create prices for these items:"))
+ (display "\n ")
+ (display (string-join (filter string? prices) "\n "))
+ (newline)
+ (display (_ "Add remaining good quotes?"))))))
+ (gnc:warn
+ (with-output-to-string
+ (lambda ()
+ (display "Unable to create prices for these items:\n ")
+ (display (string-join (filter string? prices) "\n "))
+ (newline)
+ (display "Adding remaining good quotes.")
+ (newline))))))
+
+ (when keep-going?
+ (book-add-prices! book (filter (negate string?) prices)))))))
(define (gnc:price-quotes-install-sources)
(let ((sources (gnc:fq-check-sources)))
commit 4a4f81b320f814e190ade2e0bf4157597805beba
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Aug 9 21:41:23 2019 +0800
[price-quotes] compact book->commodity->fq-call-data
make function more readable.
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index 017f8d51d..e6df019f6 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -28,40 +28,12 @@
(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash core-utils))
-(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-11)
+ (srfi srfi-1))
(gnc:module-load "gnucash/gnome-utils" 0) ;; for gnucash-ui-is-running
(gnc:module-load "gnucash/app-utils" 0)
-(define (item-list->hash! lst hash
- getkey getval
- hashref hashset
- list-duplicates?)
- ;; Takes a list of the form (item item item item) and returns a hash
- ;; formed by traversing the list, and getting the key and val from
- ;; each item using the supplied get-key and get-val functions, and
- ;; building a hash table from the result using the given hashref and
- ;; hashset functions. list-duplicates? determines whether or not in
- ;; the resulting hash, the value for a given key is a list of all
- ;; the values associated with that key in the input or just the
- ;; first one encountered.
-
- (define (handle-item item)
- (let* ((key (getkey item))
- (val (getval item))
- (existing-val (hashref hash key)))
-
- (if (not list-duplicates?)
- ;; ignore if not first value.
- (if (not existing-val) (hashset hash key val))
- ;; else result is list.
- (if existing-val
- (hashset hash key (cons val existing-val))
- (hashset hash key (list val))))))
-
- (for-each handle-item lst)
- hash)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:*finance-quote-check*
@@ -197,47 +169,39 @@
;; form:
;;
;; (("alphavantage" (commodity-1 currency-1 tz-1)
- ;; (commodity-2 currency-2 tz-2) ...)
+ ;; (commodity-2 currency-2 tz-2) ...)
;; ("fidelity_direct" (commodity-3 currency-3 tz-3)
;; (commodity-4 currency-4 tz-4) ...)
- ;; ...)
-
- (let* ((ct (gnc-commodity-table-get-table book))
- (big-list
- (gnc-commodity-table-get-quotable-commodities
- ct))
- (commodity-list #f)
- (currency-list (filter
- (lambda (a)
- (and
- (not (gnc-commodity-equiv (cadr a) (caddr a)))
- (not (string=? "XXX" (gnc-commodity-get-mnemonic (cadr a))))
- ))
- (call-with-values
- (lambda () (partition!
- (lambda (cmd)
- (not (string=? (car cmd) "currency")))
- big-list))
- (lambda (a b) (set! commodity-list a) b))))
- (quote-hash (make-hash-table 31)))
-
- (if (and (null? commodity-list) (null? currency-list))
- #f
- (begin
-
- ;; Now collect symbols going to the same backend.
- (item-list->hash! commodity-list quote-hash car cdr hash-ref hash-set! #t)
-
- ;; Now translate to just what gnc-fq-helper expects.
- (append
- (hash-fold
- (lambda (key value prior-result)
- (cons (cons key value)
- prior-result))
- '()
- quote-hash)
- (map (lambda (cmd) (cons (car cmd) (list (cdr cmd))))
- currency-list))))))
+ ;; ("currency" curr-1 curr-2 tz)
+ ;; ("currency" curr-3 curr-4 tz) ...)
+
+ (let-values (((currency-list commodity-list)
+ (partition (lambda (a) (string=? (car a) "currency"))
+ (gnc-commodity-table-get-quotable-commodities
+ (gnc-commodity-table-get-table book)))))
+
+ (let ((commodity-hash (make-hash-table))
+ (currency-list-filtered
+ (filter
+ (lambda (a)
+ (and (not (gnc-commodity-equiv (cadr a) (caddr a)))
+ (not (string=? (gnc-commodity-get-mnemonic (cadr a)) "XXX"))))
+ currency-list)))
+
+ ;; Now collect symbols going to the same backend.
+ (for-each
+ (lambda (item)
+ (let ((key (car item))
+ (val (cdr item)))
+ (hash-set! commodity-hash key
+ (cons val (hash-ref commodity-hash key '())))))
+ commodity-list)
+
+ ;; Now translate to just what gnc-fq-helper expects.
+ (append
+ (hash-map->list cons commodity-hash)
+ (map (lambda (cmd) (cons (car cmd) (list (cdr cmd))))
+ currency-list-filtered)))))
(define (fq-call-data->fq-calls fq-call-data)
;; take an output element from book->commodity->fq-call-data and
@@ -246,7 +210,7 @@
;; the latter:
;;
;; ("alphavantage" (commodity-1 currency-1 tz-1)
- ;; (commodity-2 currency-2 tz-2) ...)
+ ;; (commodity-2 currency-2 tz-2) ...)
;;
;; ("alphavantage" "IBM" "AMD" ...)
;;
commit 5e8663772aedb490dffc2f533f5f07a20303e423
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Aug 9 22:49:31 2019 +0800
[price-quotes] compact gnc:fq-get-quotes
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index 4ded8d44e..017f8d51d 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -144,50 +144,43 @@
;; was unparsable. See the gnc-fq-helper for more details
;; about it's output.
- (let ((quoter '())
- (to-child #f)
- (from-child #f))
+ (let ((quoter #f))
(define (start-quoter)
- (if (not (string-null? gnc:*finance-quote-helper*))
- (set! quoter (gnc-spawn-process-async
- (list "perl" "-w" gnc:*finance-quote-helper*) #t))))
+ (set! quoter
+ (gnc-spawn-process-async (list "perl" "-w" gnc:*finance-quote-helper*) #t)))
(define (get-quotes)
- (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 "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 "results: " results)
- results)
- (lambda (key . args)
- key)))
- requests))))
+ (when quoter
+ (map
+ (lambda (request)
+ (catch #t
+ (lambda ()
+ (gnc:debug "handling-request: " request)
+ ;; we need to display the first element (the method,
+ ;; so it won't be quoted) and then write the rest
+ (with-output-to-port (fdes->outport (gnc-process-get-fd quoter 0))
+ (lambda ()
+ (display #\()
+ (display (car request))
+ (display " ")
+ (for-each write (cdr request))
+ (display #\))
+ (newline)
+ (force-output)))
+
+ (let ((results (read (fdes->inport (gnc-process-get-fd quoter 1)))))
+ (gnc:debug "results: " results)
+ results))
+ (lambda (key . args) key)))
+ requests)))
(define (kill-quoter)
- (if (not (null? quoter))
- (gnc-detach-process quoter #t)))
+ (when quoter
+ (gnc-detach-process quoter #t)
+ (set! quoter #f)))
- (dynamic-wind
- start-quoter
- get-quotes
- kill-quoter)))
+ (dynamic-wind start-quoter get-quotes kill-quoter)))
(define (gnc:book-add-quotes window book)
commit d5122c97eaef18c30e7d66d269352929b17c4f24
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Aug 9 22:49:04 2019 +0800
[price-quotes] compact gnc:fq-check-sources
improve locality of vars.
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index dc9e44ce6..4ded8d44e 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -68,35 +68,28 @@
(string-append (gnc-path-get-bindir) "/gnc-fq-check"))
(define (gnc:fq-check-sources)
- (let ((program '())
- (from-child #f))
+ (let ((program #f))
(define (start-program)
- (if (not (string-null? gnc:*finance-quote-check*))
- (set! program (gnc-spawn-process-async
- (list "perl" "-w" gnc:*finance-quote-check*) #t))))
+ (set! program
+ (gnc-spawn-process-async
+ (list "perl" "-w" gnc:*finance-quote-check*) #t)))
(define (get-sources)
- (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 "results: " results)
- results)
- (lambda (key . args)
- key)))))
+ (when program
+ (catch #t
+ (lambda ()
+ (let ((results (read (fdes->inport (gnc-process-get-fd program 1)))))
+ (gnc:debug "gnc:fq-check-sources results: " results)
+ results))
+ (lambda (key . args) key))))
(define (kill-program)
- (if (not (null? program))
- (gnc-detach-process program #t)))
+ (when program
+ (gnc-detach-process program #t)
+ (set! program #f)))
- (dynamic-wind
- start-program
- get-sources
- kill-program)))
+ (dynamic-wind start-program get-sources kill-program)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
commit fab1c8db3e8f3d13555931e57340349dfa481b6c
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Aug 10 23:01:38 2019 +0800
[price-quotes] show if F::Q not installed, remove dead code
diff --git a/libgnucash/scm/price-quotes.scm b/libgnucash/scm/price-quotes.scm
index c12fa35e0..dc9e44ce6 100644
--- a/libgnucash/scm/price-quotes.scm
+++ b/libgnucash/scm/price-quotes.scm
@@ -603,26 +603,15 @@ Run 'gnc-fq-update' as root to install them." "\n")))
(lambda (x) (not (string? x)))
prices)))))))
-; (define (get-1-quote exchange . items)
-; (let ((cmd (apply list 'fetch exchange items))
-; (quoter (run-sub-process #f
-; gnc:*finance-quote-helper*
-; gnc:*finance-quote-helper*)))
-; (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 (gnc:price-quotes-install-sources)
(let ((sources (gnc:fq-check-sources)))
- (if (list? sources)
- (begin
-;; Translators: ~A is the version string
+ (cond
+ ((list? sources)
+ ;; Translators: ~A is the version string
(format #t (_ "Found Finance::Quote version ~A.") (car sources))
(newline)
- (gnc:msg "Found Finance::Quote version " (car sources))
- (gnc-quote-source-set-fq-installed (car sources) (cdr sources))))))
+ (gnc:msg "Found Finance::Quote version " (car sources))
+ (gnc-quote-source-set-fq-installed (car sources) (cdr sources)))
+ (else
+ (display "No Finance::Quote found\n")
+ (gnc:msg "No Finance::Quote found")))))
commit 112cf99d2d0c7a68c71d9085ad911eba93337d9a
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Aug 12 20:37:27 2019 +0800
[test-report-html] add coverage and function test
* function gnc:html-table-add-labeled-amount-line! has full coverage
test.
* function gnc:make-html-acct-table/env/accts has good coverage
confirming nothing crashes.
diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm
index a367b4a56..7e44f36d8 100644
--- a/gnucash/report/report-system/test/test-report-html.scm
+++ b/gnucash/report/report-system/test/test-report-html.scm
@@ -4,10 +4,32 @@
(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system))
+(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash report stylesheets))
(use-modules (srfi srfi-64))
+(use-modules (ice-9 pretty-print))
+(use-modules (sxml simple))
(use-modules (gnucash engine test srfi64-extras))
+(use-modules (system vm coverage))
+
+(define (coverage-test)
+ (let* ((currfile (dirname (current-filename)))
+ (path (string-take currfile (string-rindex currfile #\/))))
+ (add-to-load-path path))
+ (call-with-values
+ (lambda()
+ (with-code-coverage run-test-proper))
+ (lambda (data result)
+ (let ((port (open-output-file "/tmp/lcov.info")))
+ (coverage-data->lcov data port)
+ (close port)))))
(define (run-test)
+ (if #f
+ (coverage-test)
+ (run-test-proper)))
+
+(define (run-test-proper)
(test-runner-factory gnc:test-runner)
(test-begin "Testing/Temporary/test-report-html")
;; if (test-runner-factory gnc:test-runner) is commented out, this
@@ -17,6 +39,8 @@
(test-html-objects)
(test-html-cells)
(test-html-table)
+ (test-gnc:html-table-add-labeled-amount-line!)
+ (test-gnc:make-html-acct-table/env/accts)
(test-end "Testing/Temporary/test-report-html")
)
@@ -776,3 +800,85 @@ HTML Document Title</title></head><body></body>\n\
(test-end "HTML Tables - without style sheets")
)
+
+(define (test-gnc:html-table-add-labeled-amount-line!)
+
+ (define (table->html table)
+ (let ((doc (gnc:make-html-document)))
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-render table doc)))))
+
+ (let ((table (gnc:make-html-table)))
+ (gnc:html-table-add-labeled-amount-line!
+ table #f #f #f "label" #f #f #f #f #f #f #f)
+ (test-equal "gnc:html-table-add-labeled-amount-line!"
+ "<table><tbody><tr><td rowspan=\"1\" colspan=\"1\"><string> <string> label</td>\n<td rowspan=\"1\" colspan=\"1\"><string> </td>\n</tr>\n</tbody>\n</table>\n"
+ (table->html table)))
+
+ (let* ((table (gnc:make-html-table)))
+ (gnc:html-table-add-labeled-amount-line!
+ table 5 "tdd" #t "label1" 1 2 "label-markup"
+ "amount" 3 2 "amount-markup")
+ (test-equal "gnc:html-table-add-labeled-amount-line! all options"
+ "<table><tbody><tdd><label-markup rowspan=\"1\" colspan=\"1\"><string> <string> label1</label-markup>\n<td rowspan=\"1\" colspan=\"1\"><hr /></td>\n<amount-markup rowspan=\"1\" colspan=\"1\"><string> amount</amount-markup>\n<td><string> </td>\n</tdd>\n</tbody>\n</table>\n"
+ (table->html table))))
+
+(define (test-gnc:make-html-acct-table/env/accts)
+
+ ;; create html-document, add table, render, convert to sxml
+ (define (table->sxml table prefix)
+ (let* ((doc (gnc:make-html-document)))
+ (gnc:html-document-set-style-sheet! doc (gnc:html-style-sheet-find "Default"))
+ (gnc:html-document-add-object! doc table)
+ (let ((render (gnc:html-document-render doc)))
+ (with-output-to-file (format #f "/tmp/html-acct-table-~a.html" prefix)
+ (lambda ()
+ (display render)))
+ (xml->sxml render
+ #:trim-whitespace? #t
+ #:entities '((nbsp . "\xa0")
+ (ndash . "Â"))))))
+
+ (let* ((accounts-alist (create-test-data))
+ (accounts (map cdr accounts-alist)))
+
+ (let* ((table (gnc:make-html-table))
+ (get-balance (lambda (acc start-date end-date)
+ (let ((coll (gnc:make-commodity-collector)))
+ (coll 'add (xaccAccountGetCommodity acc) 10)
+ coll)))
+ (acct-table (gnc:make-html-acct-table/env/accts
+ `((get-balance-fn ,get-balance)
+ (display-tree-depth 9))
+ accounts)))
+ (gnc:html-table-add-account-balances table acct-table '())
+ (let ((sxml (table->sxml table "basic - combo 1")))
+ (test-equal "gnc:make-html-acct-table/env/accts combo 1"
+ '("Root" "Asset" "Bank" "GBP Bank" "Wallet" "Liabilities"
+ "Income" "Income-GBP" "Expenses" "Equity")
+ (sxml->table-row-col sxml 1 #f 1))))
+
+ (let* ((table (gnc:make-html-table))
+ (acct-table (gnc:make-html-acct-table/env/accts
+ `((balance-mode pre-closing)
+ (display-tree-depth 9))
+ accounts)))
+ (gnc:html-table-add-account-balances table acct-table '())
+ (let ((sxml (table->sxml table "basic - combo 2")))
+ (test-equal "gnc:make-html-acct-table/env/accts combo 2"
+ '("Root" "Asset" "Bank" "GBP Bank" "Wallet" "Liabilities"
+ "Income" "Income-GBP" "Expenses" "Equity")
+ (sxml->table-row-col sxml 1 #f 1))))
+
+ (let* ((table (gnc:make-html-table))
+ (acct-table (gnc:make-html-acct-table/env/accts
+ '((balance-mode pre-adjusting)
+ (display-tree-depth 9))
+ accounts)))
+ (gnc:html-table-add-account-balances table acct-table '())
+ (let ((sxml (table->sxml table "basic - combo 3")))
+ (test-equal "gnc:make-html-acct-table/env/accts combo 3"
+ '("Root" "Asset" "Bank" "GBP Bank" "Wallet" "Liabilities"
+ "Income" "Income-GBP" "Expenses" "Equity")
+ (sxml->table-row-col sxml 1 #f 1))))))
commit a42f1211d885e3db147781ef7e3f43f3a9ef09fa
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Aug 12 21:15:45 2019 +0800
[html-acct-table] modernise to srfi-9 records
diff --git a/gnucash/report/report-system/html-acct-table.scm b/gnucash/report/report-system/html-acct-table.scm
index 1cf5a4d63..f67129c47 100644
--- a/gnucash/report/report-system/html-acct-table.scm
+++ b/gnucash/report/report-system/html-acct-table.scm
@@ -495,6 +495,8 @@
;; user. This class simply maps its contents to the html-table.
;;
+(use-modules (srfi srfi-9))
+
;; this is to work around a bug in the HTML export sytmem
;; which causes COLSPAN= attributes not to be exported (!!)
(define gnc:colspans-are-working-right
@@ -506,23 +508,14 @@
;; utility class for generating account tables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define <html-acct-table>
- (make-record-type "<html-acct-table>"
- '(matrix ;; an html-table
- env ;; an alist
- )))
-
-(define gnc:html-acct-table?
- (record-predicate <html-acct-table>))
-
-(define gnc:_make-html-acct-table_
- (record-constructor <html-acct-table>))
+(define-record-type <html-acct-table>
+ (gnc:_make-html-acct-table_ matrix env)
+ gnc:html-acct-table?
+ (matrix gnc:_html-acct-table-matrix_ gnc:_html-acct-table-set-matrix!_)
+ (env gnc:_html-acct-table-env_ gnc:_html-acct-table-set-env!_))
(define (gnc:make-html-acct-table)
- (gnc:_make-html-acct-table_
- (gnc:make-html-table) ;; matrix
- #f ;; env
- ))
+ (gnc:_make-html-acct-table_ (gnc:make-html-table) #f))
(define (gnc:make-html-acct-table/env env)
(let ((acct-table (gnc:make-html-acct-table)))
@@ -538,18 +531,6 @@
(gnc:html-acct-table-add-accounts! acct-table accts)
acct-table))
-(define gnc:_html-acct-table-matrix_
- (record-accessor <html-acct-table> 'matrix))
-
-(define gnc:_html-acct-table-set-matrix!_
- (record-modifier <html-acct-table> 'matrix))
-
-(define gnc:_html-acct-table-env_
- (record-accessor <html-acct-table> 'env))
-
-(define gnc:_html-acct-table-set-env!_
- (record-modifier <html-acct-table> 'env))
-
;; some useful predicates to export
(define (gnc:account-code-less-p a b)
(string<? (xaccAccountGetCode a)
commit 81b20d0a62786811383b8227f8ed476ae909e404
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Aug 12 23:22:44 2019 +0800
[html-acct-table] timepair -> time64
* fix timepair -> time64 - this is technically dead code.
diff --git a/gnucash/report/report-system/html-acct-table.scm b/gnucash/report/report-system/html-acct-table.scm
index e67f9f599..1cf5a4d63 100644
--- a/gnucash/report/report-system/html-acct-table.scm
+++ b/gnucash/report/report-system/html-acct-table.scm
@@ -608,7 +608,7 @@
(if (equal? pred #t) gnc:account-code-less-p pred)))
(start-date (get-val env 'start-date))
(end-date (or (get-val env 'end-date)
- (cons 'absolute (cons (current-time) 0))))
+ (gnc:get-today)))
(report-commodity (or (get-val env 'report-commodity)
(gnc-default-report-currency)))
;; BUG: other code expects a real function here, maybe
commit 0c3f460e9fa5c3c354ff5fed64ea781b260ebff7
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Aug 8 23:10:12 2019 +0800
[invoice] deprecate easy/fancy-invoice creation hooks
diff --git a/gnucash/report/business-reports/invoice.scm b/gnucash/report/business-reports/invoice.scm
index b5c9e3f32..3bfe1a21b 100644
--- a/gnucash/report/business-reports/invoice.scm
+++ b/gnucash/report/business-reports/invoice.scm
@@ -930,6 +930,8 @@ for styling the invoice. Please see the exported report for the CSS class names.
'in-menu? #t)
(define (gnc:easy-invoice-report-create-internal invoice)
+ (issue-deprecation-warning
+ "gnc:easy-invoice-report-create-internal is unused")
(let* ((options (gnc:make-report-options easy-invoice-guid))
(invoice-op (gnc:lookup-option options gnc:pagename-general gnc:optname-invoice-number)))
(gnc:option-set-value invoice-op invoice)
@@ -937,6 +939,8 @@ for styling the invoice. Please see the exported report for the CSS class names.
(export gnc:easy-invoice-report-create-internal)
(define (gnc:fancy-invoice-report-create-internal invoice)
+ (issue-deprecation-warning
+ "gnc:fancy-invoice-report-create-internal is unused")
(let* ((options (gnc:make-report-options fancy-invoice-guid))
(invoice-op (gnc:lookup-option options gnc:pagename-general gnc:optname-invoice-number)))
(gnc:option-set-value invoice-op invoice)
Summary of changes:
gnucash/report/business-reports/invoice.scm | 4 +
gnucash/report/report-system/html-acct-table.scm | 37 +-
.../report/report-system/test/test-report-html.scm | 106 +++++
libgnucash/scm/price-quotes.scm | 497 +++++++++------------
4 files changed, 320 insertions(+), 324 deletions(-)
More information about the gnucash-changes
mailing list