IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge Chris Lam's 'scheme-progress' into maint.

Browse Source
This commit is contained in:
John Ralls 2018-12-29 10:19:58 -08:00
commit d3dd81632d
20 changed files with 795 additions and 1409 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gnucash/report/locale-specific/us/taxtxf.scm
View File

@ -712,7 +712,7 @@
(begin ;; do so (begin ;; do so
(set! missing-pricedb-entry? #f) (set! missing-pricedb-entry? #f)
(set! pricedb-lookup-price (set! pricedb-lookup-price
(let ((price (gnc-pricedb-lookup-nearest-in-time-t64 (let ((price (gnc-pricedb-lookup-nearest-in-time64
pricedb pricedb
account-commodity account-commodity
USD-currency USD-currency

4
gnucash/report/report-system/collectors.scm
View File

@ -18,6 +18,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report report-system collectors)) (define-module (gnucash report report-system collectors))
(issue-deprecation-warning
"(gnucash report report-system collectors) is deprecated.")
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
(export make-filter) (export make-filter)

3
gnucash/report/report-system/options-utilities.scm
View File

@ -122,6 +122,7 @@
;; into the other balances. ;; into the other balances.
(define (gnc:options-add-include-subaccounts! (define (gnc:options-add-include-subaccounts!
options pagename optname sort-tag) options pagename optname sort-tag)
(issue-deprecation-warning "gnc:options-add-include-subaccounts! is deprecated.")
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
@ -132,6 +133,7 @@
;; categories and ahow a subtotal for those. ;; categories and ahow a subtotal for those.
(define (gnc:options-add-group-accounts! (define (gnc:options-add-group-accounts!
options pagename optname sort-tag default?) options pagename optname sort-tag default?)
(issue-deprecation-warning "gnc:options-add-group-accounts! is deprecated.")
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
@ -154,6 +156,7 @@
(define (gnc:options-add-currency-selection! (define (gnc:options-add-currency-selection!
options pagename options pagename
name-show-foreign name-report-currency sort-tag) name-show-foreign name-report-currency sort-tag)
(issue-deprecation-warning "gnc:options-add-currency-selection! is deprecated.")
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option

3
gnucash/report/report-system/report-collectors.scm
View File

@ -19,6 +19,9 @@
(define-module (gnucash report report-system report-collectors)) (define-module (gnucash report report-system report-collectors))
(issue-deprecation-warning
"(gnucash report report-system report-collectors) is deprecated.")
(use-modules (gnucash gnc-module)) (use-modules (gnucash gnc-module))
(gnc:module-load "gnucash/report/report-system" 0) (gnc:module-load "gnucash/report/report-system" 0)

10
gnucash/report/report-system/report-system.scm
View File

@ -75,10 +75,10 @@
(export gnc:options-add-interval-choice!) (export gnc:options-add-interval-choice!)
(export gnc:options-add-account-levels!) (export gnc:options-add-account-levels!)
(export gnc:options-add-account-selection!) (export gnc:options-add-account-selection!)
(export gnc:options-add-include-subaccounts!) (export gnc:options-add-include-subaccounts!) ;deprecated
(export gnc:options-add-group-accounts!) (export gnc:options-add-group-accounts!) ;deprecated
(export gnc:options-add-currency!) (export gnc:options-add-currency!)
(export gnc:options-add-currency-selection!) (export gnc:options-add-currency-selection!) ;deprecated
(export gnc:options-add-price-source!) (export gnc:options-add-price-source!)
(export gnc:options-add-plot-size!) (export gnc:options-add-plot-size!)
(export gnc:options-add-marker-choice!) (export gnc:options-add-marker-choice!)
@ -723,10 +723,10 @@
(export gnc:monetaries-add) (export gnc:monetaries-add)
(export gnc:account-get-trans-type-balance-interval) (export gnc:account-get-trans-type-balance-interval)
(export gnc:account-get-trans-type-balance-interval-with-closing) (export gnc:account-get-trans-type-balance-interval-with-closing)
(export gnc:account-get-total-flow) (export gnc:account-get-total-flow) ;deprecated
(export gnc:account-get-pos-trans-total-interval) (export gnc:account-get-pos-trans-total-interval)
(export gnc:account-get-trans-type-splits-interval) (export gnc:account-get-trans-type-splits-interval)
(export gnc:double-col) (export gnc:double-col) ;deprecated
(export gnc:budget-get-start-date) (export gnc:budget-get-start-date)
(export gnc:budget-get-end-date) (export gnc:budget-get-end-date)
(export gnc:budget-account-get-net) (export gnc:budget-account-get-net)

12
gnucash/report/report-system/report-utilities.scm
View File

@ -731,6 +731,8 @@ flawed. see report-utilities.scm. please update reports.")
;; returns a commodity collector ;; returns a commodity collector
;; does NOT do currency exchanges ;; does NOT do currency exchanges
(define (gnc:account-get-total-flow direction target-account-list from-date to-date) (define (gnc:account-get-total-flow direction target-account-list from-date to-date)
(issue-deprecation-warning
"(gnc:account-get-total-flow) is deprecated.")
(let ((total-flow (gnc:make-commodity-collector))) (let ((total-flow (gnc:make-commodity-collector)))
(for-each (for-each
(lambda (target-account) (lambda (target-account)
@ -852,14 +854,12 @@ flawed. see report-utilities.scm. please update reports.")
(qof-query-destroy query) (qof-query-destroy query)
splits)))) splits))))
;; utility to assist with double-column balance tables ;; the following function is only used in trial-balance. best move it
;; a request is made with the <req> argument ;; back there, and deprecate this exported function.
;; <req> may currently be 'entry|'debit-q|'credit-q|'zero-q|'debit|'credit
;; 'debit-q|'credit-q|'zero-q tests the sign of the balance
;; 'side returns 'debit or 'credit, the column in which to display
;; 'debt|'credit return the entry, if appropriate, or #f
(define (gnc:double-col (define (gnc:double-col
req signed-balance report-commodity exchange-fn show-comm?) req signed-balance report-commodity exchange-fn show-comm?)
(issue-deprecation-warning
"(gnc:double-col) is deprecated.")
(let* ((sum (and signed-balance (let* ((sum (and signed-balance
(gnc:sum-collector-commodity (gnc:sum-collector-commodity
signed-balance signed-balance

2
gnucash/report/report-system/test/CMakeLists.txt
View File

@ -11,7 +11,6 @@ gnc_add_test_with_guile(test-link-module-report-system test-link-module.c
set(scm_test_report_system_SOURCES set(scm_test_report_system_SOURCES
test-load-report-system-module.scm test-load-report-system-module.scm
test-collectors.scm
test-test-extras.scm test-test-extras.scm
) )
@ -59,5 +58,4 @@ set_dist_list(test_report_system_DIST
${scm_test_report_system_SOURCES} ${scm_test_report_system_SOURCES}
test-extras.scm test-extras.scm
test-link-module.c test-link-module.c
test-test-extras.scm
) )

225
gnucash/report/report-system/test/test-collectors.scm
View File

@ -1,225 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (srfi srfi-1))
(use-modules (gnucash report report-system collectors))
(use-modules (gnucash engine test test-extras))
(define (run-test)
(and (test test-empty)
(test test-one)
(test test-two)
(test test-make-eq-set)
(test test-make-extreme-collector)
(test test-collector-split)
(test test-make-mapper-collector)
(test test-make-list-collector)
(test test-slotset)
(test test-collector-from-slotset)
(test test-binary-search-lt)
(test test-collector-into-list)
(test test-function-state->collector)
(test test-collector-do)
#t))
(define (test-slotset)
(let* ((values '(2 4 6))
(slotset (make-slotset (lambda (x) (* 2 x)) values)))
(and (equal? values (slotset-slots slotset))
(equal? 2 (slotset-slot slotset 1)))))
(define (test-empty)
(let ((c (empty-collector)))
(let ((empty (collector-end c)))
(and (equal? 4 (length empty))
(equal? 0 (collector-add-all (collector-accumulate-from 0)
(map cdr empty)))))))
(define (test-one)
(define c (empty-collector))
(set! c (collector-add c 1))
(and (equal? 1 (collector-add-all (collector-accumulate-from 0)
(map cdr (collector-end c))))
(equal? 4 (length (collector-end c)))))
(define (test-two)
(define c (empty-collector))
(set! c (collector-add c 2))
(and (equal? 2 (collector-add-all (collector-accumulate-from 0)
(map cdr (collector-end c))))
(equal? 4 (length (collector-end c)))))
(define (empty-collector)
(define (equal-predicate a)
(lambda (x)
(equal? a x)))
(collector-per-property '(1 2 3 4)
make-equal-filter
(lambda (value) (collector-accumulate-from 0))))
(define (test-make-eq-set)
(let ((c (make-eq-set-collector '())))
(and (null-list? (collector-end c))
(let ((c1 (collector-add c 1)))
(equal? '(1) (collector-end c1)))
(equal? '(1) (collector-add-all c '(1 1 1)))
(let ((result (collector-add-all c '(1 2))))
(and (member 1 result)
(member 2 result)
(= (length result) 2))))))
(define (test-make-extreme-collector)
(let ((c (make-extreme-collector > 0)))
(and (equal? 0 (collector-end c))
(equal? 0 (collector-add-all c '(-1)))
(equal? 1 (collector-add-all c '(1)))
(equal? 5 (collector-add-all c '(5)))
(equal? 5 (collector-add-all c '(1 5)))
(equal? 5 (collector-add-all c '(5 1)))
#t)))
(define (test-collector-split)
(let* ((c (collector-split (lambda (x) x)
(lambda (x) (collector-count-from 0))))
(all (collector-add-all c '(1 2 3 4 5 1 2))))
(and (equal? 5 (length all))
#t)))
(define (test-make-mapper-collector)
(let ((double-and-add (make-mapper-collector (lambda (x) (* x 2))
(collector-accumulate-from 0))))
(and (equal? 0 (collector-end double-and-add))
(equal? 2 (collector-add-all double-and-add '(1)))
#t)))
(define (test-make-list-collector)
(let ((c1 (collector-accumulate-from 0))
(c2 (collector-count-from 0)))
(and (equal? '(10 4) (collector-add-all (make-list-collector (list c1 c2)) '(1 2 3 4))))))
(define (test-collector-into-list)
(define (check l)
(equal? l (collector-add-all (collector-into-list) l)))
(and (check '())
(check '(1))
(check '(1 2))
(check '(1 2 3))
(check '(1 2 3 4))))
(define (test-collector-from-slotset)
;;(define (add-trace name collector)
;; (collector-print #t name collector))
(define (make-slotset-counter values)
(let ((slotset (make-slotset (lambda (x) x) values)))
(labelled-collector-from-slotset slotset
(lambda (n)
(collector-count-from 0)))))
(and (let ((values '(1 2)))
(equal? '((1 . 0) (2 . 0))
(collector-add-all (make-slotset-counter values)
'())))
(let ((values '(1 2)))
(equal? '((1 . 1) (2 . 1))
(collector-add-all (make-slotset-counter values)
'(1 2))))
(let ((values '(1 2)))
(equal? '((1 . 3) (2 . 2))
(collector-add-all (make-slotset-counter values)
'(1 2 1 2 1))))))
(use-modules (ice-9 streams))
(define (stream-range from to)
(make-stream (lambda (current)
(if (> current to) '()
(cons current (+ current 1))))
from))
(define (slow-search <= value vector)
(define (search n)
(if (= n (vector-length vector)) (- n 1)
(if (<= (vector-ref vector n) value)
(search (+ n 1))
(if (= n 0) #f (- n 1)))))
(if (= 0 (vector-length vector)) #f
(search 0)))
(define (test-binary-search-lt)
(define (search value vector)
(let ((binary-value (binary-search-lt <= value vector))
(slow-value (slow-search <= value vector))
(length (vector-length vector)))
(if (equal? binary-value slow-value) binary-value
(begin (format #t "Mismatch ~a ~a, expected ~a, found ~a\n" value vector slow-value binary-value)
(throw 'mismatch)))
binary-value))
(and (and (equal? #f (search 1 #()))
(equal? #f (search 0 #(1)))
(equal? 0 (search 1 #(1)))
(equal? 0 (search 2 #(1)))
(equal? #f (search 0 #(1 3)))
(equal? 0 (search 1 #(1 3)))
(equal? 0 (search 2 #(1 3)))
(equal? 1 (search 3 #(1 3)))
(equal? 1 (search 4 #(1 3))))
(let* ((values (stream-range 0 20))
(vectors (stream-map (lambda (n)
(let ((vector (make-vector n)))
(stream-for-each (lambda (index)
(vector-set! vector index (+ (* index 2) 1)))
(stream-range 0 (- n 1)))
vector))
values))
(tested-vectors (stream-map (lambda (vector)
(stream-for-each
(lambda (value)
(search value vector))
(stream-range 0 (+ (* (vector-length vector) 2) 1))))
vectors)))
(stream-for-each (lambda (x) x) tested-vectors))))
(define (test-function-state->collector)
(define (count v current-count) (+ current-count 1))
(define (check-count l)
(= (length l) (collector-add-all (function-state->collector count 0) l)))
(check-count '())
(check-count '(1))
(check-count '(1 2 3)))
(define (test-collector-do)
(let ((count 0))
(let ((add-to-list-and-count (collector-do (collector-into-list)
(function-state->collector (lambda (v n)
(set! count (+ n 1))
(+ n 1))
0))))
(let* ((orig '(one two three))
(collected (collector-add-all add-to-list-and-count orig)))
(format #t "~a ~a ~a\n" count collected orig)
(and (equal? orig collected)
(= count (length orig)))))))

58
gnucash/report/report-system/test/test-extras.scm
View File

@ -25,64 +25,6 @@
(use-modules (sxml simple)) (use-modules (sxml simple))
(use-modules (sxml xpath)) (use-modules (sxml xpath))
(export pattern-streamer)
(export tbl-column-count)
(export tbl-row-count)
(export tbl-ref)
(export tbl-ref->number)
;;
;; Table parsing
;;
(use-modules (ice-9 regex))
(use-modules (ice-9 streams))
(define (values-for-keywords pos regex-list text)
(make-stream (lambda (pos-keywords-pair)
(let ((current-pos (car pos-keywords-pair))
(regex-list (cdr pos-keywords-pair)))
(if (null? regex-list)
'()
(let ((match (string-match (caar regex-list) text current-pos)))
(if (not match)
'()
(let ((new-state (cons (match:end match)
(cdr regex-list)))
(next-value (cons (match:end match)
(map (lambda (item)
(match:substring match item))
(cdar regex-list)))))
(cons next-value new-state)))))))
(cons pos regex-list)))
(define (pattern-streamer start-text regex-list text)
(define (stream-next index)
;;(format #t "Next. Index: ~a\n" index)
(let ((head-index (string-contains text start-text index)))
;; (format #t "head index ~a ~a --> ~a\n" start-text index head-index)
(if (not head-index) '()
(let ((values (stream->list (values-for-keywords head-index regex-list text))))
(if (null? values) '()
(let ((new-state (car (car (last-pair values))))
(next-value (map cdr values)))
(cons next-value new-state)))))))
;;(format #t "Stream ~a\n" text)
(make-stream stream-next 0))
;; silly table functions
(define (tbl-column-count tbl)
(length (car tbl)))
(define (tbl-row-count tbl)
(length tbl))
(define (tbl-ref tbl row-index column-index)
(list-ref (list-ref tbl row-index) column-index))
(define (tbl-ref->number tbl row-index column-index)
(string->number (car (tbl-ref tbl row-index column-index))))
(export gnc:options->render) (export gnc:options->render)
(define (gnc:options->render uuid options prefix test-title) (define (gnc:options->render uuid options prefix test-title)
;; uuid - str to locate report uuid ;; uuid - str to locate report uuid

16
gnucash/report/report-system/test/test-report-utilities.scm
View File

@ -432,22 +432,6 @@
44 44
(gnc:accounts-count-splits (list expense income))) (gnc:accounts-count-splits (list expense income)))
(test-equal "gnc:account-get-total-flow 'in"
'(("GBP" . 14) ("USD" . 2544))
(collector->list
(gnc:account-get-total-flow 'in
(list bank)
(gnc-dmy2time64 15 01 1970)
(gnc-dmy2time64 01 01 2001))))
(test-equal "gnc:account-get-total-flow 'out"
'(("USD" . -296))
(collector->list
(gnc:account-get-total-flow 'out
(list bank)
(gnc-dmy2time64 15 01 1970)
(gnc-dmy2time64 01 01 2001))))
(let ((account-balances (gnc:get-assoc-account-balances (let ((account-balances (gnc:get-assoc-account-balances
(list bank gbp-bank) (list bank gbp-bank)
(lambda (acct) (lambda (acct)

83
gnucash/report/report-system/test/test-test-extras.scm
View File

@ -17,87 +17,14 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org ;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash engine test test-extras)) (use-modules (gnucash engine test test-extras))
(use-modules (ice-9 streams))
(define (run-test)
(and (test-pattern-streamer)
(test-create-account-structure)))
(define (test-pattern-streamer)
(and (test test-pattern-streamer-1)
(test test-pattern-streamer-2)
(test test-pattern-streamer-3)
(test test-pattern-streamer-4)
#t))
(define (test-pattern-streamer-1)
(let* ((content (values-for-text "tbl row x 1 y 2 row x 3 y 4 ")))
(format #t "Values: ~a ~a\n" content (list (list 1 2) (list 3 4)))
(equal? '((("1") ("2")) (("3") ("4"))) content)))
(define (test-pattern-streamer-2)
(let* ((text "")
(content (values-for-text text)))
(format #t "Values: ~a\n" content)
(equal? (list) content)))
(define (values-for-text text)
(let* ((content-stream (pattern-streamer "row" (list (list "x ([0-9]*) " 1)
(list "y ([0-9]*) " 1))
text))
(content (stream->list content-stream)))
content))
(define (test-pattern-streamer-4)
(let* ((text "tbl row x 11 v 12 v 13 row x 21 v 22 v 23 ")
(content-stream (pattern-streamer "row"
(list (list "x ([0-9]*) " 1)
(list "v ([0-9]*) " 1)
(list "v ([0-9]*) " 1))
text))
(content (stream->list content-stream)))
(= 11 (tbl-ref->number content 0 0))
(= 23 (tbl-ref->number content 1 2))))
(define stuff "<table>
<tr>
<th><string> Date</th>
<th><string> Auto</th>
<th><string> Groceries</th>
<th><string> Rent</th>
<th><string> Expenses</th>
<th><string> Grand Total</th>
</tr>
")
(define (test-pattern-streamer-3)
(let ((columns (stream->list (pattern-streamer "<th>"
(list (list "<string> ([^<]*)</" 1))
stuff))))
(format #t "columns ~a\n" columns)
(= 6 (length columns))))
;;
;;
;;
;(use-modules (gnucash engine))
;(use-modules (gnucash utilities))
;(use-modules (gnucash report report-system))
;(use-modules (gnucash app-utils))
(use-modules (gnucash engine)) (use-modules (gnucash engine))
(use-modules (sw_engine)) (use-modules (sw_engine))
(define (run-test)
(test-create-account-structure))
(define (test-create-account-structure) (define (test-create-account-structure)
(let ((env (create-test-env))) (let ((env (create-test-env)))
(let ((accounts (env-create-account-structure env (list "Assets" (let ((accounts (env-create-account-structure env (list "Assets"
@ -110,7 +37,3 @@
(and (= 3 (length accounts)) (and (= 3 (length accounts))
(equal? "Assets" (xaccAccountGetName (car accounts))) (equal? "Assets" (xaccAccountGetName (car accounts)))
)))) ))))

20
gnucash/report/standard-reports/equity-statement.scm
View File

@ -181,6 +181,24 @@
options)) options))
(define (account-get-total-flow direction target-account-list from-date to-date)
(let ((total-flow (gnc:make-commodity-collector)))
(for-each
(lambda (target-account)
(for-each
(lambda (target-account-split)
(let* ((transaction (xaccSplitGetParent target-account-split))
(split-value (xaccSplitGetAmount target-account-split)))
(if (and (<= from-date (xaccTransGetDate transaction) to-date)
(or (and (eq? direction 'in)
(positive? split-value))
(and (eq? direction 'out)
(negative? split-value))))
(total-flow 'add (xaccTransGetCurrency transaction) split-value))))
(xaccAccountGetSplitList target-account)))
target-account-list)
total-flow))
;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; equity-statement-renderer ;; equity-statement-renderer
;; set up the document and add the table ;; set up the document and add the table
@ -542,7 +560,7 @@
(net-investment 'minusmerge neg-pre-closing-equity #f);; > 0 (net-investment 'minusmerge neg-pre-closing-equity #f);; > 0
(net-investment 'merge neg-start-equity-balance #f) ;; net increase (net-investment 'merge neg-start-equity-balance #f) ;; net increase
(set! withdrawals (gnc:account-get-total-flow 'in equity-accounts start-date end-date)) (set! withdrawals (account-get-total-flow 'in equity-accounts start-date end-date))
(set! investments (gnc:make-commodity-collector)) (set! investments (gnc:make-commodity-collector))
(investments 'merge net-investment #f) (investments 'merge net-investment #f)

8
gnucash/report/standard-reports/test/CMakeLists.txt
View File

@ -1,12 +1,12 @@
set(scm_test_standard_reports_SOURCES set(scm_test_standard_reports_SOURCES
test-cash-flow.scm test-cash-flow.scm
test-cashflow-barchart.scm
test-standard-category-report.scm
test-standard-net-barchart.scm
test-standard-net-linechart.scm
) )
set(scm_test_with_srfi64_SOURCES set(scm_test_with_srfi64_SOURCES
test-standard-category-report.scm
test-standard-net-linechart.scm
test-standard-net-barchart.scm
test-cashflow-barchart.scm
test-charts.scm test-charts.scm
test-transaction.scm test-transaction.scm
test-balsheet-pnl.scm test-balsheet-pnl.scm

319
gnucash/report/standard-reports/test/test-cashflow-barchart.scm
View File

@ -24,33 +24,34 @@
(use-modules (gnucash engine)) (use-modules (gnucash engine))
(use-modules (sw_engine)) (use-modules (sw_engine))
(use-modules (gnucash engine test test-extras)) (use-modules (gnucash engine test test-extras))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash report report-system)) (use-modules (gnucash report report-system))
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report standard-reports cashflow-barchart)) (use-modules (gnucash report standard-reports cashflow-barchart))
(use-modules (gnucash report stylesheets)) (use-modules (gnucash report stylesheets))
(use-modules (ice-9 format))
(use-modules (ice-9 streams))
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
(use-modules (srfi srfi-64))
;; Explicitly set locale to make the report output predictable ;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
(define (run-test) (define (run-test)
(and (test-in-txn) (test-runner-factory gnc:test-runner)
(test-in-txn)
(test-out-txn) (test-out-txn)
(test-null-txn))) (test-null-txn))
(define (set-option options page tag value)
((gnc:option-setter (gnc:lookup-option options page tag)) value))
(define (set-option report page tag value) (define (str->num str)
((gnc:option-setter (gnc:lookup-option (gnc:report-options report) (string->number
page tag)) value)) (string-filter
(lambda (c)
(or (char-numeric? c)
(define constructor (record-constructor <report>)) (memv c '(#\- #\.))))
str)))
(define structure (define structure
(list "Root" (list (cons 'type ACCT-TYPE-ASSET)) (list "Root" (list (cons 'type ACCT-TYPE-ASSET))
@ -60,15 +61,10 @@
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE))) (list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
(list "Income" (list (cons 'type ACCT-TYPE-INCOME))))) (list "Income" (list (cons 'type ACCT-TYPE-INCOME)))))
;; Test two transactions from income to two different assets in two different days ;; Test two transactions from income to two different assets in two different days
(define (test-in-txn) (define (test-in-txn)
(let* ((template (gnc:find-report-template cashflow-barchart-uuid)) (let* ((options (gnc:make-report-options cashflow-barchart-uuid))
(options (gnc:make-report-options cashflow-barchart-uuid)) (env (create-test-env))
(report (constructor cashflow-barchart-uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(account-alist (env-create-account-structure-alist env structure)) (account-alist (env-create-account-structure-alist env structure))
(bank-account (cdr (assoc "Bank" account-alist))) (bank-account (cdr (assoc "Bank" account-alist)))
(wallet-account (cdr (assoc "Wallet" account-alist))) (wallet-account (cdr (assoc "Wallet" account-alist)))
@ -77,72 +73,40 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:time64-next-day date-0)) (date-1 (gnc:time64-next-day date-0))
(date-2 (gnc:time64-next-day date-1))) (date-2 (gnc:time64-next-day date-1)))
(env-create-transaction env (env-create-transaction env date-1 bank-account income-account 1)
date-1 (env-create-transaction env date-2 wallet-account income-account 5)
bank-account (set-option options gnc:pagename-display "Show Table" #t)
income-account (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
1/1) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(env-create-transaction env (set-option options gnc:pagename-general "Step Size" 'DayDelta)
date-2 (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
wallet-account (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
income-account (set-option options gnc:pagename-accounts "Accounts" (list wallet-account bank-account))
5/1)
(begin (let ((sxml (gnc:options->sxml cashflow-barchart-uuid options "test-cashflow-barchart"
(set-option report gnc:pagename-display "Show Table" #t) "test-in-txn" #:strip-tag "script")))
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (test-begin "test-in-txn")
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2)) (test-assert "in = net, out=0"
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (every (lambda (in out net)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (and (= in net) (zero? out)))
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (map str->num (sxml->table-row-col sxml 1 #f 2))
(set-option report gnc:pagename-accounts "Accounts" (list wallet-account bank-account)) (map str->num (sxml->table-row-col sxml 1 #f 3))
;; (format #t "Create first transaction on ~a~%" (gnc-ctime date-1)) (map str->num (sxml->table-row-col sxml 1 #f 4))))
;; (format #t "Create second transaction on ~a~%" (gnc-ctime date-2)) (test-equal "day in"
(let ((doc (renderer report))) '(0.0 1.0 5.0 6.0)
(gnc:html-document-set-style-sheet! doc (gnc:report-stylesheet report)) (map str->num (sxml->table-row-col sxml 1 #f 2)))
(let* ((result (gnc:html-document-render doc #f)) (test-equal "4 columns"
(tbl (stream->list 4
(pattern-streamer "<tr>" (length (sxml->table-row-col sxml 1 1 #f)))
(list (list "<td>([0-9]+)/([0-9]+)/([0-9]+)</td>" (test-equal "4 rows"
1 2 3) 4
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (length (sxml->table-row-col sxml 1 #f 1)))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (test-end "test-in-txn"))))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result)))
(total (stream->list
(pattern-streamer "<tr><td>Total</td>"
(list (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result))))
;; (format #t "Report Result ~a~%" result)
(and (every (lambda (row) ; test in=net & out=0 in all rows (all days)
(and (or (equal? (second row) (fourth row))
(begin (format #t "Failed, ~a and ~a differ~%" (second row) (fourth row)) #f))
(or (= 0 (string->number (car (third row))))
(begin (format #t "Failed ~d isn't 0~%" (car (third row))) #f))))
tbl)
(or (= 0 (tbl-ref->number tbl 0 1))
(begin (format #t "Failed refnum ~g isn't 0~%" (tbl-ref->number tbl 0 1)) #f)) ; 1st day in =0
(or (= 1 (tbl-ref->number tbl 1 1)) (begin (format #t "Failed refnum ~g isn't 1~%" (tbl-ref->number tbl 1 1)) #f)) ; 2nd day in =1
(or (= 5 (tbl-ref->number tbl 2 1)) (begin (format #t "Failed refnum ~g isn't 5~%" (tbl-ref->number tbl 2 1)) #f)) ; 3rd day in =5
(or (= (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) (begin (format #t "Failed refnums ~g and ~g differ ~%" (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) #f)); total in=total net
(or (= 0 (tbl-ref->number total 0 1)) (begin (format #t "Failed refnum ~g isn't 0~%" (tbl-ref->number total 0 1)) #f)) ; total out=0
(or (= 3 (tbl-row-count tbl)) (begin (format #t "Failed row count ~g isn't 3~%" (tbl-row-count tbl)) #f))
(or (= 4 (tbl-column-count tbl)) (begin (format #t "Failed column count ~g isn't 4~%" (tbl-column-count tbl)) #f))))
)
)
)
)
)
;; Test two transactions from two different assets to expense in two different days ;; Test two transactions from two different assets to expense in two different days
(define (test-out-txn) (define (test-out-txn)
(let* ((template (gnc:find-report-template cashflow-barchart-uuid)) (let* ((options (gnc:make-report-options cashflow-barchart-uuid))
(options (gnc:make-report-options cashflow-barchart-uuid)) (env (create-test-env))
(report (constructor cashflow-barchart-uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(account-alist (env-create-account-structure-alist env structure)) (account-alist (env-create-account-structure-alist env structure))
(bank-account (cdr (assoc "Bank" account-alist))) (bank-account (cdr (assoc "Bank" account-alist)))
(wallet-account (cdr (assoc "Wallet" account-alist))) (wallet-account (cdr (assoc "Wallet" account-alist)))
@ -151,81 +115,47 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:time64-next-day date-0)) (date-1 (gnc:time64-next-day date-0))
(date-2 (gnc:time64-next-day date-1))) (date-2 (gnc:time64-next-day date-1)))
(env-create-transaction env ;; large in txn to avoid negative net (hard to parse):
date-1 (env-create-transaction env date-1 bank-account income-account 100)
bank-account (env-create-transaction env date-1 expense-account bank-account 1)
income-account ;; large in txn to avoid negative net (hard to parse):
100/1) ; large in txn to avoid negative net (hard to parse) (env-create-transaction env date-2 wallet-account income-account 100)
(env-create-transaction env (env-create-transaction env date-2 expense-account wallet-account 5)
date-1
expense-account
bank-account
1/1)
(env-create-transaction env
date-2
wallet-account
income-account
100/1) ; large in txn to avoid negative net (hard to parse)
(env-create-transaction env
date-2
expense-account
wallet-account
5/1)
(begin
(set-option report gnc:pagename-display "Show Table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list wallet-account bank-account))
(let ((doc (renderer report))) (set-option options gnc:pagename-display "Show Table" #t)
(gnc:html-document-set-style-sheet! doc (gnc:report-stylesheet report)) (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(let* ((result (gnc:html-document-render doc #f)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(tbl (stream->list (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(pattern-streamer "<tr>" (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(list (list "<td>([0-9]+)/([0-9]+)/([0-9]+)</td>" (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
1 2 3) (set-option options gnc:pagename-accounts "Accounts" (list wallet-account bank-account))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (let ((sxml (gnc:options->sxml cashflow-barchart-uuid options "test-cashflow-barchart"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) "test-out-txn" #:strip-tag "script")))
result))) (test-begin "test-out-txn")
(total (stream->list (test-assert "in - out = net"
(pattern-streamer "<tr><td>Total</td>" (every (lambda (in out net)
(list (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (= (- in out) net))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (map str->num (sxml->table-row-col sxml 1 #f 2))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (map str->num (sxml->table-row-col sxml 1 #f 3))
result)))) (map str->num (sxml->table-row-col sxml 1 #f 4))))
(and (every (lambda (row) ; test in-out=net in all rows (all days) (test-equal "money out"
(let ((in (string->number (car (second row)))) '(0.0 1.0 5.0 6.0)
(out (string->number (car (third row)))) (map str->num (sxml->table-row-col sxml 1 #f 3)))
(net (string->number (car (fourth row))))) (test-equal "4 columns"
(= (- in out) net))) 4
tbl) (length (sxml->table-row-col sxml 1 1 #f)))
(= 0 (tbl-ref->number tbl 0 2)) ; 1st day out =0 (test-equal "4 rows"
(= 1 (tbl-ref->number tbl 1 2)) ; 2nd day out =1 4
(= 5 (tbl-ref->number tbl 2 2)) ; 3rd day out =5 (length (sxml->table-row-col sxml 1 #f 1)))
(= (- (tbl-ref->number total 0 0) (tbl-ref->number total 0 1)) ; total in-total out=total net (test-end "test-out-txn"))))
(tbl-ref->number total 0 2))
(= 6 (tbl-ref->number total 0 1)) ; total out=6
(= 3 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl)))))
)
)
)
)
;; Test null transaction (transaction between assets) ;; Test null transaction (transaction between assets)
;; This test is identical to test-in-txn but with an extra transaction between assets ;; This test is identical to test-in-txn but with an extra transaction between assets
(define (test-null-txn) (define (test-null-txn)
(let* ((template (gnc:find-report-template cashflow-barchart-uuid)) (let* ((options (gnc:make-report-options cashflow-barchart-uuid))
(options (gnc:make-report-options cashflow-barchart-uuid)) (env (create-test-env))
(report (constructor cashflow-barchart-uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(account-alist (env-create-account-structure-alist env structure)) (account-alist (env-create-account-structure-alist env structure))
(bank-account (cdr (assoc "Bank" account-alist))) (bank-account (cdr (assoc "Bank" account-alist)))
(wallet-account (cdr (assoc "Wallet" account-alist))) (wallet-account (cdr (assoc "Wallet" account-alist)))
@ -234,60 +164,35 @@
(date-0 (gnc:get-start-this-month)) (date-0 (gnc:get-start-this-month))
(date-1 (gnc:time64-next-day date-0)) (date-1 (gnc:time64-next-day date-0))
(date-2 (gnc:time64-next-day date-1))) (date-2 (gnc:time64-next-day date-1)))
(env-create-transaction env (env-create-transaction env date-1 bank-account income-account 1)
date-1 ;; the following transaction should not be counted
bank-account (env-create-transaction env date-1 bank-account wallet-account 20)
income-account (env-create-transaction env date-2 wallet-account income-account 5)
1/1)
(env-create-transaction env
date-1
bank-account
wallet-account
20/1) ; this transaction should not be counted
(env-create-transaction env
date-2
wallet-account
income-account
5/1)
(begin (set-option options gnc:pagename-display "Show Table" #t)
(set-option report gnc:pagename-display "Show Table" #t) (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-accounts "Accounts" (list wallet-account bank-account))
(set-option report gnc:pagename-accounts "Accounts" (list wallet-account bank-account))
(let ((doc (renderer report))) (let ((sxml (gnc:options->sxml cashflow-barchart-uuid options "test-cashflow-barchart"
(gnc:html-document-set-style-sheet! doc (gnc:report-stylesheet report)) "test-null-txn" #:strip-tag "script")))
(let* ((result (gnc:html-document-render doc #f)) (test-begin "test-null-txn")
(tbl (stream->list (test-assert "in = net, out=0"
(pattern-streamer "<tr>" (every (lambda (in out net)
(list (list "<td>([0-9]+)/([0-9]+)/([0-9]+)</td>" (and (= in net) (zero? out)))
1 2 3) (map str->num (sxml->table-row-col sxml 1 #f 2))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (map str->num (sxml->table-row-col sxml 1 #f 3))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (map str->num (sxml->table-row-col sxml 1 #f 4))))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (test-equal "day in"
result))) '(0.0 1.0 5.0 6.0)
(total (stream->list (map str->num (sxml->table-row-col sxml 1 #f 2)))
(pattern-streamer "<tr><td>Total</td>" (test-equal "4 columns"
(list (list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) 4
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (length (sxml->table-row-col sxml 1 1 #f)))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (test-equal "4 rows"
result)))) 4
(and (every (lambda (row) ; test in=net & out=0 in all rows (all days) (length (sxml->table-row-col sxml 1 #f 1)))
(and (equal? (second row) (fourth row)) (test-end "test-null-txn"))))
(= 0 (string->number (car (third row))))))
tbl)
(= 0 (tbl-ref->number tbl 0 1)) ; 1st day in =0
(= 1 (tbl-ref->number tbl 1 1)) ; 2nd day in =1
(= 5 (tbl-ref->number tbl 2 1)) ; 3rd day in =5
(= (tbl-ref->number total 0 0) (tbl-ref->number total 0 2)) ; total in=total net
(= 0 (tbl-ref->number total 0 1)) ; total out=0
(= 3 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl)))))
)
)
)
)

295
gnucash/report/standard-reports/test/test-standard-category-report.scm
View File

@ -17,11 +17,11 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org ;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (ice-9 format))
(use-modules (ice-9 streams))
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
(use-modules (srfi srfi-14))
(use-modules (srfi srfi-64))
(use-modules (gnucash gnc-module)) (use-modules (gnucash gnc-module))
(use-modules (gnucash engine test srfi64-extras))
;; Guile 2 needs to load external modules at compile time ;; Guile 2 needs to load external modules at compile time
;; otherwise the N_ syntax-rule won't be found at compile time ;; otherwise the N_ syntax-rule won't be found at compile time
@ -38,74 +38,52 @@
(use-modules (gnucash report standard-reports net-charts)) (use-modules (gnucash report standard-reports net-charts))
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report standard-reports category-barchart)) (use-modules (gnucash report standard-reports category-barchart))
(use-modules (ice-9 format))
(use-modules (ice-9 streams))
(use-modules (srfi srfi-1))
(use-modules (gnucash report stylesheets)) (use-modules (gnucash report stylesheets))
(use-modules (gnucash report report-system collectors))
(use-modules (gnucash engine test test-extras)) (use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
;; Explicitly set locale to make the report output predictable ;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
(define (run-test) (define (run-test)
(test-runner-factory gnc:test-runner)
(run-category-income-expense-test category-barchart-income-uuid category-barchart-expense-uuid) (run-category-income-expense-test category-barchart-income-uuid category-barchart-expense-uuid)
(run-category-asset-liability-test category-barchart-asset-uuid category-barchart-liability-uuid)) (run-category-asset-liability-test category-barchart-asset-uuid category-barchart-liability-uuid))
(export run-category-income-expense-test) (export run-category-income-expense-test)
(export run-category-asset-liability-test) (export run-category-asset-liability-test)
(define (set-option report page tag value) (define (set-option options page tag value)
((gnc:option-setter (gnc:lookup-option (gnc:report-options report) ((gnc:option-setter (gnc:lookup-option options page tag)) value))
page tag)) value))
(define (str->num str)
(define constructor (record-constructor <report>)) (string->number
(string-filter
;(set-option income-report gnc:pagename-general "Start Date" (cons 'relative 'start-prev-year)) (lambda (c)
;(set-option income-report gnc:pagename-general "End Date" (cons 'relative 'end-this-month)) (or (char-numeric? c)
;(set-option income-report gnc:pagename-general "Show table" #t) (memv c '(#\- #\.))))
;(set-option income-report gnc:pagename-general "Price Source" 'pricedb-nearest) str)))
;(set-option income-report gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(define (run-category-income-expense-test income-report-uuid expense-report-uuid) (define (run-category-income-expense-test income-report-uuid expense-report-uuid)
(and (null-test income-report-uuid) (null-test income-report-uuid)
(null-test expense-report-uuid) (null-test expense-report-uuid)
(single-txn-test income-report-uuid) (single-txn-test income-report-uuid)
(multi-acct-test expense-report-uuid) (multi-acct-test expense-report-uuid))
#t))
(define (run-category-asset-liability-test asset-report-uuid liability-report-uuid) (define (run-category-asset-liability-test asset-report-uuid liability-report-uuid)
(and (null-test asset-report-uuid) (null-test asset-report-uuid)
(null-test liability-report-uuid) (null-test liability-report-uuid)
(asset-test asset-report-uuid) (asset-test asset-report-uuid)
(liability-test liability-report-uuid) (liability-test liability-report-uuid))
#t))
;; No real test here, just confirm that no exceptions are thrown ;; No real test here, just confirm that no exceptions are thrown
(define (null-test uuid) (define (null-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let ((options (gnc:make-report-options uuid)))
(options (gnc:make-report-options uuid)) (gnc:options->render uuid options "test-standard-category-report" "null-test")))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let ((doc (renderer report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet report))
#t
)))
(define (single-txn-test uuid) (define (single-txn-test uuid)
(let* ((income-template (gnc:find-report-template uuid)) (let* ((income-options (gnc:make-report-options uuid))
(income-options (gnc:make-report-options uuid)) (env (create-test-env))
(income-report (constructor uuid "bar" income-options
#t #t #f #f ""))
(income-renderer (gnc:report-template-renderer income-template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -116,31 +94,26 @@
(gnc:get-start-this-month) (gnc:get-start-this-month)
(gnc:get-end-this-month) (gnc:get-end-this-month)
my-asset-account my-income-account) my-asset-account my-income-account)
(begin (set-option income-options gnc:pagename-display "Show table" #t)
(set-option income-report gnc:pagename-display "Show table" #t) (set-option income-options gnc:pagename-general "Start Date" (cons 'relative 'start-this-month))
(set-option income-report gnc:pagename-general "Start Date" (cons 'relative 'start-this-month)) (set-option income-options gnc:pagename-general "End Date" (cons 'relative 'end-this-month))
(set-option income-report gnc:pagename-general "End Date" (cons 'relative 'end-this-month)) (set-option income-options gnc:pagename-general "Step Size" 'DayDelta)
(set-option income-report gnc:pagename-general "Step Size" 'DayDelta) (set-option income-options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option income-report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option income-options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option income-report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option income-options gnc:pagename-accounts "Accounts" (list my-income-account))
(set-option income-report gnc:pagename-accounts "Accounts" (list my-income-account)) (set-option income-options gnc:pagename-accounts "Show Accounts until level" 'all)
(set-option income-report gnc:pagename-accounts "Show Accounts until level" 'all)
(let ((doc (income-renderer income-report))) (let ((sxml (gnc:options->sxml uuid income-options "test-standard-category-report"
(gnc:html-document-set-style-sheet! doc "single-txn-test" #:strip-tag "script")))
(gnc:report-stylesheet income-report)) (test-begin "single-txn-test")
(let* ((result (gnc:html-document-render doc #f)) (test-assert "day=value"
(tbl (stream->list (every =
(pattern-streamer "<tr>" (map
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" 1 2 3) (lambda (s)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (str->num (cadr (string-split s #\/))))
result)))) (sxml->table-row-col sxml 1 #f 1))
(every (lambda (date value-list) (map str->num (sxml->table-row-col sxml 1 #f 2))))
(let ((day (second date)) (test-end "single-txn-test"))))
(value (first value-list)))
(= (string->number day) (string->number value))))
(map first tbl)
(map second tbl))))))))
(define (list-leaves list) (define (list-leaves list)
(if (not (pair? list)) (if (not (pair? list))
@ -152,12 +125,8 @@
list))) list)))
(define (multi-acct-test expense-report-uuid) (define (multi-acct-test expense-report-uuid)
(let* ((expense-template (gnc:find-report-template expense-report-uuid)) (let* ((expense-options (gnc:make-report-options expense-report-uuid))
(expense-options (gnc:make-report-options expense-report-uuid)) (env (create-test-env))
(expense-report (constructor expense-report-uuid "bar" expense-options
#t #t #f #f ""))
(expense-renderer (gnc:report-template-renderer expense-template)))
(let* ((env (create-test-env))
(expense-accounts (env-expense-account-structure env)) (expense-accounts (env-expense-account-structure env))
(asset-accounts (env-create-account-structure (asset-accounts (env-create-account-structure
env env
@ -173,54 +142,32 @@
expense-account expense-account
bank-account)) bank-account))
leaf-expense-accounts) leaf-expense-accounts)
(begin (set-option expense-options gnc:pagename-display "Show table" #t)
(set-option expense-report gnc:pagename-display "Show table" #t) (set-option expense-options gnc:pagename-general "Start Date" (cons 'relative 'start-this-month))
(set-option expense-report gnc:pagename-general "Start Date" (cons 'relative 'start-this-month)) (set-option expense-options gnc:pagename-general "End Date" (cons 'relative 'end-this-month))
(set-option expense-report gnc:pagename-general "End Date" (cons 'relative 'end-this-month)) (set-option expense-options gnc:pagename-general "Step Size" 'DayDelta)
(set-option expense-report gnc:pagename-general "Step Size" 'DayDelta) (set-option expense-options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option expense-report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option expense-options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option expense-report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option expense-options gnc:pagename-accounts "Accounts" leaf-expense-accounts)
(set-option expense-report gnc:pagename-accounts "Accounts" leaf-expense-accounts) (set-option expense-options gnc:pagename-accounts "Show Accounts until level" 2)
(set-option expense-report gnc:pagename-accounts "Show Accounts until level" 2) (let ((sxml (gnc:options->sxml expense-report-uuid expense-options "test-standard-category-report"
"multi--test" #:strip-tag "script")))
(test-begin "multi-acct-test")
(test-equal "6 columns"
6
(length (sxml->table-row-col sxml 1 0 #f)))
(test-equal "date"
'("Date")
(sxml->table-row-col sxml 1 0 1))
(test-equal "auto"
'("Auto")
(sxml->table-row-col sxml 1 0 2))
(test-end "multi-acct-test"))))
(let ((doc (expense-renderer expense-report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet expense-report))
(let* ((html-document (gnc:html-document-render doc #f))
(columns (columns-from-report-document html-document))
(tbl (stream->list
(pattern-streamer "<tr>"
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" 1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
html-document))))
;(format #t "~a" html-document)
(and (= 6 (length columns))
(equal? "Date" (first columns))
(equal? "Auto" (second columns))
;; maybe should try to check actual values
)))))))
(define (columns-from-report-document doc)
(let ((columns (stream->list (pattern-streamer "<th>"
(list (list "<th>([^<]*)</" 1))
doc))))
(map caar columns)))
;;
;;
;;
(define (asset-test uuid) (define (asset-test uuid)
(let* ((asset-template (gnc:find-report-template uuid)) (let* ((asset-options (gnc:make-report-options uuid))
(asset-options (gnc:make-report-options uuid)) (env (create-test-env))
(asset-report (constructor uuid "bar" asset-options
#t #t #f #f ""))
(asset-renderer (gnc:report-template-renderer asset-template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -231,45 +178,35 @@
(gnc:get-start-this-month) (gnc:get-start-this-month)
(gnc:get-end-this-month) (gnc:get-end-this-month)
my-asset-account my-income-account) my-asset-account my-income-account)
(begin (set-option asset-options gnc:pagename-display "Show table" #t)
(set-option asset-report gnc:pagename-display "Show table" #t) (set-option asset-options gnc:pagename-general "Start Date" (cons 'relative 'start-this-month))
(set-option asset-report gnc:pagename-general "Start Date" (cons 'relative 'start-this-month)) (set-option asset-options gnc:pagename-general "End Date" (cons 'relative 'end-this-month))
(set-option asset-report gnc:pagename-general "End Date" (cons 'relative 'end-this-month)) (set-option asset-options gnc:pagename-general "Step Size" 'DayDelta)
(set-option asset-report gnc:pagename-general "Step Size" 'DayDelta) (set-option asset-options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option asset-report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option asset-options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option asset-report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option asset-options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option asset-report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option asset-options gnc:pagename-accounts "Accounts" (list my-asset-account))
(set-option asset-report gnc:pagename-accounts "Accounts" (list my-asset-account)) (set-option asset-options gnc:pagename-accounts "Show Accounts until level" 'all)
(set-option asset-report gnc:pagename-accounts "Show Accounts until level" 'all) (let ((sxml (gnc:options->sxml uuid asset-options "test-standard-category-report"
"asset-test" #:strip-tag "script")))
(let ((doc (asset-renderer asset-report))) (test-begin "asset-renderer")
(gnc:html-document-set-style-sheet! doc (test-equal "2 columns"
(gnc:report-stylesheet asset-report)) 2
(let* ((html-document (gnc:html-document-render doc #f)) (length (sxml->table-row-col sxml 1 0 #f)))
(columns (columns-from-report-document html-document)) (test-equal "account-1"
(tbl (stream->list '("account-1")
(pattern-streamer "<tr>" (sxml->table-row-col sxml 1 0 2))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" 1 2 3) (test-equal "first row $1.00"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) '("$1.00")
html-document))) (sxml->table-row-col sxml 1 1 2))
(row-count (tbl-row-count tbl))) (test-equal "28th row $406.00"
(and (member "account-1" columns) '("$406.00")
(= 2 (length columns)) (sxml->table-row-col sxml 1 28 2))
(= 1 (string->number (car (tbl-ref tbl 0 1)))) (test-end "asset-renderer"))))
(= (/ (* row-count (+ row-count 1)) 2)
(string->number (car (tbl-ref tbl (- row-count 1) 1))))
#t)))))))
(define (liability-test uuid) (define (liability-test uuid)
;; this test is tailored for bug 793278 (let* ((liability-options (gnc:make-report-options uuid))
;; except we can't use $10,000 because the string->number (env (create-test-env))
;; function cannot handle thousand separators. Use $100.
(let* ((liability-template (gnc:find-report-template uuid))
(liability-options (gnc:make-report-options uuid))
(liability-report (constructor uuid "bar" liability-options
#t #t #f #f ""))
(liability-renderer (gnc:report-template-renderer liability-template)))
(let* ((env (create-test-env))
(asset--acc (env-create-root-account env ACCT-TYPE-ASSET (gnc-default-report-currency))) (asset--acc (env-create-root-account env ACCT-TYPE-ASSET (gnc-default-report-currency)))
(liabil-acc (env-create-root-account env ACCT-TYPE-CREDIT (gnc-default-report-currency))) (liabil-acc (env-create-root-account env ACCT-TYPE-CREDIT (gnc-default-report-currency)))
(income-acc (env-create-root-account env ACCT-TYPE-INCOME (gnc-default-report-currency)))) (income-acc (env-create-root-account env ACCT-TYPE-INCOME (gnc-default-report-currency))))
@ -284,26 +221,28 @@
(env-create-transaction env (gnc-dmy2time64 02 04 2017) liabil-acc asset--acc 9) ;repay#4 (env-create-transaction env (gnc-dmy2time64 02 04 2017) liabil-acc asset--acc 9) ;repay#4
(env-create-transaction env (gnc-dmy2time64 01 05 2017) asset--acc income-acc 10) ;salary#5 (env-create-transaction env (gnc-dmy2time64 01 05 2017) asset--acc income-acc 10) ;salary#5
(env-create-transaction env (gnc-dmy2time64 02 05 2017) liabil-acc asset--acc 9) ;repay#5 (env-create-transaction env (gnc-dmy2time64 02 05 2017) liabil-acc asset--acc 9) ;repay#5
(begin (set-option liability-options gnc:pagename-display "Show table" #t)
(set-option liability-report gnc:pagename-display "Show table" #t) (set-option liability-options gnc:pagename-general "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 2017)))
(set-option liability-report gnc:pagename-general "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 2017))) (set-option liability-options gnc:pagename-general "End Date" (cons 'absolute (gnc-dmy2time64 31 12 2018)))
(set-option liability-report gnc:pagename-general "End Date" (cons 'absolute (gnc-dmy2time64 31 12 2018))) (set-option liability-options gnc:pagename-general "Step Size" 'MonthDelta)
(set-option liability-report gnc:pagename-general "Step Size" 'MonthDelta) (set-option liability-options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option liability-report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option liability-options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option liability-report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option liability-options gnc:pagename-accounts "Accounts" (list liabil-acc))
(set-option liability-report gnc:pagename-accounts "Accounts" (list liabil-acc)) (set-option liability-options gnc:pagename-accounts "Show Accounts until level" 'all)
(set-option liability-report gnc:pagename-accounts "Show Accounts until level" 'all)
(let ((doc (liability-renderer liability-report))) (let ((sxml (gnc:options->sxml uuid liability-options "test-standard-category-report"
(gnc:html-document-set-style-sheet! doc (gnc:report-stylesheet liability-report)) "liability-test" #:strip-tag "script")))
(let* ((html-document (gnc:html-document-render doc #f)) (test-begin "liability-renderer")
(columns (columns-from-report-document html-document)) (test-equal "2 columns"
(tbl (stream->list 2
(pattern-streamer "<tr>" (length (sxml->table-row-col sxml 1 0 #f)))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" 1 2 3) (test-equal "account-2"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) '("account-2")
html-document))) (sxml->table-row-col sxml 1 0 2))
(row-count (tbl-row-count tbl))) (test-equal "first row $100.00"
(and (= 2 (length columns)) '("$100.00")
(= 100 (string->number (car (tbl-ref tbl 0 1)))) (sxml->table-row-col sxml 1 1 2))
(= 55 (string->number (car (tbl-ref tbl (- row-count 1) 1)))) (test-equal "last row $55.00"
#t))))))) '("$55.00")
(sxml->table-row-col sxml 1 -1 2))
(test-end "liability-renderer"))))

386
gnucash/report/standard-reports/test/test-standard-net-barchart.scm
View File

@ -17,17 +17,15 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org ;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (gnucash gnc-module)) (use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0)) (gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0))
(use-modules (gnucash engine)) (use-modules (gnucash engine))
(use-modules (sw_engine)) (use-modules (sw_engine))
(use-modules (ice-9 format))
(use-modules (ice-9 streams))
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
(use-modules (srfi srfi-64))
(use-modules (gnucash report stylesheets)) (use-modules (gnucash report stylesheets))
(use-modules (gnucash engine test test-extras)) (use-modules (gnucash engine test test-extras))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report standard-reports net-charts)) (use-modules (gnucash report standard-reports net-charts))
@ -35,47 +33,29 @@
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
(define (run-test) (define (run-test)
(test-runner-factory gnc:test-runner)
(run-net-asset-income-test net-worth-barchart-uuid income-expense-barchart-uuid)) (run-net-asset-income-test net-worth-barchart-uuid income-expense-barchart-uuid))
(define (set-option report page tag value) (define (set-option options page tag value)
((gnc:option-setter (gnc:lookup-option (gnc:report-options report) ((gnc:option-setter (gnc:lookup-option options page tag)) value))
page tag)) value))
(define constructor (record-constructor <report>))
(define (run-net-asset-income-test asset-report-uuid income-report-uuid) (define (run-net-asset-income-test asset-report-uuid income-report-uuid)
(and (two-txn-test asset-report-uuid)
(two-txn-test-2 asset-report-uuid)
(two-txn-test-income income-report-uuid)
(null-test asset-report-uuid) (null-test asset-report-uuid)
(null-test income-report-uuid) (null-test income-report-uuid)
(single-txn-test asset-report-uuid) (single-txn-test asset-report-uuid)
(closing-test income-report-uuid) (two-txn-test asset-report-uuid)
#t)) (two-txn-test-2 asset-report-uuid)
(two-txn-test-income income-report-uuid)
(closing-test income-report-uuid))
;; Just prove that the report exists. ;; Just prove that the report exists.
(define (null-test uuid) (define (null-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid)))
(options (gnc:make-report-options uuid)) (gnc:options->render uuid options "test-standard-net-barchart" "null-test")))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let ((doc (renderer report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet report))
;;(format #t "render: ~a\n" (gnc:html-document-render doc #f))
#t
)))
(define (single-txn-test uuid) (define (single-txn-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -87,45 +67,39 @@
my-income-account my-income-account
my-asset-account my-asset-account
-1/1) -1/1)
(begin (set-option options gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-display "Show table" #t) (set-option options gnc:pagename-general "Start Date"
(set-option report gnc:pagename-general "Start Date"
(cons 'absolute (gnc:get-start-this-month))) (cons 'absolute (gnc:get-start-this-month)))
(set-option report gnc:pagename-general "End Date" (set-option options gnc:pagename-general "End Date"
(cons 'absolute (gnc:get-start-this-month))) (cons 'absolute (gnc:get-start-this-month)))
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account)) (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account))
(let ((doc (renderer report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet report))
(let* ((result (gnc:html-document-render doc #f))
(tbl (stream->list
(pattern-streamer "<tr>"
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>"
1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result))))
(or (and (= 1 (tbl-ref->number tbl 0 1))
(= 0 (tbl-ref->number tbl 0 2))
(= 1 (tbl-ref->number tbl 0 3))
(= 1 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl)))
(begin (format #t "Single-txn test ~a failed~%" uuid) #f))
))))))
(let ((sxml (gnc:options->sxml uuid options "test-standard-net-barchart"
"single-txn-test" #:strip-tag "script")))
(test-begin "single-txn-test")
(test-equal "assets $1.00"
'("$1.00")
(sxml->table-row-col sxml 1 1 2))
(test-equal "liability $0.00"
'("$0.00")
(sxml->table-row-col sxml 1 1 3))
(test-equal "net $0.00"
'("$1.00")
(sxml->table-row-col sxml 1 1 4))
(test-equal "1 rows"
1
(length (sxml->table-row-col sxml 1 #f 1)))
(test-equal "4 columns"
4
(length (sxml->table-row-col sxml 1 1 #f)))
(test-end "single-txn-test"))))
(define (two-txn-test uuid) (define (two-txn-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -145,54 +119,39 @@
my-income-account my-income-account
my-asset-account my-asset-account
-5/1) -5/1)
(begin (set-option options gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-display "Show table" #t) (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account))
(let ((doc (renderer report))) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-barchart"
(gnc:html-document-set-style-sheet! doc "two-txn-test" #:strip-tag "script")))
(gnc:report-stylesheet report)) (test-begin "two-txn-test")
(let* ((result (gnc:html-document-render doc #f)) (test-equal "asset $0.00"
(tbl (stream->list '("$0.00")
(pattern-streamer "<tr>" (sxml->table-row-col sxml 1 1 2))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (test-equal "asset $1.00"
1 2 3) '("$1.00")
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (sxml->table-row-col sxml 1 2 2))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (test-equal "asset $6.00"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) '("$6.00")
result)))) (sxml->table-row-col sxml 1 3 2))
(or (and (every (lambda (row) (test-equal "4 columns"
(and (or (equal? (second row) (fourth row)) 4
(begin (format "Second Element ~g != fourth element ~g~%" (second row) (fourth row)) #f)) (length (sxml->table-row-col sxml 1 1 #f)))
(or (= 0 (string->number (car (third row)))) (test-equal "3 rows"
(begin (format "third row element ~a not 0~%" (car (third row))) #f)))) 3
tbl) (length (sxml->table-row-col sxml 1 #f 1)))
(or (= 0 (tbl-ref->number tbl 0 1)) (test-end "two-txn-test")
(begin (format #t "Item 1 failed: ~g not 0~%" (tbl-ref->number tbl 0 1)) #f)) sxml)))
(or (= 1 (tbl-ref->number tbl 1 1))
(begin (format #t "Item 1 failed: ~g not 1~%" (tbl-ref->number tbl 1 1)) #f))
(or (= 6 (tbl-ref->number tbl 2 1))
(begin (format #t "Item 2 failed: ~g not 6~%" (tbl-ref->number tbl 2 1)) #f))
(or (= 3 (tbl-row-count tbl))
(begin (format #t "Item 3 failed: ~g not 3~%" (tbl-row-count tbl)) #f))
(or (= 4 (tbl-column-count tbl))
(begin (format #t "Item 4 failed: ~g not 4~%" (tbl-column-count tbl)) #f)))
(begin (format #t "Two-txn test ~a failed~%" uuid) #f))
))))))
(define (two-txn-test-2 uuid) (define (two-txn-test-2 uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY (my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
@ -209,48 +168,38 @@
(env-create-transaction env date-2 my-income-account my-asset-account -5/1) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account -5/1) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin (begin
(set-option report gnc:pagename-display "Show table" #t) (set-option options gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account my-liability-account)) (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account my-liability-account))
(let ((doc (renderer report))) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-barchart"
(gnc:html-document-set-style-sheet! doc "two-txn-test-2" #:strip-tag "script")))
(gnc:report-stylesheet report)) (test-begin "two-txn-test")
(let* ((result (gnc:html-document-render doc #f)) (test-equal "asset $0.00"
(tbl (stream->list '("$0.00")
(pattern-streamer "<tr>" (sxml->table-row-col sxml 1 1 2))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (test-equal "asset $1.00"
1 2 3) '("$1.00")
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (sxml->table-row-col sxml 1 2 2))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (test-equal "asset $6.00"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) '("$6.00")
result)))) (sxml->table-row-col sxml 1 3 2))
(or (and (every (lambda (row) (test-equal "4 columns"
(and (= (string->number (car (fourth row))) 4
(+ (string->number (car (second row))) (length (sxml->table-row-col sxml 1 1 #f)))
(string->number (car (third row))))) (test-equal "3 rows"
;; txns added in pairs, so assets = liability 3
(equal? (second row) (third row)))) (length (sxml->table-row-col sxml 1 #f 1)))
tbl) (test-end "two-txn-test")
(= 0 (tbl-ref->number tbl 0 1)) sxml))))
(= 1 (tbl-ref->number tbl 1 1))
(= 6 (tbl-ref->number tbl 2 1))
(= 3 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl)))
(begin (format #t "two-txn test 2 ~a failed~%" uuid) #f))
))))))
(define (two-txn-test-income uuid) (define (two-txn-test-income uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY (my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
@ -266,50 +215,40 @@
(env-create-transaction env date-1 my-expense-account my-liability-account -1/1) (env-create-transaction env date-1 my-expense-account my-liability-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account -5/1) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account -5/1) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin
(set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-income-account my-expense-account))
(let ((doc (renderer report))) (set-option options gnc:pagename-display "Show table" #t)
(gnc:html-document-set-style-sheet! doc (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(gnc:report-stylesheet report)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(let* ((result (gnc:html-document-render doc #f)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(tbl (stream->list (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(pattern-streamer "<tr>" (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (set-option options gnc:pagename-accounts "Accounts" (list my-income-account my-expense-account))
1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-barchart"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) "two-txn-test-2" #:strip-tag "script")))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (test-begin "two-txn-test-2")
result)))) (test-equal "income $0.00"
(or (and (every (lambda (row) '("$0.00")
(and (= (string->number (car (fourth row))) (sxml->table-row-col sxml 1 1 2))
(+ (string->number (car (second row))) (test-equal "income $1.00"
(string->number (car (third row))))) '("$1.00")
;; txns added in pairs, so assets = liability (sxml->table-row-col sxml 1 2 2))
(equal? (second row) (third row)))) (test-equal "income $5.00"
tbl) '("$5.00")
(= 0 (tbl-ref->number tbl 0 1)) (sxml->table-row-col sxml 1 3 2))
(= 1 (tbl-ref->number tbl 1 1)) (test-equal "4 columns"
(= 5 (tbl-ref->number tbl 2 1)) 4
(= 3 (tbl-row-count tbl)) (length (sxml->table-row-col sxml 1 1 #f)))
(= 4 (tbl-column-count tbl))) (test-equal "3 rows"
(begin (format #t "two-txn-income test ~a failed~%" uuid) #f)) 3
)))))) (length (sxml->table-row-col sxml 1 #f 1)))
(test-end "two-txn-test-2")
sxml)))
(define (closing-test uuid) (define (closing-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY (my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
@ -329,42 +268,37 @@
(env-create-transaction env date-2 my-income-account my-asset-account -2/1) (env-create-transaction env date-2 my-income-account my-asset-account -2/1)
(env-create-transaction env date-3 my-income-account my-asset-account -3/1) (env-create-transaction env date-3 my-income-account my-asset-account -3/1)
(let ((closing-txn (env-create-transaction env date-2 my-asset-account my-equity-account (let ((closing-txn (env-create-transaction env date-2 my-asset-account my-equity-account 300)))
300/1)))
(xaccTransSetIsClosingTxn closing-txn #t)) (xaccTransSetIsClosingTxn closing-txn #t))
(begin (set-option options gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-display "Show table" #t) (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-3))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-3)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-accounts "Accounts" (list my-income-account my-expense-account))
(set-option report gnc:pagename-accounts "Accounts" (list my-income-account my-expense-account))
(let ((doc (renderer report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet report))
(let* ((result (gnc:html-document-render doc #f))
(tbl (stream->list
(pattern-streamer "<tr>"
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>"
1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1))
result))))
(or (and (every (lambda (row)
(and (= (string->number (car (fourth row)))
(+ (string->number (car (second row)))
(string->number (car (third row)))))))
tbl)
(= 0 (tbl-ref->number tbl 0 1))
(= 1 (tbl-ref->number tbl 1 1))
(= 2 (tbl-ref->number tbl 2 1))
(= 3 (tbl-ref->number tbl 3 1))
(= 4 (tbl-row-count tbl))
(= 4 (tbl-column-count tbl)))
(begin (format #t "Closing-txn test ~a failed~%" uuid) #f))
))))))
(let ((sxml (gnc:options->sxml uuid options "test-standard-net-barchart"
"closing-test" #:strip-tag "script")))
(test-begin "closing-test")
(test-equal "income $0.00"
'("$0.00")
(sxml->table-row-col sxml 1 1 2))
(test-equal "income $1.00"
'("$1.00")
(sxml->table-row-col sxml 1 2 2))
(test-equal "income $2.00"
'("$2.00")
(sxml->table-row-col sxml 1 3 2))
(test-equal "income $3.00"
'("$3.00")
(sxml->table-row-col sxml 1 4 2))
(test-equal "4 columns"
4
(length (sxml->table-row-col sxml 1 1 #f)))
(test-equal "4 rows"
4
(length (sxml->table-row-col sxml 1 #f 1)))
(test-end "closing-test")
sxml)))

224
gnucash/report/standard-reports/test/test-standard-net-linechart.scm
View File

@ -17,17 +17,15 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org ;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (gnucash gnc-module)) (use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0)) (gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0))
(use-modules (gnucash engine)) (use-modules (gnucash engine))
(use-modules (sw_engine)) (use-modules (sw_engine))
(use-modules (ice-9 format))
(use-modules (ice-9 streams))
(use-modules (srfi srfi-1)) (use-modules (srfi srfi-1))
(use-modules (srfi srfi-64))
(use-modules (gnucash report stylesheets)) (use-modules (gnucash report stylesheets))
(use-modules (gnucash engine test test-extras)) (use-modules (gnucash engine test test-extras))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash report report-system test test-extras)) (use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report standard-reports net-charts)) (use-modules (gnucash report standard-reports net-charts))
@ -35,44 +33,26 @@
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
(define (run-test) (define (run-test)
(test-runner-factory gnc:test-runner)
(run-net-asset-test net-worth-linechart-uuid)) (run-net-asset-test net-worth-linechart-uuid))
(define (set-option report page tag value) (define (set-option options page tag value)
((gnc:option-setter (gnc:lookup-option (gnc:report-options report) ((gnc:option-setter (gnc:lookup-option options page tag)) value))
page tag)) value))
(define constructor (record-constructor <report>))
(define (run-net-asset-test asset-report-uuid) (define (run-net-asset-test asset-report-uuid)
(and (two-txn-test asset-report-uuid)
(two-txn-test-2 asset-report-uuid)
(null-test asset-report-uuid) (null-test asset-report-uuid)
(single-txn-test asset-report-uuid))) (single-txn-test asset-report-uuid)
(two-txn-test asset-report-uuid)
(two-txn-test-2 asset-report-uuid))
;; Just prove that the report exists. ;; Just prove that the report exists.
(define (null-test uuid) (define (null-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let ((options (gnc:make-report-options uuid)))
(options (gnc:make-report-options uuid)) (gnc:options->render uuid options "test-standard-net-linechart" "null-test")))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let ((doc (renderer report)))
(gnc:html-document-set-style-sheet! doc
(gnc:report-stylesheet report))
;;(format #t "render: ~a\n" (gnc:html-document-render doc #f))
#t
)))
(define (single-txn-test uuid) (define (single-txn-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -84,43 +64,37 @@
my-income-account my-income-account
my-asset-account my-asset-account
-1/1) -1/1)
(begin (set-option options gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-display "Show table" #t) (set-option options gnc:pagename-general "Start Date"
(set-option report gnc:pagename-general "Start Date"
(cons 'absolute (gnc:get-start-this-month))) (cons 'absolute (gnc:get-start-this-month)))
(set-option report gnc:pagename-general "End Date" (set-option options gnc:pagename-general "End Date"
(cons 'absolute (gnc:get-start-this-month))) (cons 'absolute (gnc:get-start-this-month)))
(set-option report gnc:pagename-general "Step Size" 'DayDelta) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest) (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency)) (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account)) (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account))
(let ((doc (renderer report))) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
(gnc:html-document-set-style-sheet! doc "single-txn-test" #:strip-tag "script")))
(gnc:report-stylesheet report)) (test-begin "single-txn-test")
(let* ((result (gnc:html-document-render doc #f)) (test-equal "assets $1.00"
(tbl (stream->list '("$1.00")
(pattern-streamer "<tr>" (sxml->table-row-col sxml 1 1 2))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (test-equal "liability $0.00"
1 2 3) '("$0.00")
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (sxml->table-row-col sxml 1 1 3))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (test-equal "net $0.00"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) '("$1.00")
result)))) (sxml->table-row-col sxml 1 1 4))
(and (= 1 (tbl-ref->number tbl 0 1)) (test-equal "4 columns"
(= 0 (tbl-ref->number tbl 0 2)) 4
(= 1 (tbl-ref->number tbl 0 3)) (length (sxml->table-row-col sxml 1 1 #f)))
(= 1 (tbl-row-count tbl)) (test-end "single-txn-test"))))
(= 4 (tbl-column-count tbl)))))))))
(define (two-txn-test uuid) (define (two-txn-test uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE (my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
@ -140,45 +114,40 @@
my-income-account my-income-account
my-asset-account my-asset-account
-5/1) -5/1)
(begin
(set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account))
(let ((doc (renderer report))) (set-option options gnc:pagename-display "Show table" #t)
(gnc:html-document-set-style-sheet! doc (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(gnc:report-stylesheet report)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(let* ((result (gnc:html-document-render doc #f)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(tbl (stream->list (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(pattern-streamer "<tr>" (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account))
1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) "two-txn-test" #:strip-tag "script")))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (test-begin "two-txn-test")
result)))) (test-equal "asset $0.00"
(and (every (lambda (row) '("$0.00")
(and (equal? (second row) (fourth row)) (sxml->table-row-col sxml 1 1 2))
(= 0 (string->number (car (third row)))))) (test-equal "asset $1.00"
tbl) '("$1.00")
(= 0 (tbl-ref->number tbl 0 1)) (sxml->table-row-col sxml 1 2 2))
(= 1 (tbl-ref->number tbl 1 1)) (test-equal "asset $6.00"
(= 6 (tbl-ref->number tbl 2 1)) '("$6.00")
(= 3 (tbl-row-count tbl)) (sxml->table-row-col sxml 1 3 2))
(= 4 (tbl-column-count tbl))))))))) (test-equal "4 columns"
4
(length (sxml->table-row-col sxml 1 1 #f)))
(test-equal "3 rows"
3
(length (sxml->table-row-col sxml 1 #f 1)))
(test-end "two-txn-test")
sxml)))
(define (two-txn-test-2 uuid) (define (two-txn-test-2 uuid)
(let* ((template (gnc:find-report-template uuid)) (let* ((options (gnc:make-report-options uuid))
(options (gnc:make-report-options uuid)) (env (create-test-env))
(report (constructor uuid "bar" options
#t #t #f #f ""))
(renderer (gnc:report-template-renderer template)))
(let* ((env (create-test-env))
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET (my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
(gnc-default-report-currency))) (gnc-default-report-currency)))
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY (my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
@ -194,37 +163,32 @@
(env-create-transaction env date-1 my-expense-account my-liability-account -1/1) (env-create-transaction env date-1 my-expense-account my-liability-account -1/1)
(env-create-transaction env date-2 my-income-account my-asset-account -5/1) (env-create-transaction env date-2 my-income-account my-asset-account -5/1)
(env-create-transaction env date-2 my-expense-account my-liability-account -5/1) (env-create-transaction env date-2 my-expense-account my-liability-account -5/1)
(begin
(set-option report gnc:pagename-display "Show table" #t)
(set-option report gnc:pagename-general "Start Date" (cons 'absolute date-0))
(set-option report gnc:pagename-general "End Date" (cons 'absolute date-2))
(set-option report gnc:pagename-general "Step Size" 'DayDelta)
(set-option report gnc:pagename-general "Price Source" 'pricedb-nearest)
(set-option report gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(set-option report gnc:pagename-accounts "Accounts" (list my-asset-account my-liability-account))
(let ((doc (renderer report))) (set-option options gnc:pagename-display "Show table" #t)
(gnc:html-document-set-style-sheet! doc (set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
(gnc:report-stylesheet report)) (set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
(let* ((result (gnc:html-document-render doc #f)) (set-option options gnc:pagename-general "Step Size" 'DayDelta)
(tbl (stream->list (set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
(pattern-streamer "<tr>" (set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
(list (list "<td>([0-9][0-9])/([0-9][0-9])/([0-9][0-9])</td>" (set-option options gnc:pagename-accounts "Accounts" (list my-asset-account my-liability-account))
1 2 3)
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) (let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1) "two-txn-test-2" #:strip-tag "script")))
(list "<td class=\"number-cell\">[^0-9]*([^<]*)</td>" 1)) (test-begin "two-txn-test-2")
result)))) (test-equal "asset $0.00"
(and (every (lambda (row) '("$0.00")
(and (= (string->number (car (fourth row))) (sxml->table-row-col sxml 1 1 2))
(+ (string->number (car (second row))) (test-equal "asset $1.00"
(string->number (car (third row))))) '("$1.00")
;; txns added in pairs, so assets = liability (sxml->table-row-col sxml 1 2 2))
(equal? (second row) (third row)))) (test-equal "asset $6.00"
tbl) '("$6.00")
(= 0 (tbl-ref->number tbl 0 1)) (sxml->table-row-col sxml 1 3 2))
(= 1 (tbl-ref->number tbl 1 1)) (test-equal "4 columns"
(= 6 (tbl-ref->number tbl 2 1)) 4
(= 3 (tbl-row-count tbl)) (length (sxml->table-row-col sxml 1 1 #f)))
(= 4 (tbl-column-count tbl))))))))) (test-equal "3 rows"
3
(length (sxml->table-row-col sxml 1 #f 1)))
(test-end "two-txn-test-2"))))

67
gnucash/report/standard-reports/trial-balance.scm
View File

@ -134,6 +134,47 @@
(define optname-show-rates (N_ "Show Exchange Rates")) (define optname-show-rates (N_ "Show Exchange Rates"))
(define opthelp-show-rates (N_ "Show the exchange rates used.")) (define opthelp-show-rates (N_ "Show the exchange rates used."))
;; utility to assist with double-column balance tables
;; a request is made with the <req> argument
;; <req> may currently be 'entry|'debit-q|'credit-q|'zero-q|'debit|'credit
;; 'debit-q|'credit-q|'zero-q tests the sign of the balance
;; 'side returns 'debit or 'credit, the column in which to display
;; 'debt|'credit return the entry, if appropriate, or #f
(define (double-col
req signed-balance report-commodity exchange-fn show-comm?)
(let* ((sum (and signed-balance
(gnc:sum-collector-commodity
signed-balance
report-commodity
exchange-fn)))
(amt (and sum (gnc:gnc-monetary-amount sum)))
(neg? (and amt (negative? amt)))
(bal (if neg?
(let ((bal (gnc:make-commodity-collector)))
(bal 'minusmerge signed-balance #f)
bal)
signed-balance))
(bal-sum (gnc:sum-collector-commodity
bal
report-commodity
exchange-fn))
(balance
(if (gnc:uniform-commodity? bal report-commodity)
(if (zero? amt) #f bal-sum)
(if show-comm?
(gnc-commodity-table bal report-commodity exchange-fn)
bal-sum))))
(car (assoc-ref
(list
(list 'entry balance)
(list 'debit (if neg? #f balance))
(list 'credit (if neg? balance #f))
(list 'zero-q (if neg? #f (if balance #f #t)))
(list 'debit-q (if neg? #f (if balance #t #f)))
(list 'credit-q (if neg? #t #f)))
req))))
;; options generator ;; options generator
(define (trial-balance-options-generator) (define (trial-balance-options-generator)
(let* ((options (gnc:new-options)) (let* ((options (gnc:new-options))
@ -441,10 +482,10 @@
;; with the proper arguments. ;; with the proper arguments.
;; (This is used to fill in the Trial Balance columns.) ;; (This is used to fill in the Trial Balance columns.)
(define (add-line table label signed-balance) (define (add-line table label signed-balance)
(let* ((entry (gnc:double-col (let* ((entry (double-col
'entry signed-balance 'entry signed-balance
report-commodity exchange-fn show-fcur?)) report-commodity exchange-fn show-fcur?))
(credit? (gnc:double-col (credit? (double-col
'credit-q signed-balance 'credit-q signed-balance
report-commodity exchange-fn show-fcur?)) report-commodity exchange-fn show-fcur?))
) )
@ -769,7 +810,7 @@
) )
(debit 'merge pos-adjusting #f) (debit 'merge pos-adjusting #f)
(credit 'merge neg-adjusting #f) (credit 'merge neg-adjusting #f)
(if (gnc:double-col (if (double-col
'credit-q pre-adjusting-bal 'credit-q pre-adjusting-bal
report-commodity exchange-fn show-fcur?) report-commodity exchange-fn show-fcur?)
(credit 'merge pre-adjusting-bal #f) (credit 'merge pre-adjusting-bal #f)
@ -839,10 +880,10 @@
neg-unrealized-gain-collector)) neg-unrealized-gain-collector))
(let* ((ug-row (+ header-rows (let* ((ug-row (+ header-rows
(gnc:html-acct-table-num-rows acct-table))) (gnc:html-acct-table-num-rows acct-table)))
(credit? (gnc:double-col (credit? (double-col
'credit-q neg-unrealized-gain-collector 'credit-q neg-unrealized-gain-collector
report-commodity exchange-fn show-fcur?)) report-commodity exchange-fn show-fcur?))
(entry (gnc:double-col (entry (double-col
'entry neg-unrealized-gain-collector 'entry neg-unrealized-gain-collector
report-commodity exchange-fn show-fcur?)) report-commodity exchange-fn show-fcur?))
) )
@ -908,14 +949,14 @@
(gross-bal? (list? bal)) (gross-bal? (list? bal))
(entry (and bal (entry (and bal
(not gross-bal?) (not gross-bal?)
(gnc:double-col (double-col
'entry bal 'entry bal
report-commodity report-commodity
exchange-fn exchange-fn
show-fcur?))) show-fcur?)))
(credit? (and bal (credit? (and bal
(or gross-bal? (or gross-bal?
(gnc:double-col (double-col
'credit-q bal 'credit-q bal
report-commodity report-commodity
exchange-fn exchange-fn
@ -936,7 +977,7 @@
)) ))
(debit-entry (debit-entry
(and gross-bal? (and gross-bal?
(gnc:double-col (double-col
'entry debit 'entry debit
report-commodity report-commodity
exchange-fn exchange-fn
@ -944,7 +985,7 @@
) )
(credit-entry (credit-entry
(and gross-bal? (and gross-bal?
(gnc:double-col (double-col
'entry credit 'entry credit
report-commodity report-commodity
exchange-fn exchange-fn
@ -1050,19 +1091,19 @@
(net-bs 'merge bs-debits #f) (net-bs 'merge bs-debits #f)
(net-bs 'minusmerge bs-credits #f) (net-bs 'minusmerge bs-credits #f)
(set! is-entry (set! is-entry
(gnc:double-col (double-col
'entry net-is report-commodity 'entry net-is report-commodity
exchange-fn show-fcur?)) exchange-fn show-fcur?))
(set! is-credit? (set! is-credit?
(gnc:double-col (double-col
'credit-q net-is report-commodity 'credit-q net-is report-commodity
exchange-fn show-fcur?)) exchange-fn show-fcur?))
(set! bs-entry (set! bs-entry
(gnc:double-col (double-col
'entry net-bs report-commodity 'entry net-bs report-commodity
exchange-fn show-fcur?)) exchange-fn show-fcur?))
(set! bs-credit? (set! bs-credit?
(gnc:double-col (double-col
'credit-q net-bs report-commodity 'credit-q net-bs report-commodity
exchange-fn show-fcur?)) exchange-fn show-fcur?))
(gnc:html-table-add-labeled-amount-line! (gnc:html-table-add-labeled-amount-line!

2
libgnucash/engine/test/CMakeLists.txt
View File

@ -217,7 +217,6 @@ gnc_add_test_with_guile(test-scm-query test-scm-query.cpp ENGINE_TEST_INCLUDE_DI
set(engine_test_SCHEME set(engine_test_SCHEME
test-account.scm test-account.scm
test-create-account.scm test-create-account.scm
test-test-extras.scm
test-split.scm test-split.scm
) )
@ -315,7 +314,6 @@ set(test_engine_SCHEME_DIST
test-extras.scm test-extras.scm
test-scm-query-import.scm test-scm-query-import.scm
test-split.scm test-split.scm
test-test-extras.scm
) )
set(test_engine_EXTRA_DIST set(test_engine_EXTRA_DIST

45
libgnucash/engine/test/test-test-extras.scm
View File

@ -1,45 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(debug-set! stack 50000)
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (gnucash engine test test-extras))
(use-modules (ice-9 streams))
(use-modules (gnucash engine))
(use-modules (sw_engine))
(define (run-test)
(test-create-account-structure))
(define (test-create-account-structure)
(let ((env (create-test-env)))
(let ((accounts (env-create-account-structure env (list "Assets"
(list (cons 'type ACCT-TYPE-ASSET))
(list "Bank Account")
(list "Savings"
(list "Instant")
(list "30 day notice"))))))
(and (= 3 (length accounts))
(equal? "Assets" (xaccAccountGetName (car accounts)))
))))