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

Merge branch 'scheme-progress' of https://github.com/christopherlam/gnucash into maint

Browse Source
This commit is contained in:
Geert Janssens 2018-05-12 14:07:59 +02:00
commit 7f91cb82d7
41 changed files with 838 additions and 788 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
gnucash/report/business-reports/CMakeLists.txt
View File

@ -1,3 +1,4 @@
add_subdirectory (test)
set (business_reports_SCHEME
aging.scm

20
gnucash/report/business-reports/customer-summary.scm
View File

@ -97,16 +97,6 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (num-col columns-used)
@ -590,11 +580,11 @@
(gnc:html-table-append-row!
table
(list
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br>")))
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>")))
(gnc:html-table-append-row!
table
(list "<br>"))
(set-last-row-style!
(list "<br/>"))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -612,7 +602,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -635,7 +625,7 @@
(gnc:html-table-append-row! table (list (if name name "")))
(gnc:html-table-append-row! table (list (string-expand
(if addy addy "")
#\newline "<br>")))
#\newline "<br/>")))
(gnc:html-table-append-row! table (list
(strftime
date-format

27
gnucash/report/business-reports/easy-invoice.scm
View File

@ -33,21 +33,12 @@
(use-modules (srfi srfi-1))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(use-modules (gnucash utilities))
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (gnucash report standard-reports))
(use-modules (gnucash report business-reports))
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (description-col columns-used)
@ -573,10 +564,10 @@
(gnc:html-table-append-row!
table
(list
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br>")))
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>")))
(gnc:html-table-append-row!
table
(list "<br>"))
(list "<br/>"))
(for-each
(lambda (order)
(let* ((reference (gncOrderGetReference order)))
@ -587,7 +578,7 @@
;; This string is supposed to be an abbrev. for "Reference"?
(string-append (_ "REF") ":&nbsp;" reference))))))
orders)
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -607,7 +598,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -789,7 +780,7 @@
(gnc:make-html-text
(string-append
(_ "Billing ID") ":&nbsp;"
(string-expand billing-id #\newline "<br>"))))
(string-expand billing-id #\newline "<br/>"))))
(make-break! document)))))
(if (opt-val "Display" "Billing Terms")
@ -801,7 +792,7 @@
(gnc:make-html-text
(string-append
(_ "Terms") ":&nbsp;"
(string-expand terms #\newline "<br>")))))))
(string-expand terms #\newline "<br/>")))))))
(make-break! document)
@ -823,14 +814,14 @@
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-expand notes #\newline "<br>"))))
(string-expand notes #\newline "<br/>"))))
(make-break! document)
(make-break! document)))
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-expand (opt-val "Text" "Extra Notes") #\newline "<br>")
(string-expand (opt-val "Text" "Extra Notes") #\newline "<br/>")
))
; close the framing table

19
gnucash/report/business-reports/fancy-invoice.scm
View File

@ -51,21 +51,12 @@
(use-modules (srfi srfi-1))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(use-modules (gnucash utilities))
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (gnucash report standard-reports))
(use-modules (gnucash report business-reports))
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (description-col columns-used)
@ -631,7 +622,7 @@
(gnc:html-table-cell-set-style!
name-cell "td"
'font-size "+2")
(gnc:html-table-append-row! table (list name-cell "" "")) ;;Bert: had a newline and a "<br>"
(gnc:html-table-append-row! table (list name-cell "" "")) ;;Bert: had a newline and a "<br/>"
(gnc:html-table-append-row!
table
(list
@ -648,7 +639,7 @@
(list
(string-append (_ "REF") ":&nbsp;" reference))))))
orders)
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -673,7 +664,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -936,7 +927,7 @@
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-expand notes #\newline "<br>")))))
(string-expand notes #\newline "<br/>")))))
(make-break! document)

33
gnucash/report/business-reports/invoice.scm
View File

@ -27,21 +27,12 @@
(use-modules (srfi srfi-1))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(use-modules (gnucash utilities))
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (gnucash report standard-reports))
(use-modules (gnucash report business-reports))
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (description-col columns-used)
@ -550,10 +541,10 @@
(gnc:html-table-append-row!
table
(list
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br>")))
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>")))
(gnc:html-table-append-row!
table
(list "<br>"))
(list "<br/>"))
(for-each
(lambda (order)
(let* ((reference (gncOrderGetReference order)))
@ -563,7 +554,7 @@
(list
(string-append (_ "REF") ":&nbsp;" reference))))))
orders)
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -584,7 +575,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -604,7 +595,7 @@
(gnc:html-table-append-row! table (list (if name name "")))
(gnc:html-table-append-row! table (list (string-expand
(if addy addy "")
#\newline "<br>")))
#\newline "<br/>")))
(gnc:html-table-append-row! table (list
(strftime
date-format
@ -727,7 +718,7 @@
(gnc:make-html-text
(string-append
(_ "Reference") ":&nbsp;"
(string-expand billing-id #\newline "<br>"))))
(string-expand billing-id #\newline "<br/>"))))
(make-break! document)))))
(if (opt-val "Display" "Billing Terms")
@ -740,7 +731,7 @@
(gnc:make-html-text
(string-append
(_ "Terms") ":&nbsp;"
(string-expand terms #\newline "<br>"))))
(string-expand terms #\newline "<br/>"))))
(make-break! document))
)))
@ -755,14 +746,14 @@
(gnc:make-html-text
(string-append
(_ "Job number") ":&nbsp;"
(string-expand jobnumber #\newline "<br>"))))
(string-expand jobnumber #\newline "<br/>"))))
(make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(_ "Job name") ":&nbsp;"
(string-expand jobname #\newline "<br>"))))
(string-expand jobname #\newline "<br/>"))))
(make-break! document)
(make-break! document)
)))
@ -777,7 +768,7 @@
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-expand notes #\newline "<br>")))))
(string-expand notes #\newline "<br/>")))))
(make-break! document)
@ -785,7 +776,7 @@
document
(gnc:make-html-text
(gnc:html-markup-br)
(string-expand (opt-val "Display" "Extra Notes") #\newline "<br>")
(string-expand (opt-val "Display" "Extra Notes") #\newline "<br/>")
(gnc:html-markup-br))))
; else

14
gnucash/report/business-reports/job-report.scm
View File

@ -46,16 +46,6 @@
(define desc-header (N_ "Description"))
(define amount-header (N_ "Amount"))
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
@ -482,7 +472,7 @@
(gnc:html-table-append-row!
table
(list "<br/>"))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -500,7 +490,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))

20
gnucash/report/business-reports/owner-report.scm
View File

@ -117,16 +117,6 @@
(else
(_ "Vendor"))))
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
@ -688,11 +678,11 @@
(gnc:html-table-append-row!
table
(list
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br>")))
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>")))
(gnc:html-table-append-row!
table
(list "<br>"))
(set-last-row-style!
(list "<br/>"))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -710,7 +700,7 @@
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -731,7 +721,7 @@
(gnc:html-table-append-row! table (list (if name name "")))
(gnc:html-table-append-row! table (list (string-expand
(if addy addy "")
#\newline "<br>")))
#\newline "<br/>")))
(gnc:html-table-append-row! table (list
(strftime
date-format

2
gnucash/report/business-reports/receipt.scm
View File

@ -191,7 +191,7 @@
notespage optname-extra-notes "a"
(N_ "Notes added at end of invoice -- may contain HTML markup")
""))
;(N_ "(Development version -- don't rely on the numbers on this report without double-checking them.<br>Change the 'Extra Notes' option to get rid of this message)")))
;(N_ "(Development version -- don't rely on the numbers on this report without double-checking them.<br/>Change the 'Extra Notes' option to get rid of this message)")))
(gnc:options-set-default-section
report-options generalpage)

2
gnucash/report/business-reports/taxinvoice.scm
View File

@ -237,7 +237,7 @@
notespage optname-extra-notes "a"
(_ "Notes added at end of invoice -- may contain HTML markup.")
(_ "Thank you for your patronage!")))
;(N_ "(Development version -- don't rely on the numbers on this report without double-checking them.<br>Change the 'Extra Notes' option to get rid of this message)")))
;(N_ "(Development version -- don't rely on the numbers on this report without double-checking them.<br/>Change the 'Extra Notes' option to get rid of this message)")))
(add-option (gnc:make-text-option notespage optname-extra-css "b"
(N_ "Embedded CSS.") "h1.coyname { text-align: left; }"))

31
gnucash/report/business-reports/test/CMakeLists.txt Normal file
View File

@ -0,0 +1,31 @@
set(scm_test_business_reports_with_srfi64_SOURCES
)
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-engine
scm-test-engine
scm-gettext
scm-scm
scm-test-report-system
scm-report-stylesheets
)
if (HAVE_SRFI64)
gnc_add_scheme_tests("${scm_test_business_reports_with_srfi64_SOURCES}")
endif (HAVE_SRFI64)
gnc_add_scheme_targets(scm-test-business-reports
"${scm_test_business_reports_SOURCES}"
gnucash/report/business-reports/test
"scm-test-business-support"
FALSE
)
add_dependencies(check scm-test-business-reports)
set_dist_list(test_business_reports_DIST CMakeLists.txt
${scm_test_business_reports_with_srfi64_SOURCES}
)

1
gnucash/report/report-system/CMakeLists.txt
View File

@ -52,7 +52,6 @@ set (report_system_SCHEME
set (report_system_SCHEME_2a
collectors.scm
list-extras.scm
)
set (report_system_SCHEME_2b

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

@ -333,15 +333,15 @@
;; Binary search. Returns highest index with content less than or
;; equal to the supplied value.
(define (binary-search-lt <= value vector)
(define (search low high)
(let* ((midpoint (+ low (ceiling (/ (- high low) 2))))
(midvalue (vector-ref vector midpoint)))
(if (= low high)
(if (<= midvalue value)
low #f)
(if (<= midvalue value)
(search midpoint high)
(search low (- midpoint 1))))))
(if (= 0 (vector-length vector)) #f
(search 0 (- (vector-length vector) 1))))
(define (binary-search-lt <= val vec)
(and (not (zero? (vector-length vec)))
(let loop ((low 0)
(high (1- (vector-length vec))))
(let* ((midpoint (ceiling (/ (+ low high) 2)))
(midvalue (vector-ref vec midpoint)))
(if (= low high)
(and (<= midvalue val)
low)
(if (<= midvalue val)
(loop midpoint high)
(loop low (1- midpoint))))))))

7
gnucash/report/report-system/html-table.scm
View File

@ -756,3 +756,10 @@
(push (gnc:html-document-markup-end doc "table"))
(gnc:html-document-pop-style doc)
retval))
(define (gnc:html-table-set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (1- (gnc:html-table-num-rows table))
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))

12
gnucash/report/report-system/html-text.scm
View File

@ -190,7 +190,7 @@
(define (gnc:html-markup-anchor href . rest)
(apply gnc:html-markup/attr
"a"
(string-append "href=\"" href "\"")
(format #f "href=~s" href)
rest))
(define (gnc:html-markup-img src . rest)
@ -198,15 +198,11 @@
"img"
(with-output-to-string
(lambda ()
(display "src=\"") (display src) (display"\"")
(display " ")
(for-each
(lambda (kvp)
(display (car kvp))
(display "=\"")
(display (cadr kvp))
(display "\" "))
rest)))))
(format #f "~a=~s " (car kvp) (cadr kvp)))
(cons (list 'src src)
rest))))))
(define (gnc:html-text-render p doc)
(let* ((retval '())

71
gnucash/report/report-system/html-utilities.scm
View File

@ -22,12 +22,12 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (gnucash utilities))
;; returns a list with n #f (empty cell) values
(define (gnc:html-make-empty-cell) #f)
(define (gnc:html-make-empty-cells n)
(if (> n 0)
(cons #f (gnc:html-make-empty-cells (- n 1)))
(list)))
(make-list n #f))
(define (gnc:register-guid type guid)
(gnc-build-url URL-TYPE-REGISTER (string-append type guid) ""))
@ -814,10 +814,69 @@
(gnc:html-markup-p
(gnc:html-markup-anchor
(gnc-build-url URL-TYPE-OPTIONS
(string-append "report-id=" (format #f "~a" report-id))
"")
(format #f "report-id=~a" report-id)
"")
(_ "Edit report options")))))
(define* (gnc:html-render-options-changed options #:optional plaintext?)
;; options -> html-object or string, depending on plaintext?. This
;; summarises options that were changed by the user. Set plaintext?
;; to #t for unit-tests only.
(define (disp d)
;; option-value -> string. The option is passed to various
;; scm->string converters; ultimately a generic stringify
;; function handles symbol/string/other types.
(define (try proc)
;; Try proc with d as a parameter, catching 'wrong-type-arg
;; exceptions to return #f to the or evaluator.
(catch 'wrong-type-arg
(lambda () (proc d))
(const #f)))
(or (and (boolean? d) (if d (_ "Enabled") (_ "Disabled")))
(and (null? d) "null")
(and (list? d) (string-join (map disp d) ", "))
(and (pair? d) (format #f "~a . ~a"
(car d)
(if (eq? (car d) 'absolute)
(qof-print-date (cdr d))
(disp (cdr d)))))
(try gnc-commodity-get-mnemonic)
(try xaccAccountGetName)
(try gnc-budget-get-name)
(format #f "~a" d)))
(let ((render-list '()))
(define (add-option-if-changed option)
(let* ((section (gnc:option-section option))
(name (gnc:option-name option))
(default-value (gnc:option-default-value option))
(value (gnc:option-value option))
(retval (cons (format #f "~a / ~a" section name)
(disp value))))
(if (not (or (equal? default-value value)
(char=? (string-ref section 0) #\_)))
(addto! render-list retval))))
(gnc:options-for-each add-option-if-changed options)
(if plaintext?
(string-append
(string-join
(map (lambda (item)
(format #f "~a: ~a\n" (car item) (cdr item)))
render-list)
"")
"\n")
(apply
gnc:make-html-text
(apply
append
(map
(lambda (item)
(list
(gnc:html-markup-b (car item))
": "
(cdr item)
(gnc:html-markup-br)))
render-list))))))
(define (gnc:html-make-generic-warning
report-title-string report-id
warning-title-string warning-string)
@ -877,3 +936,5 @@
((#\>) "&gt;")
(else c))))
str))))

47
gnucash/report/report-system/list-extras.scm
View File

@ -1,47 +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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report report-system list-extras))
(use-modules (srfi srfi-1))
(export list-min-max)
(export list-leaves)
(export function-compose)
(define (list-min-max list ordered?)
(define (helper list min max)
(if (null? list) (cons min max)
(let ((elt (car list)))
(helper (cdr list)
(if (ordered? elt min) elt min)
(if (ordered? elt max) max elt)))))
(helper (cdr list) (car list) (car list)))
(define (list-leaves list)
(if (not (pair? list))
(cons list '())
(fold (lambda (next acc)
(append (list-leaves next)
acc))
'()
list)))
(define (function-compose f1 f2)
(lambda a
(f1 (apply f2 a))))

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

@ -30,7 +30,6 @@
(use-modules (gnucash app-utils))
(use-modules (gnucash engine))
(use-modules (gnucash report report-system collectors))
(use-modules (gnucash report report-system list-extras))
(export account-destination-alist)
(export category-by-account-report)
@ -150,13 +149,13 @@
(splits-up-to (map car account-alist) min-date max-date)))
(define (category-report-dates-intervals dates)
(let* ((min-date (car (list-min-max (map first dates) <)))
(max-date (cdr (list-min-max (map second dates) <))))
(let* ((min-date (apply min (map first dates)))
(max-date (apply max (map second dates))))
(list min-date max-date dates)))
(define (category-report-dates-accumulate dates)
(let* ((min-date #f)
(max-date (cdr (list-min-max dates <)))
(max-date (apply max dates))
(datepairs (reverse! (cdr (fold (lambda (next acc)
(let ((prev (car acc))
(pairs-so-far (cdr acc)))

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

@ -112,6 +112,7 @@
(export gnc:html-build-acct-table)
(export gnc:first-html-build-acct-table)
(export gnc:html-make-exchangerates)
(export gnc:html-render-options-changed)
(export gnc:html-make-generic-warning)
(export gnc:html-make-no-account-warning)
(export gnc:html-make-generic-budget-warning)
@ -600,6 +601,7 @@
(export gnc:html-table-set-col-headers-style!)
(export gnc:html-table-row-headers-style)
(export gnc:html-table-set-row-headers-style!)
(export gnc:html-table-set-last-row-style!)
(export gnc:html-table-set-style!)
(export gnc:html-table-set-col-style!)
(export gnc:html-table-set-row-style!)

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

@ -12,9 +12,8 @@ gnc_add_test_with_guile(test-link-module-report-system test-link-module.c
set(scm_test_report_system_SOURCES
test-load-report-system-module.scm
test-collectors.scm
test-list-extras.scm
test-report-utilities.scm
# test-test-extras.scm ;;FIXME why is this not run
test-test-extras.scm
)
set (scm_test_report_system_with_srfi64_SOURCES
@ -31,7 +30,7 @@ set(GUILE_DEPENDS
scm-scm
scm-report-system-3
)
gnc_add_scheme_tests(${scm_test_report_system_SOURCES})
gnc_add_scheme_tests("${scm_test_report_system_SOURCES}")
if (HAVE_SRFI64)
gnc_add_scheme_tests ("${scm_test_report_system_with_srfi64_SOURCES}")

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

@ -21,21 +21,18 @@
(use-modules (gnucash gnc-module))
(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system))
(use-modules (sxml simple))
(use-modules (sxml xpath))
(export pattern-streamer)
(export create-option-set)
(export option-set-setter)
(export option-set-getter)
(export tbl-column-count)
(export tbl-row-count)
(export tbl-ref)
(export tbl-ref->number)
;;
;; Random report test related syntax and the like
;;
(export gnc:options->sxml)
;;
;; Table parsing
@ -88,69 +85,56 @@
(define (tbl-ref->number tbl row-index column-index)
(string->number (car (tbl-ref tbl row-index column-index))))
;;
;; Test sinks
;;
(define (make-test-sink) (list 'sink 0 '()))
(define (gnc:options->sxml uuid options prefix test-title)
;; uuid - str to locate report uuid
;; options object -> sxml tree
;; prefix - str describing tests e.g. "test-trep"
;; test-title: str describing each unit test e.g. "test disable filter"
;;
;; This function abstracts the report renderer. It also catches XML
;; parsing errors, dumping the options changed.
;;
;; It also dumps the render into /tmp/XX-YY.html where XX is the
;; test prefix and YY is the test title.
(define (test-sink-count sink)
(second sink))
(define (test-sink-count! sink value)
(set-car! (cdr sink) value))
(define (test-sink-messages sink)
(third sink))
(define (test-sink-messages! sink messages)
(set-car! (cdr (cdr sink)) messages))
(define (test-sink-check sink message flag)
(test-sink-count! sink (+ (test-sink-count sink) 1))
(if flag #t
(test-sink-messages! sink (cons message (test-sink-messages sink)))))
(define (test-sink-report sink)
(format #t "Completed ~a tests ~a\n"
(test-sink-count sink)
(if (null? (test-sink-messages sink)) "PASS" "FAIL"))
(if (null? (test-sink-messages sink)) #t
(begin (for-each (lambda (delayed-message)
(delayed-format-render #t delayed-message))
(test-sink-messages sink))
#f)))
(define (delayed-format . x) x)
(define (delayed-format-render stream msg)
(apply format stream msg))
;;
;; options
;;
(define (create-option-set)
(make-hash-table) )
(define (option-set-setter option-set)
(lambda (category name value)
(hash-set! option-set (list category name) value)))
(define (option-set-getter option-set)
(lambda (category name)
(hash-ref option-set (list category name))))
;;
;;
;;
(define (report-show-options stream expense-options)
(gnc:options-for-each (lambda (option)
(format stream "Option: ~a.~a Value ~a\n"
(gnc:option-section option)
(gnc:option-name option)
(gnc:option-value option)))
expense-options))
(let* ((template (gnc:find-report-template uuid))
(constructor (record-constructor <report>))
(report (constructor uuid "bar" options #t #t #f #f ""))
(renderer (gnc:report-template-renderer template))
(document (renderer report))
(sanitize-char (lambda (c)
(if (or (char-alphabetic? c)
(char-numeric? c)) c #\-)))
(fileprefix (string-map sanitize-char prefix))
(filename (string-map sanitize-char test-title)))
(gnc:html-document-set-style-sheet! document (gnc:report-stylesheet report))
(if test-title
(gnc:html-document-set-title! document test-title))
(let* ((filename (format #f "/tmp/~a-~a.html" fileprefix filename))
(render (gnc:html-document-render document)))
(with-output-to-file filename
(lambda ()
(display render)))
(catch 'parser-error
(lambda () (xml->sxml render))
(lambda (k . args)
(format #t "*** XML error. see render output at ~a\n~a"
filename (gnc:html-render-options-changed options #t))
(throw k args))))))
(export sxml->table-row-col)
(define (sxml->table-row-col sxml tbl row col)
;; sxml - sxml input tree
;; tbl - table number (e.g. 2 = second table in tree)
;; row - row number (negative counts from bottom) or #f (all rows)
;; or zero (retrieves <th> headers)
;; col - col number (negative counts from right) or all cols
;;
;; output: list-of-string
(let* ((tbl-path `(table ,tbl))
(row-path (if (and row (not (zero? row))) `(tr ,row) 'tr))
(col-tag (if (and row (zero? row)) 'th 'td))
(col-path (if col `(,col-tag ,col) col-tag))
(xpath `(// ,tbl-path // ,row-path // ,col-path // *text*)))
((sxpath xpath) sxml)))

30
gnucash/report/report-system/test/test-html-utilities-srfi64.scm
View File

@ -6,37 +6,11 @@
(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report report-system))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (srfi srfi-64))
(define (test-runner)
(let ((runner (test-runner-null))
(num-passed 0)
(num-failed 0))
(test-runner-on-test-end! runner
(lambda (runner)
(format #t "[~a] line:~a, test: ~a\n"
(test-result-ref runner 'result-kind)
(test-result-ref runner 'source-line)
(test-runner-test-name runner))
(case (test-result-kind runner)
((pass xpass) (set! num-passed (1+ num-passed)))
((fail xfail)
(if (test-result-ref runner 'expected-value)
(format #t "~a\n -> expected: ~s\n -> obtained: ~s\n"
(string-join (test-runner-group-path runner) "/")
(test-result-ref runner 'expected-value)
(test-result-ref runner 'actual-value)))
(set! num-failed (1+ num-failed)))
(else #t))))
(test-runner-on-final! runner
(lambda (runner)
(format #t "Source:~a\npass = ~a, fail = ~a\n"
(test-result-ref runner 'source-file) num-passed num-failed)
(zero? num-failed)))
runner))
(define (run-test)
(test-runner-factory test-runner)
(test-runner-factory gnc:test-runner)
(test-begin "test-html-utilities-srfi64.scm")
(test-gnc:html-string-sanitize)
(test-end "test-html-utilities-srfi64.scm"))

42
gnucash/report/report-system/test/test-list-extras.scm
View File

@ -1,42 +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 report report-system list-extras))
(use-modules (gnucash engine test test-extras))
(define (run-test)
(test test-list-min-max))
(define (test-list-min-max)
(and (equal? (cons 1 1) (list-min-max (list 1) <))
(equal? (cons 1 2) (list-min-max (list 1 2) <))
(equal? (cons 1 2) (list-min-max (list 2 1) <))
(equal? (cons 1 2) (list-min-max (list 1 1 2) <))
(equal? (cons 1 2) (list-min-max (list 1 2 1) <))
(equal? (cons 1 2) (list-min-max (list 1 2 2) <))
(equal? (cons 1 2) (list-min-max (list 2 1 1) <))
(equal? (cons 1 2) (list-min-max (list 2 2 1) <))
(equal? (cons 1 3) (list-min-max (list 1 1 3) <))
(equal? (cons 1 3) (list-min-max (list 1 2 3) <))
(equal? (cons 1 3) (list-min-max (list 1 3 2) <))
(equal? (cons 1 3) (list-min-max (list 2 3 1) <))
(equal? (cons 1 3) (list-min-max (list 3 2 1) <))))

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

@ -24,10 +24,7 @@
(use-modules (ice-9 streams))
(define (run-test)
(and (logging-and #t)
(logging-and)
(not (logging-and #t #f))
(test-pattern-streamer)
(and (test-pattern-streamer)
(test-create-account-structure)))
(define (test-pattern-streamer)

28
gnucash/report/standard-reports/income-gst-statement.scm
View File

@ -35,23 +35,27 @@
(use-modules (gnucash report standard-reports transaction))
;; Define the strings here to avoid typos and make changes easier.
(define reportname (N_ "Income & GST Statement"))
(define reportname (N_ "Income and GST Statement"))
(define pagename-sorting (N_ "Sorting"))
(define pagename-filter (N_ "Filter"))
(define TAX-SETUP-DESC
(string-append
(gnc:make-html-text
(_ "This report is useful to calculate periodic business tax payable/receivable from
authorities. From <i>Edit report options</i> above, choose your Business Income and Business Expense accounts.
authorities. From 'Edit report options' above, choose your Business Income and Business Expense accounts.
Each transaction may contain, in addition to the accounts payable/receivable or bank accounts,
a split to a tax account, e.g. Income:Sales -$1000, Liability:GST on Sales -$100, Asset:Bank $1100.")
"<br/><br/>"
(gnc:html-markup-br)
(gnc:html-markup-br)
(_ "These tax accounts can either be populated using the standard register, or from Business Invoices and Bills
which will require Business > Sales Tax Tables to be set up correctly. Please see the documentation.")
"<br/><br/>"
which will require Tax Tables to be set up correctly. Please see the documentation.")
(gnc:html-markup-br)
(gnc:html-markup-br)
(_ "From the Report Options, you will need to select the accounts which will \
hold the GST/VAT taxes collected or paid. These accounts must contain splits which document the \
monies which are wholly sent or claimed from tax authorities during periodic GST/VAT returns. These \
accounts must be of type ASSET for taxes paid on expenses, and type LIABILITY for taxes collected on sales.")
"<br/><br/>"))
(gnc:html-markup-br)
(gnc:html-markup-br)))
(define (income-gst-statement-renderer rpt)
(trep-renderer rpt
@ -63,10 +67,9 @@ accounts must be of type ASSET for taxes paid on expenses, and type LIABILITY fo
;; split -> bool
;;
;; additional split filter - returns #t if split must be included
;; we need to exclude Closing, Link and Payment transactions
(let ((trans (xaccSplitGetParent split)))
(and (member (xaccTransGetTxnType trans) (list TXN-TYPE-NONE TXN-TYPE-INVOICE))
(not (xaccTransGetIsClosingTxn trans)))))
;; we need to exclude Link and Payment transactions
(memv (xaccTransGetTxnType (xaccSplitGetParent split))
(list TXN-TYPE-NONE TXN-TYPE-INVOICE)))
(define (gst-statement-options-generator)
@ -115,6 +118,9 @@ for taxes paid on expenses, and type LIABILITY for taxes collected on sales.")
(gnc:option-make-internal! options gnc:pagename-accounts "Filter Type")
(gnc:option-make-internal! options gnc:pagename-accounts "Filter By...")
(gnc:option-make-internal! options gnc:pagename-general "Show original currency amount")
;; Disallow closing transactions
(gnc:option-set-value (gnc:lookup-option options pagename-filter "Closing transactions") 'exclude-closing)
(gnc:option-make-internal! options pagename-filter "Closing transactions")
;; Disable display options not being used anymore
(gnc:option-make-internal! options gnc:pagename-display "Shares")
(gnc:option-make-internal! options gnc:pagename-display "Price")

14
gnucash/report/standard-reports/register.scm
View File

@ -29,16 +29,6 @@
(gnc:module-load "gnucash/report/report-system" 0)
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
(define (set-last-row-style! table tag . rest)
(let ((arg-list
(cons table
(cons (- (gnc:html-table-num-rows table) 1)
(cons tag rest)))))
(apply gnc:html-table-set-row-style! arg-list)))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (num-col columns-used)
@ -793,7 +783,7 @@
(list
(string-append (_ "Client") ":&nbsp;")
(string-expand address #\newline "<br>")))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
@ -813,7 +803,7 @@
(string-expand (qof-print-date (current-time))
#\space "&nbsp;"))
(make-client-table address)))
(set-last-row-style!
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))

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

@ -8,6 +8,7 @@ set(scm_test_standard_reports_SOURCES
set(scm_test_with_srfi64_SOURCES
test-transaction.scm
test-income-gst.scm
)
set(scm_test_report_SUPPORT

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

@ -39,9 +39,9 @@
(setlocale LC_ALL "C")
(define (run-test)
(logging-and (test-in-txn)
(test-out-txn)
(test-null-txn)))
(and (test-in-txn)
(test-out-txn)
(test-null-txn)))
(define (set-option report page tag value)

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

@ -40,15 +40,15 @@
(define constructor (record-constructor <report>))
(define (run-net-asset-income-test asset-report-uuid income-report-uuid)
(logging-and (two-txn-test asset-report-uuid)
(two-txn-test-2 asset-report-uuid)
(two-txn-test-income 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 income-report-uuid)
(single-txn-test asset-report-uuid)
(closing-test income-report-uuid)
#t))
(null-test asset-report-uuid)
(null-test income-report-uuid)
(single-txn-test asset-report-uuid)
(closing-test income-report-uuid)
#t))
;; Just prove that the report exists.
(define (null-test uuid)

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

@ -40,13 +40,11 @@
(define constructor (record-constructor <report>))
(define (run-net-asset-test asset-report-uuid)
(logging-and (two-txn-test asset-report-uuid)
(two-txn-test-2 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)
#t))
(null-test asset-report-uuid)
(single-txn-test asset-report-uuid)))
;; Just prove that the report exists.
(define (null-test uuid)

213
gnucash/report/standard-reports/test/test-income-gst.scm Normal file
View File

@ -0,0 +1,213 @@
(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 (gnucash report standard-reports income-gst-statement))
(use-modules (gnucash report stylesheets))
(use-modules (gnucash report report-system))
(use-modules (gnucash report report-system test test-extras))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (sxml simple))
(use-modules (sxml xpath))
;; This is implementation testing for Income & GST report. This
;; delegates to the Transaction Report, therefore, only the
;; GSTR-specific options will be individually tested. Foreign-currency
;; conversions will NOT be tested, because they require pricedb entries.
;; see transaction.scm for explanatory notes and hints.
;; copied from income-gst-statement.scm
(define rpt-uuid "5bf27f249a0d11e7abc4cec278b6b50a")
;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C")
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "income-gst-statement.scm")
(null-test)
(gstr-tests)
(test-end "income-gst-statement.scm"))
(define (options->sxml options test-title)
(gnc:options->sxml rpt-uuid options "test-gstr" test-title))
(define (set-option! options section name value)
(let ((option (gnc:lookup-option options section name)))
(if option
(gnc:option-set-value option value)
(test-assert (format #f "wrong-option ~a ~a" section name) #f))))
(define structure
(list "Root" (list (cons 'type ACCT-TYPE-ASSET))
(list "GST"
(list "GST on Purchases")
(list "GST on Sales" (list (cons 'type ACCT-TYPE-LIABILITY)))
(list "Reduced GST on Sales" (list (cons 'type ACCT-TYPE-LIABILITY))))
(list "Asset"
(list "Bank")
(list "A/Receivable" (list (cons 'type ACCT-TYPE-RECEIVABLE))))
(list "Liability" (list (cons 'type ACCT-TYPE-PAYABLE))
(list "CreditCard")
(list "A/Payable"))
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
))
(define (null-test)
;; This null-test tests for the presence of report.
(let ((options (gnc:make-report-options rpt-uuid)))
(test-assert "null-test" (options->sxml options "null-test"))))
(define (gstr-tests)
;; This function will perform implementation testing on the transaction report.
(let* ((env (create-test-env))
(account-alist (env-create-account-structure-alist env structure))
(bank (cdr (assoc "Bank" account-alist)))
(income (cdr (assoc "Income" account-alist)))
(expense (cdr (assoc "Expenses" account-alist)))
(creditcard (cdr (assoc "CreditCard" account-alist)))
(payable (cdr (assoc "A/Payable" account-alist)))
(receivable (cdr (assoc "A/Receivable" account-alist)))
(gst-sales (cdr (assoc "GST on Sales" account-alist)))
(reduced-gst-sales (cdr (assoc "Reduced GST on Sales" account-alist)))
(gst-purch (cdr (assoc "GST on Purchases" account-alist)))
(YEAR (gnc:time64-get-year (gnc:get-today))))
(define (default-testing-options)
;; To ease testing of transaction report, we will set default
;; options for generating reports. We will elable extra columns
;; for Exporting, disable generation of informational text, and
;; disable indenting. These options will be tested separately as
;; the first test group. By default, we'll select the modern dates.
(let ((options (gnc:make-report-options rpt-uuid)))
(set-option! options "Accounts" "Accounts" (list income expense payable receivable))
(set-option! options "Accounts" "Tax Accounts" (list gst-sales
reduced-gst-sales
gst-purch))
(set-option! options "General" "Add options summary" 'always)
(set-option! options "General" "Table for Exporting" #t)
(set-option! options "General" "Start Date" (cons 'relative 'start-cal-year))
(set-option! options "General" "End Date" (cons 'relative 'end-cal-year))
options))
(define* (create-txn DD MM YY DESC list-of-splits #:optional txn-type)
(let ((txn (xaccMallocTransaction (gnc-get-current-book))))
(xaccTransBeginEdit txn)
(xaccTransSetDescription txn DESC)
(xaccTransSetCurrency txn (gnc-default-report-currency))
(xaccTransSetDate txn DD MM YY)
(for-each
(lambda (tfr)
(let ((split (xaccMallocSplit (gnc-get-current-book))))
(xaccSplitSetParent split txn)
(xaccSplitSetAccount split (cdr tfr))
(xaccSplitSetValue split (car tfr))
(xaccSplitSetAmount split (car tfr))))
list-of-splits)
(if txn-type
(xaccTransSetTxnType txn txn-type))
(xaccTransCommitEdit txn)
txn))
;; This will make all accounts use default currency (I think depends on locale)
(for-each
(lambda(pair)
(xaccAccountSetCommodity (cdr pair) (gnc-default-report-currency)))
account-alist)
(create-txn 1 1 YEAR "invoice charge $100, no GST"
(list (cons -100 income)
(cons 100 receivable))
TXN-TYPE-INVOICE)
(create-txn 2 1 YEAR "invoice charge $200+$20GST"
(list (cons -200 income)
(cons -20 gst-sales)
(cons 220 receivable))
TXN-TYPE-INVOICE)
(create-txn 3 1 YEAR "receive $320 for invoices from bank"
(list (cons -320 receivable)
(cons 320 bank))
TXN-TYPE-PAYMENT)
(create-txn 4 1 YEAR "cash sales $300+$15GST5%"
(list (cons -300 income)
(cons -15 reduced-gst-sales)
(cons 315 bank)))
(create-txn 5 1 YEAR "cash spend $50, no GST"
(list (cons -50 bank)
(cons 50 expense)))
(create-txn 6 1 YEAR "purchase on credit $80+$8GST"
(list (cons -88 payable)
(cons 80 expense)
(cons 8 gst-purch))
TXN-TYPE-INVOICE)
(create-txn 7 1 YEAR "hybrid paycheck. earn $400+$20, less $110+$10"
(list (cons 310 bank)
(cons -400 income)
(cons -20 reduced-gst-sales)
(cons 100 expense)
(cons 10 gst-purch)))
(create-txn 8 1 YEAR "pay bill from 6-january for $88 using creditcard"
(list (cons 88 payable)
(cons -88 creditcard))
TXN-TYPE-PAYMENT)
(create-txn 2 2 YEAR "link"
(list (cons -77 income)
(cons 77 income))
TXN-TYPE-LINK)
(create-txn 3 2 YEAR "payment"
(list (cons -22 income)
(cons 22 income))
TXN-TYPE-PAYMENT)
(xaccTransSetIsClosingTxn
(create-txn 3 2 YEAR "closing"
(list (cons -33 income)
(cons 33 income)))
#t)
;; Finally we can begin testing
(test-begin "display options")
(let ((options (default-testing-options)))
(set-option! options "Display" "Num" #f)
(set-option! options "Display" "Memo" #f)
(set-option! options "Display" "Account Name" #f)
(set-option! options "Sorting" "Primary Subtotal" 'date)
(set-option! options "Sorting" "Secondary Subtotal" 'account-name)
(let ((sxml (options->sxml options "initial setup")))
(test-equal "totals are as expected"
'("Grand Total" " " " " "$1,055.00" "$1,000.00" "$55.00" "$248.00" "$230.00" "$18.00")
(sxml->table-row-col sxml 1 -1 #f))
(test-equal "tax on sales as expected"
'(" " "\n" "$20.00" "$20.00" " " " " "\n" "$20.00" "$20.00" "\n" "$15.00" "$15.00" "$55.00")
(sxml->table-row-col sxml 1 #f 6))
(test-equal "tax on purchases as expected"
'(" " " " " " " " "\n" "$8.00" "\n" "$10.00" "$18.00" " " " " "$18.00")
(sxml->table-row-col sxml 1 #f 9)))
(set-option! options "Display" "Individual tax columns" #t)
(set-option! options "Display" "Individual expense columns" #t)
(set-option! options "Display" "Individual income columns" #t)
(set-option! options "Display" "Remittance amount" #t)
(set-option! options "Display" "Net Income" #t)
(set-option! options "Display" "Tax payable" #t)
(let ((sxml (options->sxml options "display options enabled")))
(test-equal "all display columns enabled"
'("Grand Total" " " " " "$1,055.00" "$1,000.00" "$20.00" "$35.00" "$248.00" "$230.00" "$18.00" "$807.00" "$770.00" "$37.00")
(sxml->table-row-col sxml 1 -1 #f))))
(test-end "display options")))

228
gnucash/report/standard-reports/test/test-transaction.scm
View File

@ -6,10 +6,11 @@
(use-modules (gnucash report report-system))
(use-modules (gnucash report report-system test test-extras))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (sxml simple))
(use-modules (sxml xpath))
(use-modules (system vm coverage)
(system vm vm))
(use-modules (system vm coverage))
(use-modules (system vm vm))
;; Guide to the test-transaction.scm
@ -24,7 +25,7 @@
;; which sets the SRFI-64 test runner, and initiates the proper test suite
;; in (null-test) and (trep-tests). Please note the tests will all call
;; (options->sxml) which in turn generates the transaction report, and
;; dumps the output at /tmp/out-XX.html for review.
;; dumps the output at /tmp/test-trep-*.html for review.
;; For coverage analysis, please amend (run-test) (if #f ...) to (if
;; #t ...) and this will run (coverage-test) instead, which will
@ -42,33 +43,6 @@
;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C")
(define (test-runner)
(let ((runner (test-runner-null))
(num-passed 0)
(num-failed 0))
(test-runner-on-test-end! runner
(lambda (runner)
(format #t "[~a] line:~a, test: ~a\n"
(test-result-ref runner 'result-kind)
(test-result-ref runner 'source-line)
(test-runner-test-name runner))
(case (test-result-kind runner)
((pass xpass) (set! num-passed (1+ num-passed)))
((fail xfail)
(if (test-result-ref runner 'expected-value)
(format #t "~a\n -> expected: ~s\n -> obtained: ~s\n"
(string-join (test-runner-group-path runner) "/")
(test-result-ref runner 'expected-value)
(test-result-ref runner 'actual-value)))
(set! num-failed (1+ num-failed)))
(else #t))))
(test-runner-on-final! runner
(lambda (runner)
(format #t "Source:~a\npass = ~a, fail = ~a\n"
(test-result-ref runner 'source-file) num-passed num-failed)
(zero? num-failed)))
runner))
(define (run-test)
(if #f
(coverage-test)
@ -86,7 +60,7 @@
(close port)))))
(define (run-test-proper)
(test-runner-factory test-runner)
(test-runner-factory gnc:test-runner)
(test-begin "transaction.scm")
(null-test)
(trep-tests)
@ -110,63 +84,17 @@
(memv c '(#\- #\.))))
str)))
(define counter
(let ((count 0))
(lambda ()
(set! count (1+ count))
count)))
(define (options->sxml options test-title)
;; options object -> sxml tree
;;
;; This function abstracts the whole transaction report renderer.
;; It also catches XML parsing errors, dumping the options changed.
;;
;; It also dumps the render into /tmp/out-N.html where N is a counter
(let* ((template (gnc:find-report-template trep-uuid))
(report (constructor trep-uuid "bar" options #t #t #f #f ""))
(renderer (gnc:report-template-renderer template))
(document (renderer report)))
(gnc:html-document-set-style-sheet! document (gnc:report-stylesheet report))
(if test-title
(gnc:html-document-set-title! document test-title))
(let* ((filename (format #f "/tmp/out-~a.html" (counter)))
(render (gnc:html-document-render document))
(outfile (open-file filename "w")))
(display render outfile)
(close-output-port outfile)
(catch 'parser-error
(lambda () (xml->sxml render))
(lambda (k . args)
(test-assert k #f) ; XML parse error doesn't cause a crash but logs as a failure
(format #t "see render output at ~a\n~a" filename (gnc:render-options-changed options #t)))))))
;; It also dumps the render into /tmp/test-trep-XX.html where XX is the test title
(gnc:options->sxml trep-uuid options "test-trep" test-title))
(define (get-row-col sxml row col)
;; sxml, row & col (numbers or #f) -> list-of-string
;;
;; from an SXML table tree with tr/th/td elements, retrieve row/col
;; if row = 0 retrieve <tr><th> elements
;; if row = #f retrieve whole <td> col, excludes <th> cols
;; if col = #f retrieve whole <tr> row
;; if both = #f retrieve all text elements
;;
;; NOTE: This will retrieve cells from the first table in the tree.
;; If there are multiple tables, I recommend that the tree is first
;; pruned to the desired table via e.g. '(// (table 2)) then sent as
;; argument to this function.
(let ((xpath (cond
((not (or row col)) '(// (table 1) // tr // *text*))
((not row) `(// (table 1) // tr // (td ,col) // *text*))
((and (equal? row 0) (not col)) '(// (table 1) // tr // th // *text*))
((not col) `(// (table 1) // (tr ,row) // td // *text*))
((equal? row 0) `(// (table 1) // tr // (th ,col) // *text*))
(else `(// (table 1) // (tr ,row) // (td ,col) // *text*)))))
((sxpath xpath) sxml)))
;;
;; END CANDIDATES
;;
(define constructor (record-constructor <report>))
(sxml->table-row-col sxml 1 row col))
(define (set-option! options section name value)
(let ((option (gnc:lookup-option options section name)))
@ -189,12 +117,13 @@
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY)))
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
))
(define (null-test)
;; This null-test tests for the presence of report.
(let ((options (gnc:make-report-options trep-uuid)))
(test-assert "null-test" (options->sxml options "null-test")))) ;out-1.html
(test-assert "null-test" (options->sxml options "null-test"))))
(define (trep-tests)
;; This function will perform implementation testing on the transaction report.
@ -207,6 +136,7 @@
(income (cdr (assoc "Income" account-alist)))
(expense (cdr (assoc "Expenses" account-alist)))
(liability (cdr (assoc "Liabilities" account-alist)))
(equity (cdr (assoc "Equity" account-alist)))
(YEAR (gnc:time64-get-year (gnc:get-today)))
(foreign1 (gnc-commodity-table-lookup
(gnc-commodity-table-get-table (gnc-account-get-book bank))
@ -293,6 +223,10 @@
(xaccTransSetNotes txn "multisplit")
(xaccTransCommitEdit txn))
;; A single closing transaction
(let ((closing-txn (env-transfer env 31 12 1999 expense equity 111 #:description "Closing")))
(xaccTransSetIsClosingTxn closing-txn #t))
;; A couple of transactions which involve foreign currency
;; conversions. We'll set the currencies to GBP and USD.
(env-transfer-foreign env 15 01 2000 gbp-bank usd-bank 10 14 #:description "GBP 10 to USD 14")
@ -325,7 +259,7 @@
(test-begin "general options")
(let* ((options (default-testing-options))
(sxml (options->sxml options "general options")) ;out-2.html
(sxml (options->sxml options "general options"))
(default-headers '("Date" "Num" "Description" "Memo/Notes" "Account" "Amount")))
(test-equal "default headers"
default-headers
@ -351,9 +285,9 @@
(set-option! options "Sorting" "Primary Subtotal" #t)
(set-option! options "Sorting" "Secondary Key" 'date)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
(let ((sxml (options->sxml options "test basic column headers, and original currency"))) ;out-3.html
(let ((sxml (options->sxml options "test basic column headers, and original currency")))
(test-equal "default headers, indented, includes common-currency"
'(" " " " "Date" "Num" "Description" "Memo/Notes" "Account" "Amount" "USD" "Amount")
'(" " " " "Date" "Num" "Description" "Memo/Notes" "Account" "Amount (USD)" "Amount")
(get-row-col sxml 0 #f))
(test-equal "grand total present, no blank cells, and is $2,280 in both common-currency and original-currency"
'("Grand Total" "$2,280.00" "$2,280.00")
@ -377,19 +311,19 @@
;; Filter Account Name Filters
(set-option! options "Filter" "Account Name Filter" "Expenses")
(let ((sxml (options->sxml options "accounts filter expenses"))) ;out-4.html
(let ((sxml (options->sxml options "accounts filter expenses")))
(test-equal "account name filter to 'expenses', sum = $31.00"
'("$31.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Account Name Filter" "Expen.es")
(let ((sxml (options->sxml options "accounts filter expen.es"))) ;out-5.html
(let ((sxml (options->sxml options "accounts filter expen.es")))
(test-equal "account name filter to 'expen.es', blank report"
'()
(get-row-col sxml #f #f)))
(set-option! options "Filter" "Use regular expressions for account name filter" #t)
(let ((sxml (options->sxml options "accounts filter expen.es regex"))) ;out-6.html
(let ((sxml (options->sxml options "accounts filter expen.es regex")))
(test-equal "account name filter to 'expen.es' and switch on regex filter, sum = $31.00"
'("$31.00")
(get-row-col sxml -1 -1)))
@ -399,19 +333,19 @@
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1969)))
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
(set-option! options "Filter" "Transaction Filter" "desc-3")
(let ((sxml (options->sxml options "transaction filter to ponies"))) ;out-7.html
(let ((sxml (options->sxml options "transaction filter to ponies")))
(test-equal "transaction filter in bank to 'desc-3', sum = $29.00"
'("$29.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Transaction Filter" "not.s?")
(let ((sxml (options->sxml options "transaction filter not.s?"))) ;out-8.html
(let ((sxml (options->sxml options "transaction filter not.s?")))
(test-equal "transaction filter in bank to 'not.s?', blank report"
'()
(get-row-col sxml #f #f)))
(set-option! options "Filter" "Use regular expressions for transaction filter" #t)
(let ((sxml (options->sxml options "transaction filter not.s? regex"))) ;out-9.html
(let ((sxml (options->sxml options "transaction filter not.s? regex")))
(test-equal "transaction filter in bank to 'not.s?' and switch regex, sum = -$23.00"
'("-$23.00")
(get-row-col sxml -1 -1)))
@ -421,19 +355,19 @@
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1969)))
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
(set-option! options "Filter" "Reconcile Status" 'unreconciled)
(let ((sxml (options->sxml options "unreconciled"))) ;out-10.html
(let ((sxml (options->sxml options "unreconciled")))
(test-equal "filter unreconciled only, sum = -$20.00"
'("-$20.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Reconcile Status" 'cleared)
(let ((sxml (options->sxml options "cleared"))) ;out-11.html
(let ((sxml (options->sxml options "cleared")))
(test-equal "filter cleared only, sum = $29.00"
'("$29.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Reconcile Status" 'reconciled)
(let ((sxml (options->sxml options "reconciled"))) ;out-12.html
(let ((sxml (options->sxml options "reconciled")))
(test-equal "filter reconciled only, sum = -$8.00"
'("-$8.00")
(get-row-col sxml -1 -1)))
@ -444,13 +378,13 @@
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
(set-option! options "Accounts" "Filter By..." (list income))
(set-option! options "Accounts" "Filter Type" 'include)
(let ((sxml (options->sxml options "including bank-income accts only"))) ;out-13.html
(let ((sxml (options->sxml options "including bank-income accts only")))
(test-equal "filter includes bank-income, sum = -$29.00"
'("$29.00")
(get-row-col sxml -1 -1)))
(set-option! options "Accounts" "Filter Type" 'exclude)
(let ((sxml (options->sxml options "bank exclude bank-income accts"))) ;out-14.html
(let ((sxml (options->sxml options "bank exclude bank-income accts")))
(test-equal "filter excludes bank-income, sum = -$28.00"
'("-$28.00")
(get-row-col sxml -1 -1)))
@ -460,16 +394,40 @@
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1969)))
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
(set-option! options "Filter" "Void Transactions" 'void-only)
(let ((sxml (options->sxml options "void only"))) ;out-15.html
(let ((sxml (options->sxml options "void only")))
(test-equal "filter void-transactions only, sum = -$10.00"
'("$10.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Void Transactions" 'both)
(let ((sxml (options->sxml options "both void and non-void"))) ;out-16.html
(let ((sxml (options->sxml options "both void and non-void")))
(test-equal "filter void-transactions only, sum = $11.00"
'("$11.00")
(get-row-col sxml -1 -1))))
(get-row-col sxml -1 -1)))
;; Test Closing-Txn Filters
(set! options (default-testing-options))
(set-option! options "Accounts" "Accounts" (list expense))
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1911)))
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 2012)))
(set-option! options "Filter" "Closing transactions" 'exclude-closing)
(let ((sxml (options->sxml options "filter closing - exclude closing txns ")))
(test-equal "filter exclude closing. bal = $111"
'("$111.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Closing transactions" 'closing-only)
(let ((sxml (options->sxml options "filter closing - include closing only")))
(test-equal "filter closing only. bal = -$111"
'("-$111.00")
(get-row-col sxml -1 -1)))
(set-option! options "Filter" "Closing transactions" 'include-both)
(let ((sxml (options->sxml options "filter closing - include both")))
(test-equal "filter include both. bal = $0"
'("$0.00")
(get-row-col sxml -1 -1)))
)
(test-end "accounts selectors and filtering")
@ -483,7 +441,7 @@
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
"Totals"))
(let ((sxml (options->sxml options "all columns off"))) ;out-17.html
(let ((sxml (options->sxml options "all columns off")))
(test-assert "all display columns off, except amount and subtotals are enabled, there should be 2 columns"
(= (length ((sxpath '(// (table 1) // (tr 1) // th)) sxml))
(length ((sxpath '(// (table 1) // (tr 4) // td)) sxml))
@ -494,7 +452,7 @@
(set-option! options "Sorting" "Primary Subtotal for Date Key" 'none)
(set-option! options "Sorting" "Secondary Subtotal" #f)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'none)
(let ((sxml (options->sxml options "only amounts"))) ;out-18.html
(let ((sxml (options->sxml options "only amounts")))
(test-assert "all display columns off, and no subtotals, but amount enabled, there should be 1 column"
(= (length ((sxpath '(// (table 1) // (tr 1) // th)) sxml))
(length ((sxpath '(// (table 1) // (tr 4) // td)) sxml))
@ -502,7 +460,7 @@
1)))
(set-option! options "Display" "Amount" 'none)
(let ((sxml (options->sxml options "no columns"))) ;out-19.html
(let ((sxml (options->sxml options "no columns")))
(test-assert "all display columns off, without amount nor subtotals, there should be 0 column"
(= (length ((sxpath '(// (table 1) // (tr 1) // th)) sxml))
(length ((sxpath '(// (table 1) // (tr 4) // td)) sxml))
@ -513,7 +471,7 @@
(set-option! options "Sorting" "Primary Subtotal for Date Key" 'weekly)
(set-option! options "Sorting" "Secondary Subtotal" #t)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'weekly)
(let ((sxml (options->sxml options "subtotals only"))) ;out-20.html
(let ((sxml (options->sxml options "subtotals only")))
(test-assert "all display columns including amount are disabled, but subtotals are enabled, there should be 1 column"
(= (length ((sxpath '(// (table 1) // (tr 1) // th)) sxml))
(length ((sxpath '(// (table 1) // (tr -1) // td)) sxml))
@ -531,7 +489,7 @@
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
"Totals" "Use Full Other Account Name" "Use Full Account Name"))
(let* ((sxml (options->sxml options "all columns on"))) ;out-21.html
(let* ((sxml (options->sxml options "all columns on")))
(test-equal "all display columns on, displays correct columns"
(list "Date" "Reconciled Date" "Num" "Description" "Memo/Notes" "Account"
"Transfer from/to" "Shares" "Price" "Amount" "Running Balance")
@ -560,7 +518,7 @@
(set-option! options "Sorting" "Primary Subtotal for Date Key" 'none)
(set-option! options "Sorting" "Secondary Subtotal" #f)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'none)
(let* ((sxml (options->sxml options "multiline"))) ;out-22.html
(let* ((sxml (options->sxml options "multiline")))
(test-assert "multi line transaction with 1st split have same memo"
(apply string=? (get-row-col sxml #f 4)))
@ -573,7 +531,7 @@
;; Remove expense multisplit, transaction is not shown
(set-option! options "Accounts" "Filter By..." (list expense))
(set-option! options "Accounts" "Filter Type" 'exclude)
(let* ((sxml (options->sxml options "multiline, filtered out"))) ;out-23.html
(let* ((sxml (options->sxml options "multiline, filtered out")))
(test-equal "multi-line has been excluded"
'()
(get-row-col sxml #f #f)))
@ -586,10 +544,10 @@
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 2000)))
(set-option! options "General" "Common Currency" #t)
(set-option! options "General" "Show original currency amount" #t)
(let* ((sxml (options->sxml options "single column, with original currency headers"))) ;out-24.html
(let* ((sxml (options->sxml options "single column, with original currency headers")))
(test-equal "single amount column, with original currency headers"
(list "Date" "Num" "Description" "Memo/Notes" "Account"
"Amount" "USD" "Amount")
"Amount (USD)" "Amount")
(get-row-col sxml 0 #f)))
(set-option! options "Display" "Amount" 'double)
@ -597,7 +555,7 @@
(set-option! options "Display" "Account Code" #t)
(set-option! options "Display" "Other Account Name" #t)
(set-option! options "Display" "Other Account Code" #t)
(let* ((sxml (options->sxml options "dual column"))) ;out-25.html
(let* ((sxml (options->sxml options "dual column")))
;; Note. It's difficult to test converted monetary
;; amounts. Although I've set transfers from USD/GBP, the
;; transfers do not update the pricedb automatically,
@ -606,7 +564,7 @@
;; output here too.
(test-equal "dual amount headers"
(list "Date" "Num" "Description" "Memo/Notes" "Account" "Transfer from/to"
"Debit" "USD" "Credit" "USD" "Debit" "Credit")
"Debit (USD)" "Credit (USD)" "Debit" "Credit")
(get-row-col sxml 0 #f))
(test-equal "Account Name and Code displayed"
(list "01-GBP Root.Asset.GBP Bank")
@ -638,21 +596,21 @@
(set-option! options "Sorting" "Primary Subtotal" #f)
(set-option! options "Sorting" "Secondary Key" 'description)
(set-option! options "Sorting" "Secondary Subtotal" #f)
(let* ((sxml (options->sxml options "sign-reversal is none, correct signs of amounts?"))) ;out-26.html
(let* ((sxml (options->sxml options "sign-reversal is none, correct signs of amounts?")))
(test-equal "sign-reversal is none, correct signs of amounts"
'(#f #t #t #f #f #t #t #t #t #f #f #f #f #t)
(map (lambda (s) (not (string-contains s "-")))
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
(set-option! options "Display" "Sign Reverses" 'income-expense)
(let* ((sxml (options->sxml options "sign-reversal is income-expense, correct signs of amounts?"))) ;out-27.html
(let* ((sxml (options->sxml options "sign-reversal is income-expense, correct signs of amounts?")))
(test-equal "sign-reversal is income-expense, correct signs of amounts"
'(#f #t #t #f #f #f #f #f #f #t #t #f #f #t)
(map (lambda (s) (not (string-contains s "-")))
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
(set-option! options "Display" "Sign Reverses" 'credit-accounts)
(let* ((sxml (options->sxml options "sign-reversal is credit-accounts, correct signs of amounts?"))) ;out-28.html
(let* ((sxml (options->sxml options "sign-reversal is credit-accounts, correct signs of amounts?")))
(test-equal "sign-reversal is credit-accounts, correct signs of amounts"
'(#f #t #t #f #f #t #t #t #t #t #t #t #t #f)
(map (lambda (s) (not (string-contains s "-")))
@ -665,10 +623,10 @@
(set-option! options "General" "Show original currency amount" #t)
(set-option! options "Sorting" "Primary Key" 'date)
(set-option! options "Sorting" "Primary Subtotal for Date Key" 'none)
(let* ((sxml (options->sxml options "dual columns"))) ;out-29.html
(let* ((sxml (options->sxml options "dual columns")))
(test-equal "dual amount column, with original currency headers"
(list "Date" "Num" "Description" "Memo/Notes" "Account"
"Debit" "USD" "Credit" "USD" "Debit" "Credit")
"Debit (USD)" "Credit (USD)" "Debit" "Credit")
(get-row-col sxml 0 #f))
(test-equal "dual amount column, grand totals available"
(list "Grand Total" " " " " " " " " "$2,280.00" "$2,280.00")
@ -696,42 +654,48 @@
(set-option! options "Sorting" "Secondary Subtotal" #f)
(set-option! options "Sorting" "Primary Key" 'date)
(let* ((sxml (options->sxml options "sorting=date"))) ;out-30.html
(let* ((sxml (options->sxml options "sorting=date")))
(test-equal "dates are sorted"
'("12/31/69" "12/31/69" "01/01/70" "02/01/70" "02/10/70")
(get-row-col sxml #f 1)))
(set-option! options "Sorting" "Primary Key" 'number)
(let* ((sxml (options->sxml options "sorting=number"))) ;out-31.html
(let* ((sxml (options->sxml options "sorting=number")))
(test-equal "sort by number"
'("trn1" "trn2" "trn3" "trn4" "trn7")
(get-row-col sxml #f 2)))
(set-option! options "Sorting" "Primary Key" 'reconciled-status)
(let* ((sxml (options->sxml options "sorting=reconciled-status"))) ;out-32.html
(let* ((sxml (options->sxml options "sorting=reconciled-status")))
(test-equal "sort by reconciled status"
'("desc-2" "desc-7" "desc-3" "desc-1" "desc-4")
(get-row-col sxml #f 3)))
(set-option! options "Sorting" "Primary Key" 'memo)
(let* ((sxml (options->sxml options "sorting=memo"))) ;out-33.html
(let* ((sxml (options->sxml options "sorting=memo")))
(test-equal "sort by memo"
'("notes3" "memo-1" "memo-2" "memo-3")
(get-row-col sxml #f 4)))
(set-option! options "Sorting" "Primary Key" 'account-name)
(let* ((sxml (options->sxml options "sorting=account-name"))) ;out-34.html
(let* ((sxml (options->sxml options "sorting=account-name")))
(test-assert "account names are sorted"
(sorted? (get-row-col sxml #f 5) string<?)))
(set-option! options "Sorting" "Primary Key" 'corresponding-acc-name)
(let* ((sxml (options->sxml options "sorting=corresponding-acc-name"))) ;out-35.html
(let* ((sxml (options->sxml options "sorting=corresponding-acc-name")))
(test-equal "sort by corresponding-acc-name"
'("Expenses" "Expenses" "Income" "Income" "Liabilities")
(get-row-col sxml #f 6)))
(set-option! options "Sorting" "Primary Key" 'notes)
(let* ((sxml (options->sxml options "sorting=trans-notes")))
(test-equal "sort by transaction notes"
'("memo-3" "memo-2" "memo-1" "notes3")
(get-row-col sxml #f 4)))
(set-option! options "Sorting" "Primary Key" 'amount)
(let* ((sxml (options->sxml options "sorting=amount"))) ;out-36.html
(let* ((sxml (options->sxml options "sorting=amount")))
(test-equal "sort by amount"
'("-$15.00" "-$8.00" "-$5.00" "$10.00" "$29.00")
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml)))
@ -746,7 +710,7 @@
(set-option! options "Display" "Totals" #t)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
(let* ((sxml (options->sxml options "sorting=account-name, date-quarterly, subtotals only"))) ;out-37.html
(let* ((sxml (options->sxml options "sorting=account-name, date-quarterly, subtotals only")))
(test-equal "sorting=account-name, date-quarterly, subtotals only"
'("$570.00" "$570.00" "$570.00" "$570.00" "$2,280.00" "$2,280.00")
(get-row-col sxml #f -1)))
@ -764,30 +728,30 @@
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
(set-option! options "Sorting" "Show Informal Debit/Credit Headers" #t)
(set-option! options "Sorting" "Show Account Description" #t)
(let* ((sxml (options->sxml options "sorting=date"))) ;out-38.html
(let* ((sxml (options->sxml options "sorting=date")))
(test-equal "expense acc friendly headers"
'("\n" "Expenses" "Expense" "Rebate")
'("\n" "Expenses" "\n" "Expense" "\n" "Rebate")
(get-row-col sxml 47 #f))
(test-equal "income acc friendly headers"
'("\n" "Income" "Charge" "Income")
'("\n" "Income" "\n" "Charge" "\n" "Income")
(get-row-col sxml 69 #f)))
(set-option! options "Accounts" "Accounts" (list bank))
(set-option! options "Display" "Totals" #f)
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
(let* ((sxml (options->sxml options "sorting=date quarterly"))) ;out-39.html
(let* ((sxml (options->sxml options "sorting=date quarterly")))
(test-equal "quarterly subtotals are correct"
'("$570.00" "$570.00" "$570.00" "$570.00")
(get-row-col sxml #f 4)))
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
(let* ((sxml (options->sxml options "sorting=date monthly"))) ;out-40.html
(let* ((sxml (options->sxml options "sorting=date monthly")))
(test-equal "monthly subtotals are correct"
'("$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00")
(get-row-col sxml #f 4)))
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'yearly)
(let* ((sxml (options->sxml options "sorting=date yearly"))) ;out-41.html
(let* ((sxml (options->sxml options "sorting=date yearly")))
(test-equal "yearly subtotals are correct"
'("$2,280.00")
(get-row-col sxml #f 4)))
@ -797,14 +761,14 @@
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #f)
(set-option! options "Filter" "Void Transactions" 'both)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'daily)
(let* ((sxml (options->sxml options "sorting=date"))) ;out-42.html
(let* ((sxml (options->sxml options "sorting=date")))
(test-equal "daily subtotals are correct"
'("$39.00")
(get-row-col sxml 5 4)))
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'weekly)
(let* ((sxml (options->sxml options "sorting=date weekly"))) ;out-43.html
(let* ((sxml (options->sxml options "sorting=date weekly")))
(test-equal "weekly subtotals are correct (1)"
'("$34.00" "$89.00")
(get-row-col sxml #f 4))
@ -825,7 +789,7 @@
(set-option! options "Sorting" "Primary Subtotal" #t)
(set-option! options "Sorting" "Secondary Key" 'date)
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
(let ((sxml (options->sxml options "subtotal table"))) ;out-44.html
(let ((sxml (options->sxml options "subtotal table")))
(test-equal "summary bank-row is correct"
(list "Bank" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00"
"$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$2,280.00")
@ -845,7 +809,7 @@
(set-option! options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 01 01 1969)))
(set-option! options "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
(let ((sxml (options->sxml options "sparse subtotal table"))) ;out-45.html
(let ((sxml (options->sxml options "sparse subtotal table")))
(test-equal "sparse summary-table - row 1"
(list "Bank" "$29.00" "-$5.00" "-$23.00" "$1.00")
(get-row-col sxml 1 #f))

266
gnucash/report/standard-reports/transaction.scm
View File

@ -17,6 +17,7 @@
;; - add support for indenting for better grouping
;; - add defaults suitable for a reconciliation report
;; - add subtotal summary grid
;; - by default, exclude closing transactions from the report
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -39,7 +40,7 @@
(define-module (gnucash report standard-reports transaction))
(use-modules (gnucash utilities))
(use-modules (gnucash utilities))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-11))
(use-modules (srfi srfi-13))
@ -49,9 +50,6 @@
(gnc:module-load "gnucash/report/report-system" 0)
(define-macro (addto! alist element)
`(set! ,alist (cons ,element ,alist)))
;; Define the strings here to avoid typos and make changes easier.
(define reportname (N_ "Transaction Report"))
@ -98,6 +96,7 @@
(define optname-transaction-matcher-regex (N_ "Use regular expressions for transaction filter"))
(define optname-reconcile-status (N_ "Reconcile Status"))
(define optname-void-transactions (N_ "Void Transactions"))
(define optname-closing-transactions (N_ "Closing transactions"))
;;Styles
(define def:grand-total-style "grand-total")
@ -113,15 +112,8 @@ in the Options panel."))
(define DATE-SORTING-TYPES (list 'date 'reconciled-date))
;; The option-values of the sorting key multichoice option, for
;; which a subtotal should be enabled.
(define SUBTOTAL-ENABLED (list 'account-name 'corresponding-acc-name
'account-code 'corresponding-acc-code
'reconciled-status))
(define ACCOUNT-SORTING-TYPES (list 'account-name 'corresponding-acc-name
'account-code 'corresponding-acc-code))
(define CUSTOM-SORTING (list 'reconciled-status))
(define SORTKEY-INFORMAL-HEADERS (list 'account-name 'account-code))
@ -152,13 +144,13 @@ in the Options panel."))
(cons 'renderer-fn (lambda (a) (xaccSplitGetAccount a)))))
(cons 'date (list (cons 'sortkey (list SPLIT-TRANS TRANS-DATE-POSTED))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (s) (xaccTransGetDate (xaccSplitGetParent s))))
(cons 'text (_ "Date"))
(cons 'tip (_ "Sort by date."))
(cons 'renderer-fn #f)))
(cons 'reconciled-date (list (cons 'sortkey (list SPLIT-DATE-RECONCILED))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (s) (xaccSplitGetDateReconciled s)))
(cons 'text (_ "Reconciled Date"))
(cons 'tip (_ "Sort by the Reconciled Date."))
(cons 'renderer-fn #f)))
@ -195,42 +187,48 @@ in the Options panel."))
(cons 'renderer-fn (lambda (a) (xaccSplitGetAccount (xaccSplitGetOtherSplit a))))))
(cons 'amount (list (cons 'sortkey (list SPLIT-VALUE))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (a) (gnc-numeric-to-scm (xaccSplitGetValue a))))
(cons 'text (_ "Amount"))
(cons 'tip (_ "Sort by amount."))
(cons 'renderer-fn #f)))
(cons 'description (list (cons 'sortkey (list SPLIT-TRANS TRANS-DESCRIPTION))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (s) (xaccTransGetDescription (xaccSplitGetParent s))))
(cons 'text (_ "Description"))
(cons 'tip (_ "Sort by description."))
(cons 'renderer-fn #f)))
(cons 'renderer-fn (lambda (s) (xaccTransGetDescription (xaccSplitGetParent s))))))
(if (and (gnc-current-session-exist)
(qof-book-use-split-action-for-num-field (gnc-get-current-book)))
(cons 'number (list (cons 'sortkey (list SPLIT-ACTION))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (a) (xaccSplitGetAction a)))
(cons 'text (_ "Number/Action"))
(cons 'tip (_ "Sort by check number/action."))
(cons 'renderer-fn #f)))
(cons 'number (list (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (a) (xaccTransGetNum (xaccSplitGetParent a))))
(cons 'text (_ "Number"))
(cons 'tip (_ "Sort by check/transaction number."))
(cons 'renderer-fn #f))))
(cons 't-number (list (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (a) (xaccTransGetNum (xaccSplitGetParent a))))
(cons 'text (_ "Transaction Number"))
(cons 'tip (_ "Sort by transaction number."))
(cons 'renderer-fn #f)))
(cons 'memo (list (cons 'sortkey (list SPLIT-MEMO))
(cons 'split-sortvalue #f)
(cons 'split-sortvalue (lambda (s) (xaccSplitGetMemo s)))
(cons 'text (_ "Memo"))
(cons 'tip (_ "Sort by memo."))
(cons 'renderer-fn #f)))
(cons 'renderer-fn (lambda (s) (xaccSplitGetMemo s)))))
(cons 'notes (list (cons 'sortkey #f)
(cons 'split-sortvalue (lambda (s) (xaccTransGetNotes (xaccSplitGetParent s))))
(cons 'text (_ "Notes"))
(cons 'tip (_ "Sort by transaction notes."))
(cons 'renderer-fn (lambda (s) (xaccTransGetNotes (xaccSplitGetParent s))))))
(cons 'none (list (cons 'sortkey '())
(cons 'split-sortvalue #f)
@ -258,36 +256,42 @@ in the Options panel."))
(list
(cons 'none (list
(cons 'split-sortvalue #f)
(cons 'date-sortvalue #f)
(cons 'text (_ "None"))
(cons 'tip (_ "None."))
(cons 'renderer-fn #f)))
(cons 'daily (list
(cons 'split-sortvalue (lambda (s) (time64-day (split->time64 s))))
(cons 'date-sortvalue time64-day)
(cons 'text (_ "Daily"))
(cons 'tip (_ "Daily."))
(cons 'renderer-fn (lambda (s) (time64->daily-string (split->time64 s))))))
(cons 'weekly (list
(cons 'split-sortvalue (lambda (s) (time64-week (split->time64 s))))
(cons 'date-sortvalue time64-week)
(cons 'text (_ "Weekly"))
(cons 'tip (_ "Weekly."))
(cons 'renderer-fn (lambda (s) (gnc:date-get-week-year-string (gnc-localtime (split->time64 s)))))))
(cons 'monthly (list
(cons 'split-sortvalue (lambda (s) (time64-month (split->time64 s))))
(cons 'date-sortvalue time64-month)
(cons 'text (_ "Monthly"))
(cons 'tip (_ "Monthly."))
(cons 'renderer-fn (lambda (s) (gnc:date-get-month-year-string (gnc-localtime (split->time64 s)))))))
(cons 'quarterly (list
(cons 'split-sortvalue (lambda (s) (time64-quarter (split->time64 s))))
(cons 'date-sortvalue time64-quarter)
(cons 'text (_ "Quarterly"))
(cons 'tip (_ "Quarterly."))
(cons 'renderer-fn (lambda (s) (gnc:date-get-quarter-year-string (gnc-localtime (split->time64 s)))))))
(cons 'yearly (list
(cons 'split-sortvalue (lambda (s) (time64-year (split->time64 s))))
(cons 'date-sortvalue time64-year)
(cons 'text (_ "Yearly"))
(cons 'tip (_ "Yearly."))
(cons 'renderer-fn (lambda (s) (gnc:date-get-year-string (gnc-localtime (split->time64 s)))))))))
@ -320,6 +324,23 @@ in the Options panel."))
(cons 'text (_ "Both"))
(cons 'tip (_ "Show both (and include void transactions in totals)."))))))
(define show-closing-list
(list
(cons 'exclude-closing (list
(cons 'text (_ "Exclude closing transactions"))
(cons 'tip (_ "Exclude closing transactions from report."))
(cons 'closing-match #f)))
(cons 'include-both (list
(cons 'text (_ "Show both closing and regular transactions"))
(cons 'tip (_ "Show both (and include closing transactions in totals)."))
(cons 'closing-match 'both)))
(cons 'closing-only (list
(cons 'text (_ "Show closing transactions only"))
(cons 'tip (_ "Show only closing transactions."))
(cons 'closing-match #t)))))
(define reconcile-status-list
;; 'filter-types must be either #f (i.e. disable reconcile filter)
;; or a value defined as defined in Query.c
@ -386,7 +407,6 @@ Credit Card, and Income accounts."))
ACCT-TYPE-EQUITY ACCT-TYPE-CREDIT
ACCT-TYPE-INCOME))))))
(define (keylist-get-info keylist key info)
(cdr (assq info (cdr (assq key keylist)))))
@ -399,6 +419,20 @@ Credit Card, and Income accounts."))
(keylist-get-info keylist (car item) 'tip)))
keylist))
(define (SUBTOTAL-ENABLED? sortkey)
;; this returns whether sortkey *can* be subtotalled/grouped.
;; it checks whether a renderer-fn is defined.
(keylist-get-info sortkey-list sortkey 'renderer-fn))
(define (CUSTOM-SORTING? sortkey)
;; sortkey -> bool
;;
;; this returns which sortkeys which *must* use the custom sorter.
;; it filters whereby a split-sortvalue is defined (i.e. the splits
;; can be compared according to their 'sortvalue) but the QofQuery
;; sortkey is not defined (i.e. their 'sortkey is #f).
(and (keylist-get-info sortkey-list sortkey 'split-sortvalue)
(not (keylist-get-info sortkey-list sortkey 'sortkey))))
;;
;; Set defaults for reconcilation report
@ -537,6 +571,16 @@ tags within description, notes or memo. ")
'non-void-only
(keylist->vectorlist show-void-list)))
(gnc:register-trep-option
(gnc:make-multichoice-option
pagename-filter optname-closing-transactions
"l" (_ "By default most users should not include closing \
transactions in a transaction report. Closing transactions are \
transfers from INCOME and EXPENSE accounts to equity, and must usually \
be excluded from periodic reporting.")
'exclude-closing
(keylist->vectorlist show-closing-list)))
;; Accounts options
;; account to do report on
@ -585,10 +629,10 @@ tags within description, notes or memo. ")
(define (apply-selectable-by-name-sorting-options)
(let* ((prime-sortkey-enabled (not (eq? prime-sortkey 'none)))
(prime-sortkey-subtotal-enabled (member prime-sortkey SUBTOTAL-ENABLED))
(prime-sortkey-subtotal-enabled (SUBTOTAL-ENABLED? prime-sortkey))
(prime-date-sortingtype-enabled (member prime-sortkey DATE-SORTING-TYPES))
(sec-sortkey-enabled (not (eq? sec-sortkey 'none)))
(sec-sortkey-subtotal-enabled (member sec-sortkey SUBTOTAL-ENABLED))
(sec-sortkey-subtotal-enabled (SUBTOTAL-ENABLED? sec-sortkey))
(sec-date-sortingtype-enabled (member sec-sortkey DATE-SORTING-TYPES)))
(gnc-option-db-set-option-selectable-by-name
@ -962,17 +1006,17 @@ tags within description, notes or memo. ")
(let ((sortkey (opt-val pagename-sorting optname-prime-sortkey)))
(if (member sortkey DATE-SORTING-TYPES)
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-prime-date-subtotal) info)
(and (member sortkey SUBTOTAL-ENABLED)
(and (opt-val pagename-sorting optname-prime-subtotal)
(keylist-get-info sortkey-list sortkey info))))))
(and (SUBTOTAL-ENABLED? sortkey)
(opt-val pagename-sorting optname-prime-subtotal)
(keylist-get-info sortkey-list sortkey info)))))
(define (secondary-get-info info)
(let ((sortkey (opt-val pagename-sorting optname-sec-sortkey)))
(if (member sortkey DATE-SORTING-TYPES)
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-sec-date-subtotal) info)
(and (member sortkey SUBTOTAL-ENABLED)
(and (opt-val pagename-sorting optname-sec-subtotal)
(keylist-get-info sortkey-list sortkey info))))))
(and (SUBTOTAL-ENABLED? sortkey)
(opt-val pagename-sorting optname-sec-subtotal)
(keylist-get-info sortkey-list sortkey info)))))
(let* ((work-to-do (length splits))
(work-done 0)
@ -1093,10 +1137,11 @@ tags within description, notes or memo. ")
"number-cell"
(gnc:make-gnc-monetary currency price-decimal)))))))))
(if (and (null? left-cols-list)
(or (opt-val gnc:pagename-display "Totals")
(primary-get-info 'renderer-fn)
(secondary-get-info 'renderer-fn)))
(if (or (column-uses? 'subtotals-only)
(and (null? left-cols-list)
(or (opt-val gnc:pagename-display "Totals")
(primary-get-info 'renderer-fn)
(secondary-get-info 'renderer-fn))))
(list (vector "" (lambda (s t) #f)))
left-cols-list)))
@ -1108,48 +1153,42 @@ tags within description, notes or memo. ")
(define default-calculated-cells
(letrec
((damount (lambda (s) (if (gnc:split-voided? s)
(xaccSplitVoidFormerAmount s)
(xaccSplitGetAmount s))))
(trans-date (lambda (s) (xaccTransGetDate (xaccSplitGetParent s))))
(currency (lambda (s) (xaccAccountGetCommodity (xaccSplitGetAccount s))))
(report-currency (lambda (s) (if (column-uses? 'common-currency)
(opt-val gnc:pagename-general optname-currency)
(currency s))))
((split-amount (lambda (s) (if (gnc:split-voided? s)
(xaccSplitVoidFormerAmount s)
(xaccSplitGetAmount s))))
(split-currency (lambda (s) (xaccAccountGetCommodity (xaccSplitGetAccount s))))
(row-currency (lambda (s) (if (column-uses? 'common-currency)
(opt-val gnc:pagename-general optname-currency)
(split-currency s))))
(friendly-debit (lambda (a) (gnc:get-debit-string (xaccAccountGetType a))))
(friendly-credit (lambda (a) (gnc:get-credit-string (xaccAccountGetType a))))
(header-commodity (lambda (str)
(string-append
str
(if (column-uses? 'common-currency)
(string-append
"<br />"
(gnc-commodity-get-mnemonic
(opt-val gnc:pagename-general optname-currency)))
(format #f " (~a)"
(gnc-commodity-get-mnemonic
(opt-val gnc:pagename-general optname-currency)))
""))))
(convert (lambda (s num)
(gnc:exchange-by-pricedb-nearest
(gnc:make-gnc-monetary (currency s) num)
(report-currency s)
;; Use midday as the transaction time so it matches a price
;; on the same day. Otherwise it uses midnight which will
;; likely match a price on the previous day
(time64CanonicalDayTime (trans-date s)))))
(split-value (lambda (s) (convert s (damount s)))) ; used for correct debit/credit
(amount (lambda (s) (split-value s)))
(debit-amount (lambda (s) (and (positive? (gnc:gnc-monetary-amount (split-value s)))
(split-value s))))
(credit-amount (lambda (s) (if (positive? (gnc:gnc-monetary-amount (split-value s)))
#f
(gnc:monetary-neg (split-value s)))))
(original-amount (lambda (s) (gnc:make-gnc-monetary (currency s) (damount s))))
(original-debit-amount (lambda (s) (if (positive? (damount s))
(original-amount s)
#f)))
(original-credit-amount (lambda (s) (if (positive? (damount s))
#f
(gnc:monetary-neg (original-amount s)))))
(running-balance (lambda (s) (gnc:make-gnc-monetary (currency s) (xaccSplitGetBalance s)))))
;; For conversion to row-currency. Use midday as the
;; transaction time so it matches a price on the same day.
;; Otherwise it uses midnight which will likely match a
;; price on the previous day
(converted-amount (lambda (s) (gnc:exchange-by-pricedb-nearest
(gnc:make-gnc-monetary (split-currency s) (split-amount s))
(row-currency s)
(time64CanonicalDayTime
(xaccTransGetDate (xaccSplitGetParent s))))))
(converted-debit-amount (lambda (s) (and (positive? (split-amount s))
(converted-amount s))))
(converted-credit-amount (lambda (s) (and (not (positive? (split-amount s)))
(gnc:monetary-neg (converted-amount s)))))
(original-amount (lambda (s) (gnc:make-gnc-monetary (split-currency s) (split-amount s))))
(original-debit-amount (lambda (s) (and (positive? (split-amount s))
(original-amount s))))
(original-credit-amount (lambda (s) (and (not (positive? (split-amount s)))
(gnc:monetary-neg (original-amount s)))))
(running-balance (lambda (s) (gnc:make-gnc-monetary (split-currency s) (xaccSplitGetBalance s)))))
(append
;; each column will be a vector
;; (vector heading
@ -1159,17 +1198,19 @@ tags within description, notes or memo. ")
;; start-dual-column? ;; #t for the debit side of a dual column (i.e. debit/credit)
;; ;; which means the next column must be the credit side
;; friendly-heading-fn ;; (friendly-heading-fn account) to retrieve friendly name for account debit/credit
(if (column-uses? 'amount-single)
(list (vector (header-commodity (_ "Amount"))
amount #t #t #f
converted-amount #t #t #f
(lambda (a) "")))
'())
(if (column-uses? 'amount-double)
(list (vector (header-commodity (_ "Debit"))
debit-amount #f #t #t
converted-debit-amount #f #t #t
friendly-debit)
(vector (header-commodity (_ "Credit"))
credit-amount #f #t #f
converted-credit-amount #f #t #f
friendly-credit))
'())
@ -1256,11 +1297,10 @@ tags within description, notes or memo. ")
1 (+ right-indent width-left-columns) data)))
(for-each (lambda (cell)
(addto! row-contents
(gnc:make-html-table-cell
"<b>"
((vector-ref cell 5)
((keylist-get-info sortkey-list sortkey 'renderer-fn) split))
"</b>")))
(gnc:make-html-text
(gnc:html-markup-b
((vector-ref cell 5)
((keylist-get-info sortkey-list sortkey 'renderer-fn) split))))))
calculated-cells))
(addto! row-contents (gnc:make-html-table-cell/size
1 (+ right-indent width-left-columns width-right-columns) data)))
@ -1418,7 +1458,7 @@ tags within description, notes or memo. ")
(render-date date-subtotal-key split))
((member sortkey ACCOUNT-SORTING-TYPES)
(render-account sortkey split anchor?))
((eq? sortkey 'reconciled-status)
(else
(render-generic sortkey split)))))
(define (render-grand-total)
@ -1768,51 +1808,38 @@ tags within description, notes or memo. ")
(secondary-order (opt-val pagename-sorting optname-sec-sortorder))
(secondary-date-subtotal (opt-val pagename-sorting optname-sec-date-subtotal))
(void-status (opt-val pagename-filter optname-void-transactions))
(closing-match (keylist-get-info show-closing-list
(opt-val pagename-filter optname-closing-transactions)
'closing-match))
(splits '())
(custom-sort? (or (and (member primary-key DATE-SORTING-TYPES) ; this will remain
(not (eq? primary-date-subtotal 'none))) ; until qof-query
(and (member secondary-key DATE-SORTING-TYPES) ; is upgraded
(not (eq? secondary-date-subtotal 'none)))
(or (member primary-key CUSTOM-SORTING)
(member secondary-key CUSTOM-SORTING))))
(or (CUSTOM-SORTING? primary-key)
(CUSTOM-SORTING? secondary-key))))
(infobox-display (opt-val gnc:pagename-general optname-infobox-display))
(query (qof-query-create-for-splits)))
(define (generic-less? X Y key date-subtotal ascend?)
(define comparator-function
(if (member key DATE-SORTING-TYPES)
(let ((date (lambda (s)
(case key
((date) (xaccTransGetDate (xaccSplitGetParent s)))
((reconciled-date) (xaccSplitGetDateReconciled s))))))
(case date-subtotal
((yearly) (lambda (s) (time64-year (date s))))
((monthly) (lambda (s) (time64-month (date s))))
((quarterly) (lambda (s) (time64-quarter (date s))))
((weekly) (lambda (s) (time64-week (date s))))
((daily) (lambda (s) (time64-day (date s))))
((none) (lambda (s) (date s)))))
(case key
((account-name) (lambda (s) (gnc-account-get-full-name (xaccSplitGetAccount s))))
((account-code) (lambda (s) (xaccAccountGetCode (xaccSplitGetAccount s))))
((corresponding-acc-name) (lambda (s) (xaccSplitGetCorrAccountFullName s)))
((corresponding-acc-code) (lambda (s) (xaccSplitGetCorrAccountCode s)))
((reconciled-status) (lambda (s) (length (memq (xaccSplitGetReconcile s)
'(#\n #\c #\y #\f #\v)))))
((amount) (lambda (s) (gnc-numeric-to-scm (xaccSplitGetValue s))))
((description) (lambda (s) (xaccTransGetDescription (xaccSplitGetParent s))))
((number) (lambda (s)
(if BOOK-SPLIT-ACTION
(xaccSplitGetAction s)
(xaccTransGetNum (xaccSplitGetParent s)))))
((t-number) (lambda (s) (xaccTransGetNum (xaccSplitGetParent s))))
((register-order) (lambda (s) #f))
((memo) (lambda (s) (xaccSplitGetMemo s)))
((none) (lambda (s) #f)))))
(cond
((string? (comparator-function X)) ((if ascend? string<? string>?) (comparator-function X) (comparator-function Y)))
((comparator-function X) ((if ascend? < >) (comparator-function X) (comparator-function Y)))
(else #f)))
(define (generic-less? split-X split-Y sortkey date-subtotal-key ascend?)
;; compare splits X and Y, whereby
;; sortkey and date-subtotal-key specify the options used
;; ascend? specifies whether ascending or descending
(let* ((comparator-function
(if (memq sortkey DATE-SORTING-TYPES)
(let ((date (keylist-get-info sortkey-list sortkey 'split-sortvalue))
(date-comparator (keylist-get-info date-subtotal-list date-subtotal-key 'date-sortvalue)))
(lambda (s)
(and date-comparator
(date-comparator (date s)))))
(or (keylist-get-info sortkey-list sortkey 'split-sortvalue)
(lambda (s) #f))))
(value-of-X (comparator-function split-X))
(value-of-Y (comparator-function split-Y))
(op (if (string? value-of-X)
(if ascend? string<? string>?)
(if ascend? < >))))
(and value-of-X (op value-of-X value-of-Y))))
(define (primary-comparator? X Y)
(generic-less? X Y primary-key
@ -1828,7 +1855,6 @@ tags within description, notes or memo. ")
(define (date-comparator? X Y)
(generic-less? X Y 'date 'none #t))
(if (or (or (null? c_account_1) (and-map not c_account_1))
(eq? account-matcher-regexp 'invalid-regex)
(eq? transaction-matcher-regexp 'invalid-regex))
@ -1851,7 +1877,7 @@ tags within description, notes or memo. ")
(if (memq infobox-display '(always no-match))
(gnc:html-document-add-object!
document
(gnc:render-options-changed options))))
(gnc:html-render-options-changed options))))
(begin
@ -1864,6 +1890,8 @@ tags within description, notes or memo. ")
(else #f))
(if reconcile-status-filter
(xaccQueryAddClearedMatch query reconcile-status-filter QOF-QUERY-AND))
(if (boolean? closing-match)
(xaccQueryAddClosingTransMatch query closing-match QOF-QUERY-AND))
(if (not custom-sort?)
(begin
(qof-query-set-sort-order query
@ -1925,7 +1953,7 @@ tags within description, notes or memo. ")
(if (memq infobox-display '(always no-match))
(gnc:html-document-add-object!
document
(gnc:render-options-changed options))))
(gnc:html-render-options-changed options))))
(let-values (((table grid) (make-split-table splits options custom-calculated-cells)))
@ -1954,7 +1982,7 @@ tags within description, notes or memo. ")
(if (eq? infobox-display 'always)
(gnc:html-document-add-object!
document
(gnc:render-options-changed options)))
(gnc:html-render-options-changed options)))
(gnc:html-document-add-object! document table)))))

1
libgnucash/app-utils/app-utils.scm
View File

@ -101,7 +101,6 @@
(export gnc:make-radiobutton-option)
(export gnc:make-radiobutton-callback-option)
(export gnc:make-list-option)
(export gnc:render-options-changed)
(export gnc:options-make-end-date!)
(export gnc:options-make-date-interval!)
(export gnc:option-make-internal!)

58
libgnucash/app-utils/options.scm
View File

@ -2001,64 +2001,6 @@
(gnc:option-value src-option)))))
src-options)))
(define* (gnc:render-options-changed options #:optional plaintext?)
;;
;; options -> string
;;
;; this function will generate an string of options that were changed by the user.
;; by default, it produces an html string.
;; the optional plaintext? = #t will ensure the output is suitable for console output
;; omitting all html elements, and is expected to be used for unit tests only.
;;
(let ((row-contents '()))
(define (disp d)
;; this function will intelligently display the option value. the option-value is subject to various tests
;; the or clause below will test for boolean, null, list, and pairs. each will trigger a custom function
;; returning a string. the pair option is handled differently because its car will define the data type
;; for its cdr which is either a symbol, time64 number, percent or pixels. if the option does not satisfy
;; any of the above, the function attempts to pass it as a parameter to gnc-commodity-get-mnemonic, or
;; xaccAccountGetName, or gnc-budget-get-name; success leads to application of these functions, failure
;; then leads to a generic stringify function which will handle symbol/string/other types.
(define (try thunk arg)
;; this helper function will attempt to run thunk with arg as a parameter. we will catch any
;; 'wrong-type-arg exception, and return the #f value to the or evaluator below.
(catch 'wrong-type-arg
(lambda () (thunk arg))
(lambda (k . args) #f)))
(or (and (boolean? d) (if d (_ "Enabled") (_ "Disabled")))
(and (null? d) "null")
(and (list? d) (string-join (map disp d) ", "))
(and (pair? d) (string-append
(disp (car d)) " . "
(case (car d)
((relative) (symbol->string (cdr d)))
((absolute) (qof-print-date (cdr d)))
((pixels percent) (number->string (cdr d)))
(else (format #f "unknown car of pair, cannot determine format for ~A" (cdr d))))))
(try gnc-commodity-get-mnemonic d)
(try xaccAccountGetName d)
(try gnc-budget-get-name d)
(format #f "~A" d)))
(define (disp-option-if-changed option)
;; this function is called by gnc:options-for-each on each option, and will test whether default value
;; has been changed and the option is not hidden, and display it using (disp val) as above.
(let* ((section (gnc:option-section option))
(name (gnc:option-name option))
(default-value (gnc:option-default-value option))
(value (gnc:option-value option))
(return-string (string-append (if plaintext? "" "<b>")
section " / " name
(if plaintext? "" "</b>")
": "
(disp value))))
(if (not (or (equal? default-value value)
(char=? (string-ref section 0) #\_)))
(set! row-contents (cons return-string row-contents)))))
(gnc:options-for-each disp-option-if-changed options)
(string-append (string-join (reverse row-contents)
(if plaintext? "\n" "<br />\n"))
(if plaintext? "\n\n" "<br />\n<br />\n"))))
(define (gnc:send-options db_handle options)
(gnc:options-for-each
(lambda (option)

8
libgnucash/app-utils/test/CMakeLists.txt
View File

@ -43,6 +43,9 @@ set(GUILE_DEPENDS
set(test_app_utils_scheme_SOURCES
test-c-interface.scm
test-load-app-utils-module.scm
)
set (test_app_utils_scheme_SRFI64_SOURCES
test-date-utilities.scm
)
@ -61,6 +64,11 @@ gnc_add_scheme_targets(scm-test-c-interface
)
gnc_add_scheme_tests("${test_app_utils_scheme_SOURCES}")
if (HAVE_SRFI64)
gnc_add_scheme_tests("${test_app_utils_scheme_SRFI64_SOURCES}")
endif ()
# Doesn't work yet:
gnc_add_test_with_guile(test-app-utils "${test_app_utils_SOURCES}" APP_UTILS_TEST_INCLUDE_DIRS APP_UTILS_TEST_LIBS)

70
libgnucash/app-utils/test/test-date-utilities.scm
View File

@ -1,10 +1,15 @@
(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 (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(define (run-test)
(and (test test-weeknum-calculator)
(test test-date-get-quarter-string)))
(test-runner-factory gnc:test-runner)
(test-begin "test-date-utilities.scm")
(test-weeknum-calculator)
(test-date-get-quarter-string)
(test-end "test-date-utilities.scm"))
(define (create-datevec l)
(let ((now (gnc-localtime (current-time))))
@ -12,8 +17,8 @@
(set-tm:min now (list-ref l 4))
(set-tm:hour now (list-ref l 3))
(set-tm:mday now (list-ref l 2))
(set-tm:mon now (list-ref l 1))
(set-tm:year now (list-ref l 0))
(set-tm:mon now (1- (list-ref l 1)))
(set-tm:year now (- (list-ref l 0) 1900))
(set-tm:isdst now -1)
now))
@ -28,28 +33,39 @@
(gnc:date-to-week (create-time64 d2)))))
(define (test-weeknum-calculator)
(and (weeknums-equal? (cons '(1970 1 1 0 0 0)
'(1970 1 1 23 59 59)))
(weeknums-equal? (cons '(1969 12 31 0 0 0)
'(1969 12 31 23 59 59)))
(weeknums-equal? (cons '(1969 12 31 0 0 0)
'(1970 1 1 0 0 1)))
(weeknums-equal? (cons '(2001 1 1 0 0 0)
'(2001 1 1 23 59 59)))
(not (weeknums-equal? (cons '(1970 1 1 0 0 0)
'(1970 1 10 0 0 1))))
(not (weeknums-equal? (cons '(1969 12 28 0 0 1)
'(1970 1 5 0 0 1))))
))
(test-assert "weeknums 1/1/70early = 1/1/70late"
(weeknums-equal? (cons '(1970 1 1 0 0 0)
'(1970 1 1 23 59 59))))
(test-assert "weeknums 31/12/69early = 31/12/69late"
(weeknums-equal? (cons '(1969 12 31 0 0 0)
'(1969 12 31 23 59 59))))
(test-assert "weeknums 31/12/69 = 1/1/70"
(weeknums-equal? (cons '(1969 12 31 0 0 0)
'(1970 1 1 0 0 1))))
(test-assert "weeknums 1/1/01early = 01/01/01 late"
(weeknums-equal? (cons '(2001 1 1 0 0 0)
'(2001 1 1 23 59 59))))
(test-assert "weeknums 1/1/70 != 10/1/70"
(not (weeknums-equal? (cons '(1970 1 1 0 0 0)
'(1970 1 10 0 0 1)))))
(test-assert "weeknum 28/12/69 != 5/1/70"
(not (weeknums-equal? (cons '(1969 12 28 0 0 1)
'(1970 1 5 0 0 1))))))
(define (test-date-get-quarter-string)
(and (or (string=? "Q1" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))
(begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (creaete-datevec '(2001 2 14 11 42 23))))
#f))
(or (string=? "Q2" (gnc:date-get-quarter-string (create-datevec '(2013 4 23 18 11 49))))
(begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))
#f))
(or (string=? "Q3" (gnc:date-get-quarter-string (create-datevec '(1997 9 11 08 14 21))))
(begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23)))))
#f)))
(test-equal "14/02/2001 = Q1"
"Q1"
(gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))
(test-equal "23/04/2013 = Q2"
"Q2"
(gnc:date-get-quarter-string (create-datevec '(2013 4 23 18 11 49))))
(test-equal "11/09/1997 = Q3"
"Q3"
(gnc:date-get-quarter-string (create-datevec '(1997 9 11 08 14 21)))))

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

@ -233,6 +233,20 @@ gnc_add_scheme_targets(scm-test-engine-extras
FALSE
)
if (HAVE_SRFI64)
gnc_add_scheme_targets (scm-srfi64-extras
"srfi64-extras.scm"
"gnucash/engine/test/"
"${GUILE_DEPENDS}"
FALSE
)
set(srfi64_extras_SCHEME_DIST
srfi64-extras.scm
)
endif (HAVE_SRFI64)
gnc_add_scheme_targets(scm-test-engine
"${engine_test_SCHEME}"
""
@ -311,4 +325,5 @@ set(test_engine_EXTRA_DIST
)
set_dist_list(test_engine_DIST CMakeLists.txt
${srfi64_extras_SCHEME_DIST}
${test_engine_SOURCES_DIST} ${test_engine_SCHEME_DIST} ${test_engine_EXTRA_DIST})

49
libgnucash/engine/test/srfi64-extras.scm Normal file
View File

@ -0,0 +1,49 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash engine test srfi64-extras))
(use-modules (srfi srfi-64))
(export gnc:test-runner)
(define (gnc:test-runner)
(let ((runner (test-runner-null))
(num-passed 0)
(num-failed 0))
(test-runner-on-test-end! runner
(lambda (runner)
(format #t "[~a] line:~a, test: ~a\n"
(test-result-ref runner 'result-kind)
(test-result-ref runner 'source-line)
(test-runner-test-name runner))
(case (test-result-kind runner)
((pass xpass) (set! num-passed (1+ num-passed)))
((fail xfail)
(if (test-result-ref runner 'expected-value)
(format #t "~a\n -> expected: ~s\n -> obtained: ~s\n"
(string-join (test-runner-group-path runner) "/")
(test-result-ref runner 'expected-value)
(test-result-ref runner 'actual-value)))
(set! num-failed (1+ num-failed)))
(else #t))))
(test-runner-on-final! runner
(lambda (runner)
(format #t "Source:~a\npass = ~a, fail = ~a\n"
(test-result-ref runner 'source-file) num-passed num-failed)
(zero? num-failed)))
runner))

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

@ -27,15 +27,7 @@
(use-modules (sw_app_utils))
(use-modules (sw_engine))
(export logging-and)
(export test)
(export make-test-sink)
(export env-test-sink)
(export test-sink-report)
(export test-sink-check)
(export delayed-format)
(export delayed-format-render)
(export with-account)
(export with-transaction)
@ -62,15 +54,6 @@
;; Random test related syntax and the like
;;
;; logging-and is mostly for debugging tests
(define-macro (logging-and . args)
(cons 'and (map (lambda (arg)
(list 'begin
(list 'format #t "Test: ~a\n" (list 'quote arg))
arg))
args)))
;; ..and 'test' gives nicer output
(define (test the-test)
(format #t "(Running ~a " the-test)
(let ((result (the-test)))
@ -112,8 +95,7 @@
(define (create-test-env)
(list (cons 'random (seed->random-state (random 1000)))
(cons 'counter (make-counter))
(cons 'sink (make-test-sink))))
(cons 'counter (make-counter))))
(define (env-random-amount env n)
(/ (env-random env n) 1))
@ -130,9 +112,6 @@
(define (env-select-price-source env)
'pricedb-nearest)
(define (env-test-sink env)
(assoc-ref env 'sink))
(define (env-any-date env) (gnc:get-today))
(define (env-create-transaction env date credit debit aaa)
@ -324,69 +303,5 @@
(list "Other")
(list "Expenses"
(list (cons 'type ACCT-TYPE-EXPENSE))))))
;;
;; Test sinks
;;
(define (make-test-sink) (list 'sink 0 '()))
(define (test-sink-count sink)
(second sink))
(define (test-sink-count! sink value)
(set-car! (cdr sink) value))
(define (test-sink-messages sink)
(third sink))
(define (test-sink-messages! sink messages)
(set-car! (cdr (cdr sink)) messages))
(define (test-sink-check sink message flag)
(test-sink-count! sink (+ (test-sink-count sink) 1))
(if flag #t
(test-sink-messages! sink (cons message (test-sink-messages sink)))))
(define (test-sink-report sink)
(format #t "Completed ~a tests ~a\n"
(test-sink-count sink)
(if (null? (test-sink-messages sink)) "PASS" "FAIL"))
(if (null? (test-sink-messages sink)) #t
(begin (for-each (lambda (delayed-message)
(delayed-format-render #t delayed-message))
(test-sink-messages sink))
#f)))
(define (delayed-format . x) x)
(define (delayed-format-render stream msg)
(apply format stream msg))
;;
;; options
;;
(define (create-option-set)
(make-hash-table) )
(define (option-set-setter option-set)
(lambda (category name value)
(hash-set! option-set (list category name) value)))
(define (option-set-getter option-set)
(lambda (category name)
(hash-ref option-set (list category name))))
;;
;;
;;
(define (report-show-options stream expense-options)
(gnc:options-for-each (lambda (option)
(format stream "Option: ~a.~a Value ~a\n"
(gnc:option-section option)
(gnc:option-name option)
(gnc:option-value option)))
expense-options))

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

@ -26,10 +26,7 @@
(use-modules (sw_engine))
(define (run-test)
(and (logging-and #t)
(logging-and)
(not (logging-and #t #f))
(test-create-account-structure)))
(test-create-account-structure))
(define (test-create-account-structure)
(let ((env (create-test-env)))

5
libgnucash/scm/utilities.scm
View File

@ -42,6 +42,7 @@
(export gnc:error)
(export gnc:msg)
(export gnc:debug)
(export addto!)
;; Do this stuff very early -- but other than that, don't add any
;; executable code until the end of the file if you can help it.
@ -71,6 +72,10 @@
(define (gnc:debug . items)
(gnc-scm-log-debug (strify items)))
(define-syntax addto!
(syntax-rules ()
((addto! alist element)
(set! alist (cons element alist)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:substring-replace