mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
[test-standard-net-linechart] upgrade to srfi-64 and sxml
This commit is contained in:
Christopher Lam
parent
c3253f9189
commit
62d8a65b99
@ -2,11 +2,11 @@ set(scm_test_standard_reports_SOURCES
|
||||
test-cash-flow.scm
|
||||
test-cashflow-barchart.scm
|
||||
test-standard-net-barchart.scm
|
||||
test-standard-net-linechart.scm
|
||||
)
|
||||
|
||||
set(scm_test_with_srfi64_SOURCES
|
||||
test-standard-category-report.scm
|
||||
test-standard-net-linechart.scm
|
||||
test-charts.scm
|
||||
test-transaction.scm
|
||||
test-balsheet-pnl.scm
|
||||
|
||||
@ -17,17 +17,15 @@
|
||||
;; 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/report/report-system" 0))
|
||||
(use-modules (gnucash engine))
|
||||
(use-modules (sw_engine))
|
||||
(use-modules (ice-9 format))
|
||||
(use-modules (ice-9 streams))
|
||||
(use-modules (srfi srfi-1))
|
||||
(use-modules (srfi srfi-64))
|
||||
(use-modules (gnucash report stylesheets))
|
||||
(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 standard-reports net-charts))
|
||||
|
||||
@ -35,196 +33,162 @@
|
||||
(setlocale LC_ALL "C")
|
||||
|
||||
(define (run-test)
|
||||
(test-runner-factory gnc:test-runner)
|
||||
(run-net-asset-test net-worth-linechart-uuid))
|
||||
|
||||
(define (set-option report page tag value)
|
||||
((gnc:option-setter (gnc:lookup-option (gnc:report-options report)
|
||||
page tag)) value))
|
||||
|
||||
|
||||
(define constructor (record-constructor <report>))
|
||||
(define (set-option options page tag value)
|
||||
((gnc:option-setter (gnc:lookup-option options page tag)) value))
|
||||
|
||||
(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)
|
||||
(single-txn-test asset-report-uuid)))
|
||||
(null-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.
|
||||
(define (null-test uuid)
|
||||
(let* ((template (gnc:find-report-template uuid))
|
||||
(options (gnc:make-report-options uuid))
|
||||
(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
|
||||
)))
|
||||
(let ((options (gnc:make-report-options uuid)))
|
||||
(gnc:options->render uuid options "test-standard-net-linechart" "null-test")))
|
||||
|
||||
(define (single-txn-test uuid)
|
||||
(let* ((template (gnc:find-report-template uuid))
|
||||
(options (gnc:make-report-options uuid))
|
||||
(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
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency))))
|
||||
(env-create-transaction env
|
||||
(gnc:get-start-this-month)
|
||||
my-income-account
|
||||
my-asset-account
|
||||
-1/1)
|
||||
(begin
|
||||
(set-option report gnc:pagename-display "Show table" #t)
|
||||
(set-option report gnc:pagename-general "Start Date"
|
||||
(cons 'absolute (gnc:get-start-this-month)))
|
||||
(set-option report gnc:pagename-general "End Date"
|
||||
(cons 'absolute (gnc:get-start-this-month)))
|
||||
(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* ((options (gnc:make-report-options uuid))
|
||||
(env (create-test-env))
|
||||
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency))))
|
||||
(env-create-transaction env
|
||||
(gnc:get-start-this-month)
|
||||
my-income-account
|
||||
my-asset-account
|
||||
-1/1)
|
||||
(set-option options gnc:pagename-display "Show table" #t)
|
||||
(set-option options gnc:pagename-general "Start Date"
|
||||
(cons 'absolute (gnc:get-start-this-month)))
|
||||
(set-option options gnc:pagename-general "End Date"
|
||||
(cons 'absolute (gnc:get-start-this-month)))
|
||||
(set-option options gnc:pagename-general "Step Size" 'DayDelta)
|
||||
(set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
|
||||
(set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
|
||||
(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))))
|
||||
(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)))))))))
|
||||
(let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
|
||||
"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 "4 columns"
|
||||
4
|
||||
(length (sxml->table-row-col sxml 1 1 #f)))
|
||||
(test-end "single-txn-test"))))
|
||||
|
||||
|
||||
(define (two-txn-test uuid)
|
||||
(let* ((template (gnc:find-report-template uuid))
|
||||
(options (gnc:make-report-options uuid))
|
||||
(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
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency)))
|
||||
(date-0 (gnc:get-start-this-month))
|
||||
(date-1 (gnc:time64-next-day date-0))
|
||||
(date-2 (gnc:time64-next-day date-1)))
|
||||
(env-create-transaction env
|
||||
date-1
|
||||
my-income-account
|
||||
my-asset-account
|
||||
-1/1)
|
||||
(env-create-transaction env
|
||||
date-2
|
||||
my-income-account
|
||||
my-asset-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))
|
||||
(let* ((options (gnc:make-report-options uuid))
|
||||
(env (create-test-env))
|
||||
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency)))
|
||||
(date-0 (gnc:get-start-this-month))
|
||||
(date-1 (gnc:time64-next-day date-0))
|
||||
(date-2 (gnc:time64-next-day date-1)))
|
||||
(env-create-transaction env
|
||||
date-1
|
||||
my-income-account
|
||||
my-asset-account
|
||||
-1/1)
|
||||
(env-create-transaction env
|
||||
date-2
|
||||
my-income-account
|
||||
my-asset-account
|
||||
-5/1)
|
||||
|
||||
(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))))
|
||||
(and (every (lambda (row)
|
||||
(and (equal? (second row) (fourth row))
|
||||
(= 0 (string->number (car (third row))))))
|
||||
tbl)
|
||||
(= 0 (tbl-ref->number tbl 0 1))
|
||||
(= 1 (tbl-ref->number tbl 1 1))
|
||||
(= 6 (tbl-ref->number tbl 2 1))
|
||||
(= 3 (tbl-row-count tbl))
|
||||
(= 4 (tbl-column-count tbl)))))))))
|
||||
(set-option options gnc:pagename-display "Show table" #t)
|
||||
(set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
|
||||
(set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
|
||||
(set-option options gnc:pagename-general "Step Size" 'DayDelta)
|
||||
(set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
|
||||
(set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
|
||||
(set-option options gnc:pagename-accounts "Accounts" (list my-asset-account))
|
||||
|
||||
(let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
|
||||
"two-txn-test" #:strip-tag "script")))
|
||||
(test-begin "two-txn-test")
|
||||
(test-equal "asset $0.00"
|
||||
'("$0.00")
|
||||
(sxml->table-row-col sxml 1 1 2))
|
||||
(test-equal "asset $1.00"
|
||||
'("$1.00")
|
||||
(sxml->table-row-col sxml 1 2 2))
|
||||
(test-equal "asset $6.00"
|
||||
'("$6.00")
|
||||
(sxml->table-row-col sxml 1 3 2))
|
||||
(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)
|
||||
(let* ((template (gnc:find-report-template uuid))
|
||||
(options (gnc:make-report-options uuid))
|
||||
(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
|
||||
(gnc-default-report-currency)))
|
||||
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency)))
|
||||
(date-0 (gnc:get-start-this-month))
|
||||
(date-1 (gnc:time64-next-day date-0))
|
||||
(date-2 (gnc:time64-next-day date-1)))
|
||||
(env-create-transaction env date-1 my-income-account my-asset-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-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* ((options (gnc:make-report-options uuid))
|
||||
(env (create-test-env))
|
||||
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET
|
||||
(gnc-default-report-currency)))
|
||||
(my-liability-account (env-create-root-account env ACCT-TYPE-LIABILITY
|
||||
(gnc-default-report-currency)))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE
|
||||
(gnc-default-report-currency)))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME
|
||||
(gnc-default-report-currency)))
|
||||
(date-0 (gnc:get-start-this-month))
|
||||
(date-1 (gnc:time64-next-day date-0))
|
||||
(date-2 (gnc:time64-next-day date-1)))
|
||||
(env-create-transaction env date-1 my-income-account my-asset-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-expense-account my-liability-account -5/1)
|
||||
|
||||
(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))))
|
||||
(and (every (lambda (row)
|
||||
(and (= (string->number (car (fourth row)))
|
||||
(+ (string->number (car (second row)))
|
||||
(string->number (car (third row)))))
|
||||
;; txns added in pairs, so assets = liability
|
||||
(equal? (second row) (third row))))
|
||||
tbl)
|
||||
(= 0 (tbl-ref->number tbl 0 1))
|
||||
(= 1 (tbl-ref->number tbl 1 1))
|
||||
(= 6 (tbl-ref->number tbl 2 1))
|
||||
(= 3 (tbl-row-count tbl))
|
||||
(= 4 (tbl-column-count tbl)))))))))
|
||||
(set-option options gnc:pagename-display "Show table" #t)
|
||||
(set-option options gnc:pagename-general "Start Date" (cons 'absolute date-0))
|
||||
(set-option options gnc:pagename-general "End Date" (cons 'absolute date-2))
|
||||
(set-option options gnc:pagename-general "Step Size" 'DayDelta)
|
||||
(set-option options gnc:pagename-general "Price Source" 'pricedb-nearest)
|
||||
(set-option options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
|
||||
(set-option options gnc:pagename-accounts "Accounts" (list my-asset-account my-liability-account))
|
||||
|
||||
(let ((sxml (gnc:options->sxml uuid options "test-standard-net-linechart"
|
||||
"two-txn-test-2" #:strip-tag "script")))
|
||||
(test-begin "two-txn-test-2")
|
||||
(test-equal "asset $0.00"
|
||||
'("$0.00")
|
||||
(sxml->table-row-col sxml 1 1 2))
|
||||
(test-equal "asset $1.00"
|
||||
'("$1.00")
|
||||
(sxml->table-row-col sxml 1 2 2))
|
||||
(test-equal "asset $6.00"
|
||||
'("$6.00")
|
||||
(sxml->table-row-col sxml 1 3 2))
|
||||
(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-2"))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user