mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Merge branch 'scheme-progress' of https://github.com/christopherlam/gnucash into maint
This commit is contained in:
Geert Janssens
commit
7f91cb82d7
@ -1,3 +1,4 @@
|
|||||||
|
add_subdirectory (test)
|
||||||
|
|
||||||
set (business_reports_SCHEME
|
set (business_reports_SCHEME
|
||||||
aging.scm
|
aging.scm
|
||||||
|
|||||||
@ -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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (num-col columns-used)
|
(define (num-col columns-used)
|
||||||
@ -590,11 +580,11 @@
|
|||||||
(gnc:html-table-append-row!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list
|
(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!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list "<br>"))
|
(list "<br/>"))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -612,7 +602,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -635,7 +625,7 @@
|
|||||||
(gnc:html-table-append-row! table (list (if name name "")))
|
(gnc:html-table-append-row! table (list (if name name "")))
|
||||||
(gnc:html-table-append-row! table (list (string-expand
|
(gnc:html-table-append-row! table (list (string-expand
|
||||||
(if addy addy "")
|
(if addy addy "")
|
||||||
#\newline "<br>")))
|
#\newline "<br/>")))
|
||||||
(gnc:html-table-append-row! table (list
|
(gnc:html-table-append-row! table (list
|
||||||
(strftime
|
(strftime
|
||||||
date-format
|
date-format
|
||||||
|
|||||||
@ -33,21 +33,12 @@
|
|||||||
(use-modules (srfi srfi-1))
|
(use-modules (srfi srfi-1))
|
||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
(use-modules (gnucash gettext))
|
(use-modules (gnucash gettext))
|
||||||
|
(use-modules (gnucash utilities))
|
||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
(use-modules (gnucash report standard-reports))
|
(use-modules (gnucash report standard-reports))
|
||||||
(use-modules (gnucash report business-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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (description-col columns-used)
|
(define (description-col columns-used)
|
||||||
@ -573,10 +564,10 @@
|
|||||||
(gnc:html-table-append-row!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list
|
(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!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list "<br>"))
|
(list "<br/>"))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (order)
|
(lambda (order)
|
||||||
(let* ((reference (gncOrderGetReference order)))
|
(let* ((reference (gncOrderGetReference order)))
|
||||||
@ -587,7 +578,7 @@
|
|||||||
;; This string is supposed to be an abbrev. for "Reference"?
|
;; This string is supposed to be an abbrev. for "Reference"?
|
||||||
(string-append (_ "REF") ": " reference))))))
|
(string-append (_ "REF") ": " reference))))))
|
||||||
orders)
|
orders)
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -607,7 +598,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -789,7 +780,7 @@
|
|||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Billing ID") ": "
|
(_ "Billing ID") ": "
|
||||||
(string-expand billing-id #\newline "<br>"))))
|
(string-expand billing-id #\newline "<br/>"))))
|
||||||
(make-break! document)))))
|
(make-break! document)))))
|
||||||
|
|
||||||
(if (opt-val "Display" "Billing Terms")
|
(if (opt-val "Display" "Billing Terms")
|
||||||
@ -801,7 +792,7 @@
|
|||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Terms") ": "
|
(_ "Terms") ": "
|
||||||
(string-expand terms #\newline "<br>")))))))
|
(string-expand terms #\newline "<br/>")))))))
|
||||||
|
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
|
|
||||||
@ -823,14 +814,14 @@
|
|||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-expand notes #\newline "<br>"))))
|
(string-expand notes #\newline "<br/>"))))
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
(make-break! document)))
|
(make-break! document)))
|
||||||
|
|
||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(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
|
; close the framing table
|
||||||
|
|||||||
@ -51,21 +51,12 @@
|
|||||||
(use-modules (srfi srfi-1))
|
(use-modules (srfi srfi-1))
|
||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
(use-modules (gnucash gettext))
|
(use-modules (gnucash gettext))
|
||||||
|
(use-modules (gnucash utilities))
|
||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
(use-modules (gnucash report standard-reports))
|
(use-modules (gnucash report standard-reports))
|
||||||
(use-modules (gnucash report business-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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (description-col columns-used)
|
(define (description-col columns-used)
|
||||||
@ -631,7 +622,7 @@
|
|||||||
(gnc:html-table-cell-set-style!
|
(gnc:html-table-cell-set-style!
|
||||||
name-cell "td"
|
name-cell "td"
|
||||||
'font-size "+2")
|
'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!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list
|
(list
|
||||||
@ -648,7 +639,7 @@
|
|||||||
(list
|
(list
|
||||||
(string-append (_ "REF") ": " reference))))))
|
(string-append (_ "REF") ": " reference))))))
|
||||||
orders)
|
orders)
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -673,7 +664,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -936,7 +927,7 @@
|
|||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-expand notes #\newline "<br>")))))
|
(string-expand notes #\newline "<br/>")))))
|
||||||
|
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
|
|
||||||
|
|||||||
@ -27,21 +27,12 @@
|
|||||||
(use-modules (srfi srfi-1))
|
(use-modules (srfi srfi-1))
|
||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
(use-modules (gnucash gettext))
|
(use-modules (gnucash gettext))
|
||||||
|
(use-modules (gnucash utilities))
|
||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(gnc:module-load "gnucash/report/report-system" 0)
|
||||||
(use-modules (gnucash report standard-reports))
|
(use-modules (gnucash report standard-reports))
|
||||||
(use-modules (gnucash report business-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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (description-col columns-used)
|
(define (description-col columns-used)
|
||||||
@ -550,10 +541,10 @@
|
|||||||
(gnc:html-table-append-row!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list
|
(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!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list "<br>"))
|
(list "<br/>"))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (order)
|
(lambda (order)
|
||||||
(let* ((reference (gncOrderGetReference order)))
|
(let* ((reference (gncOrderGetReference order)))
|
||||||
@ -563,7 +554,7 @@
|
|||||||
(list
|
(list
|
||||||
(string-append (_ "REF") ": " reference))))))
|
(string-append (_ "REF") ": " reference))))))
|
||||||
orders)
|
orders)
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -584,7 +575,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -604,7 +595,7 @@
|
|||||||
(gnc:html-table-append-row! table (list (if name name "")))
|
(gnc:html-table-append-row! table (list (if name name "")))
|
||||||
(gnc:html-table-append-row! table (list (string-expand
|
(gnc:html-table-append-row! table (list (string-expand
|
||||||
(if addy addy "")
|
(if addy addy "")
|
||||||
#\newline "<br>")))
|
#\newline "<br/>")))
|
||||||
(gnc:html-table-append-row! table (list
|
(gnc:html-table-append-row! table (list
|
||||||
(strftime
|
(strftime
|
||||||
date-format
|
date-format
|
||||||
@ -727,7 +718,7 @@
|
|||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Reference") ": "
|
(_ "Reference") ": "
|
||||||
(string-expand billing-id #\newline "<br>"))))
|
(string-expand billing-id #\newline "<br/>"))))
|
||||||
(make-break! document)))))
|
(make-break! document)))))
|
||||||
|
|
||||||
(if (opt-val "Display" "Billing Terms")
|
(if (opt-val "Display" "Billing Terms")
|
||||||
@ -740,7 +731,7 @@
|
|||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Terms") ": "
|
(_ "Terms") ": "
|
||||||
(string-expand terms #\newline "<br>"))))
|
(string-expand terms #\newline "<br/>"))))
|
||||||
(make-break! document))
|
(make-break! document))
|
||||||
)))
|
)))
|
||||||
|
|
||||||
@ -755,14 +746,14 @@
|
|||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Job number") ": "
|
(_ "Job number") ": "
|
||||||
(string-expand jobnumber #\newline "<br>"))))
|
(string-expand jobnumber #\newline "<br/>"))))
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-append
|
(string-append
|
||||||
(_ "Job name") ": "
|
(_ "Job name") ": "
|
||||||
(string-expand jobname #\newline "<br>"))))
|
(string-expand jobname #\newline "<br/>"))))
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
)))
|
)))
|
||||||
@ -777,7 +768,7 @@
|
|||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(string-expand notes #\newline "<br>")))))
|
(string-expand notes #\newline "<br/>")))))
|
||||||
|
|
||||||
(make-break! document)
|
(make-break! document)
|
||||||
|
|
||||||
@ -785,7 +776,7 @@
|
|||||||
document
|
document
|
||||||
(gnc:make-html-text
|
(gnc:make-html-text
|
||||||
(gnc:html-markup-br)
|
(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))))
|
(gnc:html-markup-br))))
|
||||||
|
|
||||||
; else
|
; else
|
||||||
|
|||||||
@ -46,16 +46,6 @@
|
|||||||
(define desc-header (N_ "Description"))
|
(define desc-header (N_ "Description"))
|
||||||
(define amount-header (N_ "Amount"))
|
(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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (date-due-col columns-used)
|
(define (date-due-col columns-used)
|
||||||
@ -482,7 +472,7 @@
|
|||||||
(gnc:html-table-append-row!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list "<br/>"))
|
(list "<br/>"))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -500,7 +490,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
|
|||||||
@ -117,16 +117,6 @@
|
|||||||
(else
|
(else
|
||||||
(_ "Vendor"))))
|
(_ "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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (date-due-col columns-used)
|
(define (date-due-col columns-used)
|
||||||
@ -688,11 +678,11 @@
|
|||||||
(gnc:html-table-append-row!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list
|
(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!
|
(gnc:html-table-append-row!
|
||||||
table
|
table
|
||||||
(list "<br>"))
|
(list "<br/>"))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -710,7 +700,7 @@
|
|||||||
table "table"
|
table "table"
|
||||||
'attribute (list "border" 0)
|
'attribute (list "border" 0)
|
||||||
'attribute (list "cellpadding" 0))
|
'attribute (list "cellpadding" 0))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -731,7 +721,7 @@
|
|||||||
(gnc:html-table-append-row! table (list (if name name "")))
|
(gnc:html-table-append-row! table (list (if name name "")))
|
||||||
(gnc:html-table-append-row! table (list (string-expand
|
(gnc:html-table-append-row! table (list (string-expand
|
||||||
(if addy addy "")
|
(if addy addy "")
|
||||||
#\newline "<br>")))
|
#\newline "<br/>")))
|
||||||
(gnc:html-table-append-row! table (list
|
(gnc:html-table-append-row! table (list
|
||||||
(strftime
|
(strftime
|
||||||
date-format
|
date-format
|
||||||
|
|||||||
@ -191,7 +191,7 @@
|
|||||||
notespage optname-extra-notes "a"
|
notespage optname-extra-notes "a"
|
||||||
(N_ "Notes added at end of invoice -- may contain HTML markup")
|
(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
|
(gnc:options-set-default-section
|
||||||
report-options generalpage)
|
report-options generalpage)
|
||||||
|
|||||||
@ -237,7 +237,7 @@
|
|||||||
notespage optname-extra-notes "a"
|
notespage optname-extra-notes "a"
|
||||||
(_ "Notes added at end of invoice -- may contain HTML markup.")
|
(_ "Notes added at end of invoice -- may contain HTML markup.")
|
||||||
(_ "Thank you for your patronage!")))
|
(_ "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"
|
(add-option (gnc:make-text-option notespage optname-extra-css "b"
|
||||||
(N_ "Embedded CSS.") "h1.coyname { text-align: left; }"))
|
(N_ "Embedded CSS.") "h1.coyname { text-align: left; }"))
|
||||||
|
|||||||
31
gnucash/report/business-reports/test/CMakeLists.txt
Normal file
31
gnucash/report/business-reports/test/CMakeLists.txt
Normal 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}
|
||||||
|
)
|
||||||
@ -52,7 +52,6 @@ set (report_system_SCHEME
|
|||||||
|
|
||||||
set (report_system_SCHEME_2a
|
set (report_system_SCHEME_2a
|
||||||
collectors.scm
|
collectors.scm
|
||||||
list-extras.scm
|
|
||||||
)
|
)
|
||||||
|
|
||||||
set (report_system_SCHEME_2b
|
set (report_system_SCHEME_2b
|
||||||
|
|||||||
@ -333,15 +333,15 @@
|
|||||||
;; Binary search. Returns highest index with content less than or
|
;; Binary search. Returns highest index with content less than or
|
||||||
;; equal to the supplied value.
|
;; equal to the supplied value.
|
||||||
|
|
||||||
(define (binary-search-lt <= value vector)
|
(define (binary-search-lt <= val vec)
|
||||||
(define (search low high)
|
(and (not (zero? (vector-length vec)))
|
||||||
(let* ((midpoint (+ low (ceiling (/ (- high low) 2))))
|
(let loop ((low 0)
|
||||||
(midvalue (vector-ref vector midpoint)))
|
(high (1- (vector-length vec))))
|
||||||
(if (= low high)
|
(let* ((midpoint (ceiling (/ (+ low high) 2)))
|
||||||
(if (<= midvalue value)
|
(midvalue (vector-ref vec midpoint)))
|
||||||
low #f)
|
(if (= low high)
|
||||||
(if (<= midvalue value)
|
(and (<= midvalue val)
|
||||||
(search midpoint high)
|
low)
|
||||||
(search low (- midpoint 1))))))
|
(if (<= midvalue val)
|
||||||
(if (= 0 (vector-length vector)) #f
|
(loop midpoint high)
|
||||||
(search 0 (- (vector-length vector) 1))))
|
(loop low (1- midpoint))))))))
|
||||||
|
|||||||
@ -756,3 +756,10 @@
|
|||||||
(push (gnc:html-document-markup-end doc "table"))
|
(push (gnc:html-document-markup-end doc "table"))
|
||||||
(gnc:html-document-pop-style doc)
|
(gnc:html-document-pop-style doc)
|
||||||
retval))
|
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)))
|
||||||
|
|||||||
@ -190,7 +190,7 @@
|
|||||||
(define (gnc:html-markup-anchor href . rest)
|
(define (gnc:html-markup-anchor href . rest)
|
||||||
(apply gnc:html-markup/attr
|
(apply gnc:html-markup/attr
|
||||||
"a"
|
"a"
|
||||||
(string-append "href=\"" href "\"")
|
(format #f "href=~s" href)
|
||||||
rest))
|
rest))
|
||||||
|
|
||||||
(define (gnc:html-markup-img src . rest)
|
(define (gnc:html-markup-img src . rest)
|
||||||
@ -198,15 +198,11 @@
|
|||||||
"img"
|
"img"
|
||||||
(with-output-to-string
|
(with-output-to-string
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(display "src=\"") (display src) (display"\"")
|
|
||||||
(display " ")
|
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (kvp)
|
(lambda (kvp)
|
||||||
(display (car kvp))
|
(format #f "~a=~s " (car kvp) (cadr kvp)))
|
||||||
(display "=\"")
|
(cons (list 'src src)
|
||||||
(display (cadr kvp))
|
rest))))))
|
||||||
(display "\" "))
|
|
||||||
rest)))))
|
|
||||||
|
|
||||||
(define (gnc:html-text-render p doc)
|
(define (gnc:html-text-render p doc)
|
||||||
(let* ((retval '())
|
(let* ((retval '())
|
||||||
|
|||||||
@ -22,12 +22,12 @@
|
|||||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(use-modules (gnucash utilities))
|
||||||
|
|
||||||
;; returns a list with n #f (empty cell) values
|
;; returns a list with n #f (empty cell) values
|
||||||
(define (gnc:html-make-empty-cell) #f)
|
(define (gnc:html-make-empty-cell) #f)
|
||||||
(define (gnc:html-make-empty-cells n)
|
(define (gnc:html-make-empty-cells n)
|
||||||
(if (> n 0)
|
(make-list n #f))
|
||||||
(cons #f (gnc:html-make-empty-cells (- n 1)))
|
|
||||||
(list)))
|
|
||||||
|
|
||||||
(define (gnc:register-guid type guid)
|
(define (gnc:register-guid type guid)
|
||||||
(gnc-build-url URL-TYPE-REGISTER (string-append type guid) ""))
|
(gnc-build-url URL-TYPE-REGISTER (string-append type guid) ""))
|
||||||
@ -814,10 +814,69 @@
|
|||||||
(gnc:html-markup-p
|
(gnc:html-markup-p
|
||||||
(gnc:html-markup-anchor
|
(gnc:html-markup-anchor
|
||||||
(gnc-build-url URL-TYPE-OPTIONS
|
(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")))))
|
(_ "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
|
(define (gnc:html-make-generic-warning
|
||||||
report-title-string report-id
|
report-title-string report-id
|
||||||
warning-title-string warning-string)
|
warning-title-string warning-string)
|
||||||
@ -877,3 +936,5 @@
|
|||||||
((#\>) ">")
|
((#\>) ">")
|
||||||
(else c))))
|
(else c))))
|
||||||
str))))
|
str))))
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -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))))
|
|
||||||
@ -30,7 +30,6 @@
|
|||||||
(use-modules (gnucash app-utils))
|
(use-modules (gnucash app-utils))
|
||||||
(use-modules (gnucash engine))
|
(use-modules (gnucash engine))
|
||||||
(use-modules (gnucash report report-system collectors))
|
(use-modules (gnucash report report-system collectors))
|
||||||
(use-modules (gnucash report report-system list-extras))
|
|
||||||
|
|
||||||
(export account-destination-alist)
|
(export account-destination-alist)
|
||||||
(export category-by-account-report)
|
(export category-by-account-report)
|
||||||
@ -150,13 +149,13 @@
|
|||||||
(splits-up-to (map car account-alist) min-date max-date)))
|
(splits-up-to (map car account-alist) min-date max-date)))
|
||||||
|
|
||||||
(define (category-report-dates-intervals dates)
|
(define (category-report-dates-intervals dates)
|
||||||
(let* ((min-date (car (list-min-max (map first dates) <)))
|
(let* ((min-date (apply min (map first dates)))
|
||||||
(max-date (cdr (list-min-max (map second dates) <))))
|
(max-date (apply max (map second dates))))
|
||||||
(list min-date max-date dates)))
|
(list min-date max-date dates)))
|
||||||
|
|
||||||
(define (category-report-dates-accumulate dates)
|
(define (category-report-dates-accumulate dates)
|
||||||
(let* ((min-date #f)
|
(let* ((min-date #f)
|
||||||
(max-date (cdr (list-min-max dates <)))
|
(max-date (apply max dates))
|
||||||
(datepairs (reverse! (cdr (fold (lambda (next acc)
|
(datepairs (reverse! (cdr (fold (lambda (next acc)
|
||||||
(let ((prev (car acc))
|
(let ((prev (car acc))
|
||||||
(pairs-so-far (cdr acc)))
|
(pairs-so-far (cdr acc)))
|
||||||
|
|||||||
@ -112,6 +112,7 @@
|
|||||||
(export gnc:html-build-acct-table)
|
(export gnc:html-build-acct-table)
|
||||||
(export gnc:first-html-build-acct-table)
|
(export gnc:first-html-build-acct-table)
|
||||||
(export gnc:html-make-exchangerates)
|
(export gnc:html-make-exchangerates)
|
||||||
|
(export gnc:html-render-options-changed)
|
||||||
(export gnc:html-make-generic-warning)
|
(export gnc:html-make-generic-warning)
|
||||||
(export gnc:html-make-no-account-warning)
|
(export gnc:html-make-no-account-warning)
|
||||||
(export gnc:html-make-generic-budget-warning)
|
(export gnc:html-make-generic-budget-warning)
|
||||||
@ -600,6 +601,7 @@
|
|||||||
(export gnc:html-table-set-col-headers-style!)
|
(export gnc:html-table-set-col-headers-style!)
|
||||||
(export gnc:html-table-row-headers-style)
|
(export gnc:html-table-row-headers-style)
|
||||||
(export gnc:html-table-set-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-style!)
|
||||||
(export gnc:html-table-set-col-style!)
|
(export gnc:html-table-set-col-style!)
|
||||||
(export gnc:html-table-set-row-style!)
|
(export gnc:html-table-set-row-style!)
|
||||||
|
|||||||
@ -12,9 +12,8 @@ gnc_add_test_with_guile(test-link-module-report-system test-link-module.c
|
|||||||
set(scm_test_report_system_SOURCES
|
set(scm_test_report_system_SOURCES
|
||||||
test-load-report-system-module.scm
|
test-load-report-system-module.scm
|
||||||
test-collectors.scm
|
test-collectors.scm
|
||||||
test-list-extras.scm
|
|
||||||
test-report-utilities.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
|
set (scm_test_report_system_with_srfi64_SOURCES
|
||||||
@ -31,7 +30,7 @@ set(GUILE_DEPENDS
|
|||||||
scm-scm
|
scm-scm
|
||||||
scm-report-system-3
|
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)
|
if (HAVE_SRFI64)
|
||||||
gnc_add_scheme_tests ("${scm_test_report_system_with_srfi64_SOURCES}")
|
gnc_add_scheme_tests ("${scm_test_report_system_with_srfi64_SOURCES}")
|
||||||
|
|||||||
@ -21,21 +21,18 @@
|
|||||||
|
|
||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
(use-modules (gnucash engine test test-extras))
|
(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 pattern-streamer)
|
||||||
|
|
||||||
(export create-option-set)
|
|
||||||
(export option-set-setter)
|
|
||||||
(export option-set-getter)
|
|
||||||
|
|
||||||
(export tbl-column-count)
|
(export tbl-column-count)
|
||||||
(export tbl-row-count)
|
(export tbl-row-count)
|
||||||
(export tbl-ref)
|
(export tbl-ref)
|
||||||
(export tbl-ref->number)
|
(export tbl-ref->number)
|
||||||
|
|
||||||
;;
|
(export gnc:options->sxml)
|
||||||
;; Random report test related syntax and the like
|
|
||||||
;;
|
|
||||||
|
|
||||||
;;
|
;;
|
||||||
;; Table parsing
|
;; Table parsing
|
||||||
@ -88,69 +85,56 @@
|
|||||||
(define (tbl-ref->number tbl row-index column-index)
|
(define (tbl-ref->number tbl row-index column-index)
|
||||||
(string->number (car (tbl-ref 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)
|
(let* ((template (gnc:find-report-template uuid))
|
||||||
(second sink))
|
(constructor (record-constructor <report>))
|
||||||
|
(report (constructor uuid "bar" options #t #t #f #f ""))
|
||||||
(define (test-sink-count! sink value)
|
(renderer (gnc:report-template-renderer template))
|
||||||
(set-car! (cdr sink) value))
|
(document (renderer report))
|
||||||
|
(sanitize-char (lambda (c)
|
||||||
(define (test-sink-messages sink)
|
(if (or (char-alphabetic? c)
|
||||||
(third sink))
|
(char-numeric? c)) c #\-)))
|
||||||
|
(fileprefix (string-map sanitize-char prefix))
|
||||||
(define (test-sink-messages! sink messages)
|
(filename (string-map sanitize-char test-title)))
|
||||||
(set-car! (cdr (cdr sink)) messages))
|
(gnc:html-document-set-style-sheet! document (gnc:report-stylesheet report))
|
||||||
|
(if test-title
|
||||||
(define (test-sink-check sink message flag)
|
(gnc:html-document-set-title! document test-title))
|
||||||
(test-sink-count! sink (+ (test-sink-count sink) 1))
|
(let* ((filename (format #f "/tmp/~a-~a.html" fileprefix filename))
|
||||||
(if flag #t
|
(render (gnc:html-document-render document)))
|
||||||
(test-sink-messages! sink (cons message (test-sink-messages sink)))))
|
(with-output-to-file filename
|
||||||
|
(lambda ()
|
||||||
(define (test-sink-report sink)
|
(display render)))
|
||||||
(format #t "Completed ~a tests ~a\n"
|
(catch 'parser-error
|
||||||
(test-sink-count sink)
|
(lambda () (xml->sxml render))
|
||||||
(if (null? (test-sink-messages sink)) "PASS" "FAIL"))
|
(lambda (k . args)
|
||||||
(if (null? (test-sink-messages sink)) #t
|
(format #t "*** XML error. see render output at ~a\n~a"
|
||||||
(begin (for-each (lambda (delayed-message)
|
filename (gnc:html-render-options-changed options #t))
|
||||||
(delayed-format-render #t delayed-message))
|
(throw k args))))))
|
||||||
(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))
|
|
||||||
|
|
||||||
|
(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)))
|
||||||
|
|||||||
@ -6,37 +6,11 @@
|
|||||||
(use-modules (gnucash engine test test-extras))
|
(use-modules (gnucash engine test test-extras))
|
||||||
(use-modules (gnucash report report-system test test-extras))
|
(use-modules (gnucash report report-system test test-extras))
|
||||||
(use-modules (gnucash report report-system))
|
(use-modules (gnucash report report-system))
|
||||||
|
(use-modules (gnucash engine test srfi64-extras))
|
||||||
(use-modules (srfi srfi-64))
|
(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)
|
(define (run-test)
|
||||||
(test-runner-factory test-runner)
|
(test-runner-factory gnc:test-runner)
|
||||||
(test-begin "test-html-utilities-srfi64.scm")
|
(test-begin "test-html-utilities-srfi64.scm")
|
||||||
(test-gnc:html-string-sanitize)
|
(test-gnc:html-string-sanitize)
|
||||||
(test-end "test-html-utilities-srfi64.scm"))
|
(test-end "test-html-utilities-srfi64.scm"))
|
||||||
|
|||||||
@ -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) <))))
|
|
||||||
@ -24,10 +24,7 @@
|
|||||||
(use-modules (ice-9 streams))
|
(use-modules (ice-9 streams))
|
||||||
|
|
||||||
(define (run-test)
|
(define (run-test)
|
||||||
(and (logging-and #t)
|
(and (test-pattern-streamer)
|
||||||
(logging-and)
|
|
||||||
(not (logging-and #t #f))
|
|
||||||
(test-pattern-streamer)
|
|
||||||
(test-create-account-structure)))
|
(test-create-account-structure)))
|
||||||
|
|
||||||
(define (test-pattern-streamer)
|
(define (test-pattern-streamer)
|
||||||
|
|||||||
@ -35,23 +35,27 @@
|
|||||||
(use-modules (gnucash report standard-reports transaction))
|
(use-modules (gnucash report standard-reports transaction))
|
||||||
|
|
||||||
;; Define the strings here to avoid typos and make changes easier.
|
;; 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-sorting (N_ "Sorting"))
|
||||||
|
(define pagename-filter (N_ "Filter"))
|
||||||
(define TAX-SETUP-DESC
|
(define TAX-SETUP-DESC
|
||||||
(string-append
|
(gnc:make-html-text
|
||||||
(_ "This report is useful to calculate periodic business tax payable/receivable from
|
(_ "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,
|
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.")
|
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
|
(_ "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.")
|
which will require Tax Tables to be set up correctly. Please see the documentation.")
|
||||||
"<br/><br/>"
|
(gnc:html-markup-br)
|
||||||
|
(gnc:html-markup-br)
|
||||||
(_ "From the Report Options, you will need to select the accounts which will \
|
(_ "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 \
|
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 \
|
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.")
|
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)
|
(define (income-gst-statement-renderer rpt)
|
||||||
(trep-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
|
;; split -> bool
|
||||||
;;
|
;;
|
||||||
;; additional split filter - returns #t if split must be included
|
;; additional split filter - returns #t if split must be included
|
||||||
;; we need to exclude Closing, Link and Payment transactions
|
;; we need to exclude Link and Payment transactions
|
||||||
(let ((trans (xaccSplitGetParent split)))
|
(memv (xaccTransGetTxnType (xaccSplitGetParent split))
|
||||||
(and (member (xaccTransGetTxnType trans) (list TXN-TYPE-NONE TXN-TYPE-INVOICE))
|
(list TXN-TYPE-NONE TXN-TYPE-INVOICE)))
|
||||||
(not (xaccTransGetIsClosingTxn trans)))))
|
|
||||||
|
|
||||||
(define (gst-statement-options-generator)
|
(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 Type")
|
||||||
(gnc:option-make-internal! options gnc:pagename-accounts "Filter By...")
|
(gnc:option-make-internal! options gnc:pagename-accounts "Filter By...")
|
||||||
(gnc:option-make-internal! options gnc:pagename-general "Show original currency amount")
|
(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
|
;; Disable display options not being used anymore
|
||||||
(gnc:option-make-internal! options gnc:pagename-display "Shares")
|
(gnc:option-make-internal! options gnc:pagename-display "Shares")
|
||||||
(gnc:option-make-internal! options gnc:pagename-display "Price")
|
(gnc:option-make-internal! options gnc:pagename-display "Price")
|
||||||
|
|||||||
@ -29,16 +29,6 @@
|
|||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(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)
|
(define (date-col columns-used)
|
||||||
(vector-ref columns-used 0))
|
(vector-ref columns-used 0))
|
||||||
(define (num-col columns-used)
|
(define (num-col columns-used)
|
||||||
@ -793,7 +783,7 @@
|
|||||||
(list
|
(list
|
||||||
(string-append (_ "Client") ": ")
|
(string-append (_ "Client") ": ")
|
||||||
(string-expand address #\newline "<br>")))
|
(string-expand address #\newline "<br>")))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
@ -813,7 +803,7 @@
|
|||||||
(string-expand (qof-print-date (current-time))
|
(string-expand (qof-print-date (current-time))
|
||||||
#\space " "))
|
#\space " "))
|
||||||
(make-client-table address)))
|
(make-client-table address)))
|
||||||
(set-last-row-style!
|
(gnc:html-table-set-last-row-style!
|
||||||
table "td"
|
table "td"
|
||||||
'attribute (list "valign" "top"))
|
'attribute (list "valign" "top"))
|
||||||
table))
|
table))
|
||||||
|
|||||||
@ -8,6 +8,7 @@ set(scm_test_standard_reports_SOURCES
|
|||||||
|
|
||||||
set(scm_test_with_srfi64_SOURCES
|
set(scm_test_with_srfi64_SOURCES
|
||||||
test-transaction.scm
|
test-transaction.scm
|
||||||
|
test-income-gst.scm
|
||||||
)
|
)
|
||||||
|
|
||||||
set(scm_test_report_SUPPORT
|
set(scm_test_report_SUPPORT
|
||||||
|
|||||||
@ -39,9 +39,9 @@
|
|||||||
(setlocale LC_ALL "C")
|
(setlocale LC_ALL "C")
|
||||||
|
|
||||||
(define (run-test)
|
(define (run-test)
|
||||||
(logging-and (test-in-txn)
|
(and (test-in-txn)
|
||||||
(test-out-txn)
|
(test-out-txn)
|
||||||
(test-null-txn)))
|
(test-null-txn)))
|
||||||
|
|
||||||
|
|
||||||
(define (set-option report page tag value)
|
(define (set-option report page tag value)
|
||||||
|
|||||||
@ -40,15 +40,15 @@
|
|||||||
(define constructor (record-constructor <report>))
|
(define constructor (record-constructor <report>))
|
||||||
|
|
||||||
(define (run-net-asset-income-test asset-report-uuid income-report-uuid)
|
(define (run-net-asset-income-test asset-report-uuid income-report-uuid)
|
||||||
(logging-and (two-txn-test asset-report-uuid)
|
(and (two-txn-test asset-report-uuid)
|
||||||
(two-txn-test-2 asset-report-uuid)
|
(two-txn-test-2 asset-report-uuid)
|
||||||
(two-txn-test-income income-report-uuid)
|
(two-txn-test-income income-report-uuid)
|
||||||
|
|
||||||
(null-test asset-report-uuid)
|
(null-test asset-report-uuid)
|
||||||
(null-test income-report-uuid)
|
(null-test income-report-uuid)
|
||||||
(single-txn-test asset-report-uuid)
|
(single-txn-test asset-report-uuid)
|
||||||
(closing-test income-report-uuid)
|
(closing-test income-report-uuid)
|
||||||
#t))
|
#t))
|
||||||
|
|
||||||
;; Just prove that the report exists.
|
;; Just prove that the report exists.
|
||||||
(define (null-test uuid)
|
(define (null-test uuid)
|
||||||
|
|||||||
@ -40,13 +40,11 @@
|
|||||||
(define constructor (record-constructor <report>))
|
(define constructor (record-constructor <report>))
|
||||||
|
|
||||||
(define (run-net-asset-test asset-report-uuid)
|
(define (run-net-asset-test asset-report-uuid)
|
||||||
(logging-and (two-txn-test asset-report-uuid)
|
(and (two-txn-test asset-report-uuid)
|
||||||
(two-txn-test-2 asset-report-uuid)
|
(two-txn-test-2 asset-report-uuid)
|
||||||
|
|
||||||
(null-test asset-report-uuid)
|
(null-test asset-report-uuid)
|
||||||
(single-txn-test asset-report-uuid)
|
(single-txn-test asset-report-uuid)))
|
||||||
|
|
||||||
#t))
|
|
||||||
|
|
||||||
;; Just prove that the report exists.
|
;; Just prove that the report exists.
|
||||||
(define (null-test uuid)
|
(define (null-test uuid)
|
||||||
|
|||||||
213
gnucash/report/standard-reports/test/test-income-gst.scm
Normal file
213
gnucash/report/standard-reports/test/test-income-gst.scm
Normal 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")))
|
||||||
@ -6,10 +6,11 @@
|
|||||||
(use-modules (gnucash report report-system))
|
(use-modules (gnucash report report-system))
|
||||||
(use-modules (gnucash report report-system test test-extras))
|
(use-modules (gnucash report report-system test test-extras))
|
||||||
(use-modules (srfi srfi-64))
|
(use-modules (srfi srfi-64))
|
||||||
|
(use-modules (gnucash engine test srfi64-extras))
|
||||||
(use-modules (sxml simple))
|
(use-modules (sxml simple))
|
||||||
(use-modules (sxml xpath))
|
(use-modules (sxml xpath))
|
||||||
(use-modules (system vm coverage)
|
(use-modules (system vm coverage))
|
||||||
(system vm vm))
|
(use-modules (system vm vm))
|
||||||
|
|
||||||
;; Guide to the test-transaction.scm
|
;; Guide to the test-transaction.scm
|
||||||
|
|
||||||
@ -24,7 +25,7 @@
|
|||||||
;; which sets the SRFI-64 test runner, and initiates the proper test suite
|
;; 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
|
;; in (null-test) and (trep-tests). Please note the tests will all call
|
||||||
;; (options->sxml) which in turn generates the transaction report, and
|
;; (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
|
;; For coverage analysis, please amend (run-test) (if #f ...) to (if
|
||||||
;; #t ...) and this will run (coverage-test) instead, which will
|
;; #t ...) and this will run (coverage-test) instead, which will
|
||||||
@ -42,33 +43,6 @@
|
|||||||
;; Explicitly set locale to make the report output predictable
|
;; Explicitly set locale to make the report output predictable
|
||||||
(setlocale LC_ALL "C")
|
(setlocale LC_ALL "C")
|
||||||
|
|
||||||
(define (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)
|
(define (run-test)
|
||||||
(if #f
|
(if #f
|
||||||
(coverage-test)
|
(coverage-test)
|
||||||
@ -86,7 +60,7 @@
|
|||||||
(close port)))))
|
(close port)))))
|
||||||
|
|
||||||
(define (run-test-proper)
|
(define (run-test-proper)
|
||||||
(test-runner-factory test-runner)
|
(test-runner-factory gnc:test-runner)
|
||||||
(test-begin "transaction.scm")
|
(test-begin "transaction.scm")
|
||||||
(null-test)
|
(null-test)
|
||||||
(trep-tests)
|
(trep-tests)
|
||||||
@ -110,63 +84,17 @@
|
|||||||
(memv c '(#\- #\.))))
|
(memv c '(#\- #\.))))
|
||||||
str)))
|
str)))
|
||||||
|
|
||||||
(define counter
|
|
||||||
(let ((count 0))
|
|
||||||
(lambda ()
|
|
||||||
(set! count (1+ count))
|
|
||||||
count)))
|
|
||||||
|
|
||||||
(define (options->sxml options test-title)
|
(define (options->sxml options test-title)
|
||||||
;; options object -> sxml tree
|
;; options object -> sxml tree
|
||||||
;;
|
;;
|
||||||
;; This function abstracts the whole transaction report renderer.
|
;; This function abstracts the whole transaction report renderer.
|
||||||
;; It also catches XML parsing errors, dumping the options changed.
|
;; 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
|
;; It also dumps the render into /tmp/test-trep-XX.html where XX is the test title
|
||||||
(let* ((template (gnc:find-report-template trep-uuid))
|
(gnc:options->sxml trep-uuid options "test-trep" test-title))
|
||||||
(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)))))))
|
|
||||||
|
|
||||||
(define (get-row-col sxml row col)
|
(define (get-row-col sxml row col)
|
||||||
;; sxml, row & col (numbers or #f) -> list-of-string
|
(sxml->table-row-col sxml 1 row col))
|
||||||
;;
|
|
||||||
;; 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>))
|
|
||||||
|
|
||||||
(define (set-option! options section name value)
|
(define (set-option! options section name value)
|
||||||
(let ((option (gnc:lookup-option options section name)))
|
(let ((option (gnc:lookup-option options section name)))
|
||||||
@ -189,12 +117,13 @@
|
|||||||
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
|
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
|
||||||
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
|
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
|
||||||
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY)))
|
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY)))
|
||||||
|
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
|
||||||
))
|
))
|
||||||
|
|
||||||
(define (null-test)
|
(define (null-test)
|
||||||
;; This null-test tests for the presence of report.
|
;; This null-test tests for the presence of report.
|
||||||
(let ((options (gnc:make-report-options trep-uuid)))
|
(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)
|
(define (trep-tests)
|
||||||
;; This function will perform implementation testing on the transaction report.
|
;; This function will perform implementation testing on the transaction report.
|
||||||
@ -207,6 +136,7 @@
|
|||||||
(income (cdr (assoc "Income" account-alist)))
|
(income (cdr (assoc "Income" account-alist)))
|
||||||
(expense (cdr (assoc "Expenses" account-alist)))
|
(expense (cdr (assoc "Expenses" account-alist)))
|
||||||
(liability (cdr (assoc "Liabilities" account-alist)))
|
(liability (cdr (assoc "Liabilities" account-alist)))
|
||||||
|
(equity (cdr (assoc "Equity" account-alist)))
|
||||||
(YEAR (gnc:time64-get-year (gnc:get-today)))
|
(YEAR (gnc:time64-get-year (gnc:get-today)))
|
||||||
(foreign1 (gnc-commodity-table-lookup
|
(foreign1 (gnc-commodity-table-lookup
|
||||||
(gnc-commodity-table-get-table (gnc-account-get-book bank))
|
(gnc-commodity-table-get-table (gnc-account-get-book bank))
|
||||||
@ -293,6 +223,10 @@
|
|||||||
(xaccTransSetNotes txn "multisplit")
|
(xaccTransSetNotes txn "multisplit")
|
||||||
(xaccTransCommitEdit txn))
|
(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
|
;; A couple of transactions which involve foreign currency
|
||||||
;; conversions. We'll set the currencies to GBP and USD.
|
;; 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")
|
(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")
|
(test-begin "general options")
|
||||||
|
|
||||||
(let* ((options (default-testing-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")))
|
(default-headers '("Date" "Num" "Description" "Memo/Notes" "Account" "Amount")))
|
||||||
(test-equal "default headers"
|
(test-equal "default headers"
|
||||||
default-headers
|
default-headers
|
||||||
@ -351,9 +285,9 @@
|
|||||||
(set-option! options "Sorting" "Primary Subtotal" #t)
|
(set-option! options "Sorting" "Primary Subtotal" #t)
|
||||||
(set-option! options "Sorting" "Secondary Key" 'date)
|
(set-option! options "Sorting" "Secondary Key" 'date)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
|
(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"
|
(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))
|
(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"
|
(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")
|
'("Grand Total" "$2,280.00" "$2,280.00")
|
||||||
@ -377,19 +311,19 @@
|
|||||||
|
|
||||||
;; Filter Account Name Filters
|
;; Filter Account Name Filters
|
||||||
(set-option! options "Filter" "Account Name Filter" "Expenses")
|
(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"
|
(test-equal "account name filter to 'expenses', sum = $31.00"
|
||||||
'("$31.00")
|
'("$31.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Account Name Filter" "Expen.es")
|
(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"
|
(test-equal "account name filter to 'expen.es', blank report"
|
||||||
'()
|
'()
|
||||||
(get-row-col sxml #f #f)))
|
(get-row-col sxml #f #f)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Use regular expressions for account name filter" #t)
|
(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"
|
(test-equal "account name filter to 'expen.es' and switch on regex filter, sum = $31.00"
|
||||||
'("$31.00")
|
'("$31.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(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" "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 "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
|
||||||
(set-option! options "Filter" "Transaction Filter" "desc-3")
|
(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"
|
(test-equal "transaction filter in bank to 'desc-3', sum = $29.00"
|
||||||
'("$29.00")
|
'("$29.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Transaction Filter" "not.s?")
|
(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"
|
(test-equal "transaction filter in bank to 'not.s?', blank report"
|
||||||
'()
|
'()
|
||||||
(get-row-col sxml #f #f)))
|
(get-row-col sxml #f #f)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Use regular expressions for transaction filter" #t)
|
(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"
|
(test-equal "transaction filter in bank to 'not.s?' and switch regex, sum = -$23.00"
|
||||||
'("-$23.00")
|
'("-$23.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(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" "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 "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
|
||||||
(set-option! options "Filter" "Reconcile Status" 'unreconciled)
|
(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"
|
(test-equal "filter unreconciled only, sum = -$20.00"
|
||||||
'("-$20.00")
|
'("-$20.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Reconcile Status" 'cleared)
|
(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"
|
(test-equal "filter cleared only, sum = $29.00"
|
||||||
'("$29.00")
|
'("$29.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Reconcile Status" 'reconciled)
|
(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"
|
(test-equal "filter reconciled only, sum = -$8.00"
|
||||||
'("-$8.00")
|
'("-$8.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(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 "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
|
||||||
(set-option! options "Accounts" "Filter By..." (list income))
|
(set-option! options "Accounts" "Filter By..." (list income))
|
||||||
(set-option! options "Accounts" "Filter Type" 'include)
|
(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"
|
(test-equal "filter includes bank-income, sum = -$29.00"
|
||||||
'("$29.00")
|
'("$29.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Accounts" "Filter Type" 'exclude)
|
(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"
|
(test-equal "filter excludes bank-income, sum = -$28.00"
|
||||||
'("-$28.00")
|
'("-$28.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(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" "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 "General" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 1970)))
|
||||||
(set-option! options "Filter" "Void Transactions" 'void-only)
|
(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"
|
(test-equal "filter void-transactions only, sum = -$10.00"
|
||||||
'("$10.00")
|
'("$10.00")
|
||||||
(get-row-col sxml -1 -1)))
|
(get-row-col sxml -1 -1)))
|
||||||
|
|
||||||
(set-option! options "Filter" "Void Transactions" 'both)
|
(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"
|
(test-equal "filter void-transactions only, sum = $11.00"
|
||||||
'("$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")
|
(test-end "accounts selectors and filtering")
|
||||||
|
|
||||||
@ -483,7 +441,7 @@
|
|||||||
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
|
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
|
||||||
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
|
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
|
||||||
"Totals"))
|
"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"
|
(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 1) // th)) sxml))
|
||||||
(length ((sxpath '(// (table 1) // (tr 4) // td)) 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" "Primary Subtotal for Date Key" 'none)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'none)
|
(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"
|
(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 1) // th)) sxml))
|
||||||
(length ((sxpath '(// (table 1) // (tr 4) // td)) sxml))
|
(length ((sxpath '(// (table 1) // (tr 4) // td)) sxml))
|
||||||
@ -502,7 +460,7 @@
|
|||||||
1)))
|
1)))
|
||||||
|
|
||||||
(set-option! options "Display" "Amount" 'none)
|
(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"
|
(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 1) // th)) sxml))
|
||||||
(length ((sxpath '(// (table 1) // (tr 4) // td)) 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" "Primary Subtotal for Date Key" 'weekly)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal" #t)
|
(set-option! options "Sorting" "Secondary Subtotal" #t)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'weekly)
|
(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"
|
(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) // th)) sxml))
|
||||||
(length ((sxpath '(// (table 1) // (tr -1) // td)) sxml))
|
(length ((sxpath '(// (table 1) // (tr -1) // td)) sxml))
|
||||||
@ -531,7 +489,7 @@
|
|||||||
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
|
(list "Date" "Reconciled Date" "Num" "Description" "Memo" "Notes"
|
||||||
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
|
"Account Name" "Other Account Name" "Shares" "Price" "Running Balance"
|
||||||
"Totals" "Use Full Other Account Name" "Use Full Account Name"))
|
"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"
|
(test-equal "all display columns on, displays correct columns"
|
||||||
(list "Date" "Reconciled Date" "Num" "Description" "Memo/Notes" "Account"
|
(list "Date" "Reconciled Date" "Num" "Description" "Memo/Notes" "Account"
|
||||||
"Transfer from/to" "Shares" "Price" "Amount" "Running Balance")
|
"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" "Primary Subtotal for Date Key" 'none)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'none)
|
(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"
|
(test-assert "multi line transaction with 1st split have same memo"
|
||||||
(apply string=? (get-row-col sxml #f 4)))
|
(apply string=? (get-row-col sxml #f 4)))
|
||||||
|
|
||||||
@ -573,7 +531,7 @@
|
|||||||
;; Remove expense multisplit, transaction is not shown
|
;; Remove expense multisplit, transaction is not shown
|
||||||
(set-option! options "Accounts" "Filter By..." (list expense))
|
(set-option! options "Accounts" "Filter By..." (list expense))
|
||||||
(set-option! options "Accounts" "Filter Type" 'exclude)
|
(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"
|
(test-equal "multi-line has been excluded"
|
||||||
'()
|
'()
|
||||||
(get-row-col sxml #f #f)))
|
(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" "End Date" (cons 'absolute (gnc-dmy2time64 31 12 2000)))
|
||||||
(set-option! options "General" "Common Currency" #t)
|
(set-option! options "General" "Common Currency" #t)
|
||||||
(set-option! options "General" "Show original currency amount" #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"
|
(test-equal "single amount column, with original currency headers"
|
||||||
(list "Date" "Num" "Description" "Memo/Notes" "Account"
|
(list "Date" "Num" "Description" "Memo/Notes" "Account"
|
||||||
"Amount" "USD" "Amount")
|
"Amount (USD)" "Amount")
|
||||||
(get-row-col sxml 0 #f)))
|
(get-row-col sxml 0 #f)))
|
||||||
|
|
||||||
(set-option! options "Display" "Amount" 'double)
|
(set-option! options "Display" "Amount" 'double)
|
||||||
@ -597,7 +555,7 @@
|
|||||||
(set-option! options "Display" "Account Code" #t)
|
(set-option! options "Display" "Account Code" #t)
|
||||||
(set-option! options "Display" "Other Account Name" #t)
|
(set-option! options "Display" "Other Account Name" #t)
|
||||||
(set-option! options "Display" "Other Account Code" #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
|
;; Note. It's difficult to test converted monetary
|
||||||
;; amounts. Although I've set transfers from USD/GBP, the
|
;; amounts. Although I've set transfers from USD/GBP, the
|
||||||
;; transfers do not update the pricedb automatically,
|
;; transfers do not update the pricedb automatically,
|
||||||
@ -606,7 +564,7 @@
|
|||||||
;; output here too.
|
;; output here too.
|
||||||
(test-equal "dual amount headers"
|
(test-equal "dual amount headers"
|
||||||
(list "Date" "Num" "Description" "Memo/Notes" "Account" "Transfer from/to"
|
(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))
|
(get-row-col sxml 0 #f))
|
||||||
(test-equal "Account Name and Code displayed"
|
(test-equal "Account Name and Code displayed"
|
||||||
(list "01-GBP Root.Asset.GBP Bank")
|
(list "01-GBP Root.Asset.GBP Bank")
|
||||||
@ -638,21 +596,21 @@
|
|||||||
(set-option! options "Sorting" "Primary Subtotal" #f)
|
(set-option! options "Sorting" "Primary Subtotal" #f)
|
||||||
(set-option! options "Sorting" "Secondary Key" 'description)
|
(set-option! options "Sorting" "Secondary Key" 'description)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
(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"
|
(test-equal "sign-reversal is none, correct signs of amounts"
|
||||||
'(#f #t #t #f #f #t #t #t #t #f #f #f #f #t)
|
'(#f #t #t #f #f #t #t #t #t #f #f #f #f #t)
|
||||||
(map (lambda (s) (not (string-contains s "-")))
|
(map (lambda (s) (not (string-contains s "-")))
|
||||||
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
|
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
|
||||||
|
|
||||||
(set-option! options "Display" "Sign Reverses" 'income-expense)
|
(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"
|
(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)
|
'(#f #t #t #f #f #f #f #f #f #t #t #f #f #t)
|
||||||
(map (lambda (s) (not (string-contains s "-")))
|
(map (lambda (s) (not (string-contains s "-")))
|
||||||
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
|
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml))))
|
||||||
|
|
||||||
(set-option! options "Display" "Sign Reverses" 'credit-accounts)
|
(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"
|
(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)
|
'(#f #t #t #f #f #t #t #t #t #t #t #t #t #f)
|
||||||
(map (lambda (s) (not (string-contains s "-")))
|
(map (lambda (s) (not (string-contains s "-")))
|
||||||
@ -665,10 +623,10 @@
|
|||||||
(set-option! options "General" "Show original currency amount" #t)
|
(set-option! options "General" "Show original currency amount" #t)
|
||||||
(set-option! options "Sorting" "Primary Key" 'date)
|
(set-option! options "Sorting" "Primary Key" 'date)
|
||||||
(set-option! options "Sorting" "Primary Subtotal for Date Key" 'none)
|
(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"
|
(test-equal "dual amount column, with original currency headers"
|
||||||
(list "Date" "Num" "Description" "Memo/Notes" "Account"
|
(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))
|
(get-row-col sxml 0 #f))
|
||||||
(test-equal "dual amount column, grand totals available"
|
(test-equal "dual amount column, grand totals available"
|
||||||
(list "Grand Total" " " " " " " " " "$2,280.00" "$2,280.00")
|
(list "Grand Total" " " " " " " " " "$2,280.00" "$2,280.00")
|
||||||
@ -696,42 +654,48 @@
|
|||||||
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
(set-option! options "Sorting" "Secondary Subtotal" #f)
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'date)
|
(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"
|
(test-equal "dates are sorted"
|
||||||
'("12/31/69" "12/31/69" "01/01/70" "02/01/70" "02/10/70")
|
'("12/31/69" "12/31/69" "01/01/70" "02/01/70" "02/10/70")
|
||||||
(get-row-col sxml #f 1)))
|
(get-row-col sxml #f 1)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'number)
|
(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"
|
(test-equal "sort by number"
|
||||||
'("trn1" "trn2" "trn3" "trn4" "trn7")
|
'("trn1" "trn2" "trn3" "trn4" "trn7")
|
||||||
(get-row-col sxml #f 2)))
|
(get-row-col sxml #f 2)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'reconciled-status)
|
(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"
|
(test-equal "sort by reconciled status"
|
||||||
'("desc-2" "desc-7" "desc-3" "desc-1" "desc-4")
|
'("desc-2" "desc-7" "desc-3" "desc-1" "desc-4")
|
||||||
(get-row-col sxml #f 3)))
|
(get-row-col sxml #f 3)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'memo)
|
(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"
|
(test-equal "sort by memo"
|
||||||
'("notes3" "memo-1" "memo-2" "memo-3")
|
'("notes3" "memo-1" "memo-2" "memo-3")
|
||||||
(get-row-col sxml #f 4)))
|
(get-row-col sxml #f 4)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'account-name)
|
(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"
|
(test-assert "account names are sorted"
|
||||||
(sorted? (get-row-col sxml #f 5) string<?)))
|
(sorted? (get-row-col sxml #f 5) string<?)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Primary Key" 'corresponding-acc-name)
|
(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"
|
(test-equal "sort by corresponding-acc-name"
|
||||||
'("Expenses" "Expenses" "Income" "Income" "Liabilities")
|
'("Expenses" "Expenses" "Income" "Income" "Liabilities")
|
||||||
(get-row-col sxml #f 6)))
|
(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)
|
(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"
|
(test-equal "sort by amount"
|
||||||
'("-$15.00" "-$8.00" "-$5.00" "$10.00" "$29.00")
|
'("-$15.00" "-$8.00" "-$5.00" "$10.00" "$29.00")
|
||||||
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml)))
|
((sxpath '(// (table 1) // tr // (td -1) // a // *text*)) sxml)))
|
||||||
@ -746,7 +710,7 @@
|
|||||||
(set-option! options "Display" "Totals" #t)
|
(set-option! options "Display" "Totals" #t)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
|
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
|
||||||
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
|
(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"
|
(test-equal "sorting=account-name, date-quarterly, subtotals only"
|
||||||
'("$570.00" "$570.00" "$570.00" "$570.00" "$2,280.00" "$2,280.00")
|
'("$570.00" "$570.00" "$570.00" "$570.00" "$2,280.00" "$2,280.00")
|
||||||
(get-row-col sxml #f -1)))
|
(get-row-col sxml #f -1)))
|
||||||
@ -764,30 +728,30 @@
|
|||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'quarterly)
|
(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 Informal Debit/Credit Headers" #t)
|
||||||
(set-option! options "Sorting" "Show Account Description" #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"
|
(test-equal "expense acc friendly headers"
|
||||||
'("\n" "Expenses" "Expense" "Rebate")
|
'("\n" "Expenses" "\n" "Expense" "\n" "Rebate")
|
||||||
(get-row-col sxml 47 #f))
|
(get-row-col sxml 47 #f))
|
||||||
(test-equal "income acc friendly headers"
|
(test-equal "income acc friendly headers"
|
||||||
'("\n" "Income" "Charge" "Income")
|
'("\n" "Income" "\n" "Charge" "\n" "Income")
|
||||||
(get-row-col sxml 69 #f)))
|
(get-row-col sxml 69 #f)))
|
||||||
|
|
||||||
(set-option! options "Accounts" "Accounts" (list bank))
|
(set-option! options "Accounts" "Accounts" (list bank))
|
||||||
(set-option! options "Display" "Totals" #f)
|
(set-option! options "Display" "Totals" #f)
|
||||||
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
|
(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"
|
(test-equal "quarterly subtotals are correct"
|
||||||
'("$570.00" "$570.00" "$570.00" "$570.00")
|
'("$570.00" "$570.00" "$570.00" "$570.00")
|
||||||
(get-row-col sxml #f 4)))
|
(get-row-col sxml #f 4)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
|
(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"
|
(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")
|
'("$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)))
|
(get-row-col sxml #f 4)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'yearly)
|
(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"
|
(test-equal "yearly subtotals are correct"
|
||||||
'("$2,280.00")
|
'("$2,280.00")
|
||||||
(get-row-col sxml #f 4)))
|
(get-row-col sxml #f 4)))
|
||||||
@ -797,14 +761,14 @@
|
|||||||
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #f)
|
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #f)
|
||||||
(set-option! options "Filter" "Void Transactions" 'both)
|
(set-option! options "Filter" "Void Transactions" 'both)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'daily)
|
(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"
|
(test-equal "daily subtotals are correct"
|
||||||
'("$39.00")
|
'("$39.00")
|
||||||
(get-row-col sxml 5 4)))
|
(get-row-col sxml 5 4)))
|
||||||
|
|
||||||
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
|
(set-option! options "Sorting" "Show subtotals only (hide transactional data)" #t)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'weekly)
|
(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)"
|
(test-equal "weekly subtotals are correct (1)"
|
||||||
'("$34.00" "$89.00")
|
'("$34.00" "$89.00")
|
||||||
(get-row-col sxml #f 4))
|
(get-row-col sxml #f 4))
|
||||||
@ -825,7 +789,7 @@
|
|||||||
(set-option! options "Sorting" "Primary Subtotal" #t)
|
(set-option! options "Sorting" "Primary Subtotal" #t)
|
||||||
(set-option! options "Sorting" "Secondary Key" 'date)
|
(set-option! options "Sorting" "Secondary Key" 'date)
|
||||||
(set-option! options "Sorting" "Secondary Subtotal for Date Key" 'monthly)
|
(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"
|
(test-equal "summary bank-row is correct"
|
||||||
(list "Bank" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00" "$190.00"
|
(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")
|
"$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" "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 "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"
|
(test-equal "sparse summary-table - row 1"
|
||||||
(list "Bank" "$29.00" "-$5.00" "-$23.00" "$1.00")
|
(list "Bank" "$29.00" "-$5.00" "-$23.00" "$1.00")
|
||||||
(get-row-col sxml 1 #f))
|
(get-row-col sxml 1 #f))
|
||||||
|
|||||||
@ -17,6 +17,7 @@
|
|||||||
;; - add support for indenting for better grouping
|
;; - add support for indenting for better grouping
|
||||||
;; - add defaults suitable for a reconciliation report
|
;; - add defaults suitable for a reconciliation report
|
||||||
;; - add subtotal summary grid
|
;; - add subtotal summary grid
|
||||||
|
;; - by default, exclude closing transactions from the report
|
||||||
;;
|
;;
|
||||||
;; This program is free software; you can redistribute it and/or
|
;; This program is free software; you can redistribute it and/or
|
||||||
;; modify it under the terms of the GNU General Public License as
|
;; modify it under the terms of the GNU General Public License as
|
||||||
@ -39,7 +40,7 @@
|
|||||||
|
|
||||||
(define-module (gnucash report standard-reports transaction))
|
(define-module (gnucash report standard-reports transaction))
|
||||||
|
|
||||||
(use-modules (gnucash utilities))
|
(use-modules (gnucash utilities))
|
||||||
(use-modules (srfi srfi-1))
|
(use-modules (srfi srfi-1))
|
||||||
(use-modules (srfi srfi-11))
|
(use-modules (srfi srfi-11))
|
||||||
(use-modules (srfi srfi-13))
|
(use-modules (srfi srfi-13))
|
||||||
@ -49,9 +50,6 @@
|
|||||||
|
|
||||||
(gnc:module-load "gnucash/report/report-system" 0)
|
(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 the strings here to avoid typos and make changes easier.
|
||||||
(define reportname (N_ "Transaction Report"))
|
(define reportname (N_ "Transaction Report"))
|
||||||
|
|
||||||
@ -98,6 +96,7 @@
|
|||||||
(define optname-transaction-matcher-regex (N_ "Use regular expressions for transaction filter"))
|
(define optname-transaction-matcher-regex (N_ "Use regular expressions for transaction filter"))
|
||||||
(define optname-reconcile-status (N_ "Reconcile Status"))
|
(define optname-reconcile-status (N_ "Reconcile Status"))
|
||||||
(define optname-void-transactions (N_ "Void Transactions"))
|
(define optname-void-transactions (N_ "Void Transactions"))
|
||||||
|
(define optname-closing-transactions (N_ "Closing transactions"))
|
||||||
|
|
||||||
;;Styles
|
;;Styles
|
||||||
(define def:grand-total-style "grand-total")
|
(define def:grand-total-style "grand-total")
|
||||||
@ -113,15 +112,8 @@ in the Options panel."))
|
|||||||
|
|
||||||
(define DATE-SORTING-TYPES (list 'date 'reconciled-date))
|
(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
|
(define ACCOUNT-SORTING-TYPES (list 'account-name 'corresponding-acc-name
|
||||||
'account-code 'corresponding-acc-code))
|
'account-code 'corresponding-acc-code))
|
||||||
(define CUSTOM-SORTING (list 'reconciled-status))
|
|
||||||
|
|
||||||
(define SORTKEY-INFORMAL-HEADERS (list 'account-name 'account-code))
|
(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 'renderer-fn (lambda (a) (xaccSplitGetAccount a)))))
|
||||||
|
|
||||||
(cons 'date (list (cons 'sortkey (list SPLIT-TRANS TRANS-DATE-POSTED))
|
(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 'text (_ "Date"))
|
||||||
(cons 'tip (_ "Sort by date."))
|
(cons 'tip (_ "Sort by date."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
|
|
||||||
(cons 'reconciled-date (list (cons 'sortkey (list SPLIT-DATE-RECONCILED))
|
(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 'text (_ "Reconciled Date"))
|
||||||
(cons 'tip (_ "Sort by the Reconciled Date."))
|
(cons 'tip (_ "Sort by the Reconciled Date."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
@ -195,42 +187,48 @@ in the Options panel."))
|
|||||||
(cons 'renderer-fn (lambda (a) (xaccSplitGetAccount (xaccSplitGetOtherSplit a))))))
|
(cons 'renderer-fn (lambda (a) (xaccSplitGetAccount (xaccSplitGetOtherSplit a))))))
|
||||||
|
|
||||||
(cons 'amount (list (cons 'sortkey (list SPLIT-VALUE))
|
(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 'text (_ "Amount"))
|
||||||
(cons 'tip (_ "Sort by amount."))
|
(cons 'tip (_ "Sort by amount."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
|
|
||||||
(cons 'description (list (cons 'sortkey (list SPLIT-TRANS TRANS-DESCRIPTION))
|
(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 'text (_ "Description"))
|
||||||
(cons 'tip (_ "Sort by description."))
|
(cons 'tip (_ "Sort by description."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn (lambda (s) (xaccTransGetDescription (xaccSplitGetParent s))))))
|
||||||
|
|
||||||
(if (and (gnc-current-session-exist)
|
(if (and (gnc-current-session-exist)
|
||||||
(qof-book-use-split-action-for-num-field (gnc-get-current-book)))
|
(qof-book-use-split-action-for-num-field (gnc-get-current-book)))
|
||||||
(cons 'number (list (cons 'sortkey (list SPLIT-ACTION))
|
(cons 'number (list (cons 'sortkey (list SPLIT-ACTION))
|
||||||
(cons 'split-sortvalue #f)
|
(cons 'split-sortvalue (lambda (a) (xaccSplitGetAction a)))
|
||||||
(cons 'text (_ "Number/Action"))
|
(cons 'text (_ "Number/Action"))
|
||||||
(cons 'tip (_ "Sort by check number/action."))
|
(cons 'tip (_ "Sort by check number/action."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
|
|
||||||
(cons 'number (list (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
|
(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 'text (_ "Number"))
|
||||||
(cons 'tip (_ "Sort by check/transaction number."))
|
(cons 'tip (_ "Sort by check/transaction number."))
|
||||||
(cons 'renderer-fn #f))))
|
(cons 'renderer-fn #f))))
|
||||||
|
|
||||||
(cons 't-number (list (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
|
(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 'text (_ "Transaction Number"))
|
||||||
(cons 'tip (_ "Sort by transaction number."))
|
(cons 'tip (_ "Sort by transaction number."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
|
|
||||||
(cons 'memo (list (cons 'sortkey (list SPLIT-MEMO))
|
(cons 'memo (list (cons 'sortkey (list SPLIT-MEMO))
|
||||||
(cons 'split-sortvalue #f)
|
(cons 'split-sortvalue (lambda (s) (xaccSplitGetMemo s)))
|
||||||
(cons 'text (_ "Memo"))
|
(cons 'text (_ "Memo"))
|
||||||
(cons 'tip (_ "Sort by 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 'none (list (cons 'sortkey '())
|
||||||
(cons 'split-sortvalue #f)
|
(cons 'split-sortvalue #f)
|
||||||
@ -258,36 +256,42 @@ in the Options panel."))
|
|||||||
(list
|
(list
|
||||||
(cons 'none (list
|
(cons 'none (list
|
||||||
(cons 'split-sortvalue #f)
|
(cons 'split-sortvalue #f)
|
||||||
|
(cons 'date-sortvalue #f)
|
||||||
(cons 'text (_ "None"))
|
(cons 'text (_ "None"))
|
||||||
(cons 'tip (_ "None."))
|
(cons 'tip (_ "None."))
|
||||||
(cons 'renderer-fn #f)))
|
(cons 'renderer-fn #f)))
|
||||||
|
|
||||||
(cons 'daily (list
|
(cons 'daily (list
|
||||||
(cons 'split-sortvalue (lambda (s) (time64-day (split->time64 s))))
|
(cons 'split-sortvalue (lambda (s) (time64-day (split->time64 s))))
|
||||||
|
(cons 'date-sortvalue time64-day)
|
||||||
(cons 'text (_ "Daily"))
|
(cons 'text (_ "Daily"))
|
||||||
(cons 'tip (_ "Daily."))
|
(cons 'tip (_ "Daily."))
|
||||||
(cons 'renderer-fn (lambda (s) (time64->daily-string (split->time64 s))))))
|
(cons 'renderer-fn (lambda (s) (time64->daily-string (split->time64 s))))))
|
||||||
|
|
||||||
(cons 'weekly (list
|
(cons 'weekly (list
|
||||||
(cons 'split-sortvalue (lambda (s) (time64-week (split->time64 s))))
|
(cons 'split-sortvalue (lambda (s) (time64-week (split->time64 s))))
|
||||||
|
(cons 'date-sortvalue time64-week)
|
||||||
(cons 'text (_ "Weekly"))
|
(cons 'text (_ "Weekly"))
|
||||||
(cons 'tip (_ "Weekly."))
|
(cons 'tip (_ "Weekly."))
|
||||||
(cons 'renderer-fn (lambda (s) (gnc:date-get-week-year-string (gnc-localtime (split->time64 s)))))))
|
(cons 'renderer-fn (lambda (s) (gnc:date-get-week-year-string (gnc-localtime (split->time64 s)))))))
|
||||||
|
|
||||||
(cons 'monthly (list
|
(cons 'monthly (list
|
||||||
(cons 'split-sortvalue (lambda (s) (time64-month (split->time64 s))))
|
(cons 'split-sortvalue (lambda (s) (time64-month (split->time64 s))))
|
||||||
|
(cons 'date-sortvalue time64-month)
|
||||||
(cons 'text (_ "Monthly"))
|
(cons 'text (_ "Monthly"))
|
||||||
(cons 'tip (_ "Monthly."))
|
(cons 'tip (_ "Monthly."))
|
||||||
(cons 'renderer-fn (lambda (s) (gnc:date-get-month-year-string (gnc-localtime (split->time64 s)))))))
|
(cons 'renderer-fn (lambda (s) (gnc:date-get-month-year-string (gnc-localtime (split->time64 s)))))))
|
||||||
|
|
||||||
(cons 'quarterly (list
|
(cons 'quarterly (list
|
||||||
(cons 'split-sortvalue (lambda (s) (time64-quarter (split->time64 s))))
|
(cons 'split-sortvalue (lambda (s) (time64-quarter (split->time64 s))))
|
||||||
|
(cons 'date-sortvalue time64-quarter)
|
||||||
(cons 'text (_ "Quarterly"))
|
(cons 'text (_ "Quarterly"))
|
||||||
(cons 'tip (_ "Quarterly."))
|
(cons 'tip (_ "Quarterly."))
|
||||||
(cons 'renderer-fn (lambda (s) (gnc:date-get-quarter-year-string (gnc-localtime (split->time64 s)))))))
|
(cons 'renderer-fn (lambda (s) (gnc:date-get-quarter-year-string (gnc-localtime (split->time64 s)))))))
|
||||||
|
|
||||||
(cons 'yearly (list
|
(cons 'yearly (list
|
||||||
(cons 'split-sortvalue (lambda (s) (time64-year (split->time64 s))))
|
(cons 'split-sortvalue (lambda (s) (time64-year (split->time64 s))))
|
||||||
|
(cons 'date-sortvalue time64-year)
|
||||||
(cons 'text (_ "Yearly"))
|
(cons 'text (_ "Yearly"))
|
||||||
(cons 'tip (_ "Yearly."))
|
(cons 'tip (_ "Yearly."))
|
||||||
(cons 'renderer-fn (lambda (s) (gnc:date-get-year-string (gnc-localtime (split->time64 s)))))))))
|
(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 'text (_ "Both"))
|
||||||
(cons 'tip (_ "Show both (and include void transactions in totals)."))))))
|
(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
|
(define reconcile-status-list
|
||||||
;; 'filter-types must be either #f (i.e. disable reconcile filter)
|
;; 'filter-types must be either #f (i.e. disable reconcile filter)
|
||||||
;; or a value defined as defined in Query.c
|
;; 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-EQUITY ACCT-TYPE-CREDIT
|
||||||
ACCT-TYPE-INCOME))))))
|
ACCT-TYPE-INCOME))))))
|
||||||
|
|
||||||
|
|
||||||
(define (keylist-get-info keylist key info)
|
(define (keylist-get-info keylist key info)
|
||||||
(cdr (assq info (cdr (assq key keylist)))))
|
(cdr (assq info (cdr (assq key keylist)))))
|
||||||
|
|
||||||
@ -399,6 +419,20 @@ Credit Card, and Income accounts."))
|
|||||||
(keylist-get-info keylist (car item) 'tip)))
|
(keylist-get-info keylist (car item) 'tip)))
|
||||||
keylist))
|
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
|
;; Set defaults for reconcilation report
|
||||||
@ -537,6 +571,16 @@ tags within description, notes or memo. ")
|
|||||||
'non-void-only
|
'non-void-only
|
||||||
(keylist->vectorlist show-void-list)))
|
(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
|
;; Accounts options
|
||||||
|
|
||||||
;; account to do report on
|
;; account to do report on
|
||||||
@ -585,10 +629,10 @@ tags within description, notes or memo. ")
|
|||||||
|
|
||||||
(define (apply-selectable-by-name-sorting-options)
|
(define (apply-selectable-by-name-sorting-options)
|
||||||
(let* ((prime-sortkey-enabled (not (eq? prime-sortkey 'none)))
|
(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))
|
(prime-date-sortingtype-enabled (member prime-sortkey DATE-SORTING-TYPES))
|
||||||
(sec-sortkey-enabled (not (eq? sec-sortkey 'none)))
|
(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)))
|
(sec-date-sortingtype-enabled (member sec-sortkey DATE-SORTING-TYPES)))
|
||||||
|
|
||||||
(gnc-option-db-set-option-selectable-by-name
|
(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)))
|
(let ((sortkey (opt-val pagename-sorting optname-prime-sortkey)))
|
||||||
(if (member sortkey DATE-SORTING-TYPES)
|
(if (member sortkey DATE-SORTING-TYPES)
|
||||||
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-prime-date-subtotal) info)
|
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-prime-date-subtotal) info)
|
||||||
(and (member sortkey SUBTOTAL-ENABLED)
|
(and (SUBTOTAL-ENABLED? sortkey)
|
||||||
(and (opt-val pagename-sorting optname-prime-subtotal)
|
(opt-val pagename-sorting optname-prime-subtotal)
|
||||||
(keylist-get-info sortkey-list sortkey info))))))
|
(keylist-get-info sortkey-list sortkey info)))))
|
||||||
|
|
||||||
(define (secondary-get-info info)
|
(define (secondary-get-info info)
|
||||||
(let ((sortkey (opt-val pagename-sorting optname-sec-sortkey)))
|
(let ((sortkey (opt-val pagename-sorting optname-sec-sortkey)))
|
||||||
(if (member sortkey DATE-SORTING-TYPES)
|
(if (member sortkey DATE-SORTING-TYPES)
|
||||||
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-sec-date-subtotal) info)
|
(keylist-get-info date-subtotal-list (opt-val pagename-sorting optname-sec-date-subtotal) info)
|
||||||
(and (member sortkey SUBTOTAL-ENABLED)
|
(and (SUBTOTAL-ENABLED? sortkey)
|
||||||
(and (opt-val pagename-sorting optname-sec-subtotal)
|
(opt-val pagename-sorting optname-sec-subtotal)
|
||||||
(keylist-get-info sortkey-list sortkey info))))))
|
(keylist-get-info sortkey-list sortkey info)))))
|
||||||
|
|
||||||
(let* ((work-to-do (length splits))
|
(let* ((work-to-do (length splits))
|
||||||
(work-done 0)
|
(work-done 0)
|
||||||
@ -1093,10 +1137,11 @@ tags within description, notes or memo. ")
|
|||||||
"number-cell"
|
"number-cell"
|
||||||
(gnc:make-gnc-monetary currency price-decimal)))))))))
|
(gnc:make-gnc-monetary currency price-decimal)))))))))
|
||||||
|
|
||||||
(if (and (null? left-cols-list)
|
(if (or (column-uses? 'subtotals-only)
|
||||||
(or (opt-val gnc:pagename-display "Totals")
|
(and (null? left-cols-list)
|
||||||
(primary-get-info 'renderer-fn)
|
(or (opt-val gnc:pagename-display "Totals")
|
||||||
(secondary-get-info 'renderer-fn)))
|
(primary-get-info 'renderer-fn)
|
||||||
|
(secondary-get-info 'renderer-fn))))
|
||||||
(list (vector "" (lambda (s t) #f)))
|
(list (vector "" (lambda (s t) #f)))
|
||||||
left-cols-list)))
|
left-cols-list)))
|
||||||
|
|
||||||
@ -1108,48 +1153,42 @@ tags within description, notes or memo. ")
|
|||||||
|
|
||||||
(define default-calculated-cells
|
(define default-calculated-cells
|
||||||
(letrec
|
(letrec
|
||||||
((damount (lambda (s) (if (gnc:split-voided? s)
|
((split-amount (lambda (s) (if (gnc:split-voided? s)
|
||||||
(xaccSplitVoidFormerAmount s)
|
(xaccSplitVoidFormerAmount s)
|
||||||
(xaccSplitGetAmount s))))
|
(xaccSplitGetAmount s))))
|
||||||
(trans-date (lambda (s) (xaccTransGetDate (xaccSplitGetParent s))))
|
(split-currency (lambda (s) (xaccAccountGetCommodity (xaccSplitGetAccount s))))
|
||||||
(currency (lambda (s) (xaccAccountGetCommodity (xaccSplitGetAccount s))))
|
(row-currency (lambda (s) (if (column-uses? 'common-currency)
|
||||||
(report-currency (lambda (s) (if (column-uses? 'common-currency)
|
(opt-val gnc:pagename-general optname-currency)
|
||||||
(opt-val gnc:pagename-general optname-currency)
|
(split-currency s))))
|
||||||
(currency s))))
|
|
||||||
(friendly-debit (lambda (a) (gnc:get-debit-string (xaccAccountGetType a))))
|
(friendly-debit (lambda (a) (gnc:get-debit-string (xaccAccountGetType a))))
|
||||||
(friendly-credit (lambda (a) (gnc:get-credit-string (xaccAccountGetType a))))
|
(friendly-credit (lambda (a) (gnc:get-credit-string (xaccAccountGetType a))))
|
||||||
(header-commodity (lambda (str)
|
(header-commodity (lambda (str)
|
||||||
(string-append
|
(string-append
|
||||||
str
|
str
|
||||||
(if (column-uses? 'common-currency)
|
(if (column-uses? 'common-currency)
|
||||||
(string-append
|
(format #f " (~a)"
|
||||||
"<br />"
|
(gnc-commodity-get-mnemonic
|
||||||
(gnc-commodity-get-mnemonic
|
(opt-val gnc:pagename-general optname-currency)))
|
||||||
(opt-val gnc:pagename-general optname-currency)))
|
|
||||||
""))))
|
""))))
|
||||||
(convert (lambda (s num)
|
;; For conversion to row-currency. Use midday as the
|
||||||
(gnc:exchange-by-pricedb-nearest
|
;; transaction time so it matches a price on the same day.
|
||||||
(gnc:make-gnc-monetary (currency s) num)
|
;; Otherwise it uses midnight which will likely match a
|
||||||
(report-currency s)
|
;; price on the previous day
|
||||||
;; Use midday as the transaction time so it matches a price
|
(converted-amount (lambda (s) (gnc:exchange-by-pricedb-nearest
|
||||||
;; on the same day. Otherwise it uses midnight which will
|
(gnc:make-gnc-monetary (split-currency s) (split-amount s))
|
||||||
;; likely match a price on the previous day
|
(row-currency s)
|
||||||
(time64CanonicalDayTime (trans-date s)))))
|
(time64CanonicalDayTime
|
||||||
(split-value (lambda (s) (convert s (damount s)))) ; used for correct debit/credit
|
(xaccTransGetDate (xaccSplitGetParent s))))))
|
||||||
(amount (lambda (s) (split-value s)))
|
(converted-debit-amount (lambda (s) (and (positive? (split-amount s))
|
||||||
(debit-amount (lambda (s) (and (positive? (gnc:gnc-monetary-amount (split-value s)))
|
(converted-amount s))))
|
||||||
(split-value s))))
|
(converted-credit-amount (lambda (s) (and (not (positive? (split-amount s)))
|
||||||
(credit-amount (lambda (s) (if (positive? (gnc:gnc-monetary-amount (split-value s)))
|
(gnc:monetary-neg (converted-amount s)))))
|
||||||
#f
|
(original-amount (lambda (s) (gnc:make-gnc-monetary (split-currency s) (split-amount s))))
|
||||||
(gnc:monetary-neg (split-value s)))))
|
(original-debit-amount (lambda (s) (and (positive? (split-amount s))
|
||||||
(original-amount (lambda (s) (gnc:make-gnc-monetary (currency s) (damount s))))
|
(original-amount s))))
|
||||||
(original-debit-amount (lambda (s) (if (positive? (damount s))
|
(original-credit-amount (lambda (s) (and (not (positive? (split-amount s)))
|
||||||
(original-amount s)
|
(gnc:monetary-neg (original-amount s)))))
|
||||||
#f)))
|
(running-balance (lambda (s) (gnc:make-gnc-monetary (split-currency s) (xaccSplitGetBalance s)))))
|
||||||
(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)))))
|
|
||||||
(append
|
(append
|
||||||
;; each column will be a vector
|
;; each column will be a vector
|
||||||
;; (vector heading
|
;; (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)
|
;; 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
|
;; ;; 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
|
;; friendly-heading-fn ;; (friendly-heading-fn account) to retrieve friendly name for account debit/credit
|
||||||
|
|
||||||
(if (column-uses? 'amount-single)
|
(if (column-uses? 'amount-single)
|
||||||
(list (vector (header-commodity (_ "Amount"))
|
(list (vector (header-commodity (_ "Amount"))
|
||||||
amount #t #t #f
|
converted-amount #t #t #f
|
||||||
(lambda (a) "")))
|
(lambda (a) "")))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
(if (column-uses? 'amount-double)
|
(if (column-uses? 'amount-double)
|
||||||
(list (vector (header-commodity (_ "Debit"))
|
(list (vector (header-commodity (_ "Debit"))
|
||||||
debit-amount #f #t #t
|
converted-debit-amount #f #t #t
|
||||||
friendly-debit)
|
friendly-debit)
|
||||||
(vector (header-commodity (_ "Credit"))
|
(vector (header-commodity (_ "Credit"))
|
||||||
credit-amount #f #t #f
|
converted-credit-amount #f #t #f
|
||||||
friendly-credit))
|
friendly-credit))
|
||||||
'())
|
'())
|
||||||
|
|
||||||
@ -1256,11 +1297,10 @@ tags within description, notes or memo. ")
|
|||||||
1 (+ right-indent width-left-columns) data)))
|
1 (+ right-indent width-left-columns) data)))
|
||||||
(for-each (lambda (cell)
|
(for-each (lambda (cell)
|
||||||
(addto! row-contents
|
(addto! row-contents
|
||||||
(gnc:make-html-table-cell
|
(gnc:make-html-text
|
||||||
"<b>"
|
(gnc:html-markup-b
|
||||||
((vector-ref cell 5)
|
((vector-ref cell 5)
|
||||||
((keylist-get-info sortkey-list sortkey 'renderer-fn) split))
|
((keylist-get-info sortkey-list sortkey 'renderer-fn) split))))))
|
||||||
"</b>")))
|
|
||||||
calculated-cells))
|
calculated-cells))
|
||||||
(addto! row-contents (gnc:make-html-table-cell/size
|
(addto! row-contents (gnc:make-html-table-cell/size
|
||||||
1 (+ right-indent width-left-columns width-right-columns) data)))
|
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))
|
(render-date date-subtotal-key split))
|
||||||
((member sortkey ACCOUNT-SORTING-TYPES)
|
((member sortkey ACCOUNT-SORTING-TYPES)
|
||||||
(render-account sortkey split anchor?))
|
(render-account sortkey split anchor?))
|
||||||
((eq? sortkey 'reconciled-status)
|
(else
|
||||||
(render-generic sortkey split)))))
|
(render-generic sortkey split)))))
|
||||||
|
|
||||||
(define (render-grand-total)
|
(define (render-grand-total)
|
||||||
@ -1768,51 +1808,38 @@ tags within description, notes or memo. ")
|
|||||||
(secondary-order (opt-val pagename-sorting optname-sec-sortorder))
|
(secondary-order (opt-val pagename-sorting optname-sec-sortorder))
|
||||||
(secondary-date-subtotal (opt-val pagename-sorting optname-sec-date-subtotal))
|
(secondary-date-subtotal (opt-val pagename-sorting optname-sec-date-subtotal))
|
||||||
(void-status (opt-val pagename-filter optname-void-transactions))
|
(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 '())
|
(splits '())
|
||||||
(custom-sort? (or (and (member primary-key DATE-SORTING-TYPES) ; this will remain
|
(custom-sort? (or (and (member primary-key DATE-SORTING-TYPES) ; this will remain
|
||||||
(not (eq? primary-date-subtotal 'none))) ; until qof-query
|
(not (eq? primary-date-subtotal 'none))) ; until qof-query
|
||||||
(and (member secondary-key DATE-SORTING-TYPES) ; is upgraded
|
(and (member secondary-key DATE-SORTING-TYPES) ; is upgraded
|
||||||
(not (eq? secondary-date-subtotal 'none)))
|
(not (eq? secondary-date-subtotal 'none)))
|
||||||
(or (member primary-key CUSTOM-SORTING)
|
(or (CUSTOM-SORTING? primary-key)
|
||||||
(member secondary-key CUSTOM-SORTING))))
|
(CUSTOM-SORTING? secondary-key))))
|
||||||
(infobox-display (opt-val gnc:pagename-general optname-infobox-display))
|
(infobox-display (opt-val gnc:pagename-general optname-infobox-display))
|
||||||
(query (qof-query-create-for-splits)))
|
(query (qof-query-create-for-splits)))
|
||||||
|
|
||||||
(define (generic-less? X Y key date-subtotal ascend?)
|
(define (generic-less? split-X split-Y sortkey date-subtotal-key ascend?)
|
||||||
(define comparator-function
|
;; compare splits X and Y, whereby
|
||||||
(if (member key DATE-SORTING-TYPES)
|
;; sortkey and date-subtotal-key specify the options used
|
||||||
(let ((date (lambda (s)
|
;; ascend? specifies whether ascending or descending
|
||||||
(case key
|
(let* ((comparator-function
|
||||||
((date) (xaccTransGetDate (xaccSplitGetParent s)))
|
(if (memq sortkey DATE-SORTING-TYPES)
|
||||||
((reconciled-date) (xaccSplitGetDateReconciled s))))))
|
(let ((date (keylist-get-info sortkey-list sortkey 'split-sortvalue))
|
||||||
(case date-subtotal
|
(date-comparator (keylist-get-info date-subtotal-list date-subtotal-key 'date-sortvalue)))
|
||||||
((yearly) (lambda (s) (time64-year (date s))))
|
(lambda (s)
|
||||||
((monthly) (lambda (s) (time64-month (date s))))
|
(and date-comparator
|
||||||
((quarterly) (lambda (s) (time64-quarter (date s))))
|
(date-comparator (date s)))))
|
||||||
((weekly) (lambda (s) (time64-week (date s))))
|
(or (keylist-get-info sortkey-list sortkey 'split-sortvalue)
|
||||||
((daily) (lambda (s) (time64-day (date s))))
|
(lambda (s) #f))))
|
||||||
((none) (lambda (s) (date s)))))
|
(value-of-X (comparator-function split-X))
|
||||||
(case key
|
(value-of-Y (comparator-function split-Y))
|
||||||
((account-name) (lambda (s) (gnc-account-get-full-name (xaccSplitGetAccount s))))
|
(op (if (string? value-of-X)
|
||||||
((account-code) (lambda (s) (xaccAccountGetCode (xaccSplitGetAccount s))))
|
(if ascend? string<? string>?)
|
||||||
((corresponding-acc-name) (lambda (s) (xaccSplitGetCorrAccountFullName s)))
|
(if ascend? < >))))
|
||||||
((corresponding-acc-code) (lambda (s) (xaccSplitGetCorrAccountCode s)))
|
(and value-of-X (op value-of-X value-of-Y))))
|
||||||
((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 (primary-comparator? X Y)
|
(define (primary-comparator? X Y)
|
||||||
(generic-less? X Y primary-key
|
(generic-less? X Y primary-key
|
||||||
@ -1828,7 +1855,6 @@ tags within description, notes or memo. ")
|
|||||||
(define (date-comparator? X Y)
|
(define (date-comparator? X Y)
|
||||||
(generic-less? X Y 'date 'none #t))
|
(generic-less? X Y 'date 'none #t))
|
||||||
|
|
||||||
|
|
||||||
(if (or (or (null? c_account_1) (and-map not c_account_1))
|
(if (or (or (null? c_account_1) (and-map not c_account_1))
|
||||||
(eq? account-matcher-regexp 'invalid-regex)
|
(eq? account-matcher-regexp 'invalid-regex)
|
||||||
(eq? transaction-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))
|
(if (memq infobox-display '(always no-match))
|
||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:render-options-changed options))))
|
(gnc:html-render-options-changed options))))
|
||||||
|
|
||||||
(begin
|
(begin
|
||||||
|
|
||||||
@ -1864,6 +1890,8 @@ tags within description, notes or memo. ")
|
|||||||
(else #f))
|
(else #f))
|
||||||
(if reconcile-status-filter
|
(if reconcile-status-filter
|
||||||
(xaccQueryAddClearedMatch query reconcile-status-filter QOF-QUERY-AND))
|
(xaccQueryAddClearedMatch query reconcile-status-filter QOF-QUERY-AND))
|
||||||
|
(if (boolean? closing-match)
|
||||||
|
(xaccQueryAddClosingTransMatch query closing-match QOF-QUERY-AND))
|
||||||
(if (not custom-sort?)
|
(if (not custom-sort?)
|
||||||
(begin
|
(begin
|
||||||
(qof-query-set-sort-order query
|
(qof-query-set-sort-order query
|
||||||
@ -1925,7 +1953,7 @@ tags within description, notes or memo. ")
|
|||||||
(if (memq infobox-display '(always no-match))
|
(if (memq infobox-display '(always no-match))
|
||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:render-options-changed options))))
|
(gnc:html-render-options-changed options))))
|
||||||
|
|
||||||
(let-values (((table grid) (make-split-table splits options custom-calculated-cells)))
|
(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)
|
(if (eq? infobox-display 'always)
|
||||||
(gnc:html-document-add-object!
|
(gnc:html-document-add-object!
|
||||||
document
|
document
|
||||||
(gnc:render-options-changed options)))
|
(gnc:html-render-options-changed options)))
|
||||||
|
|
||||||
(gnc:html-document-add-object! document table)))))
|
(gnc:html-document-add-object! document table)))))
|
||||||
|
|
||||||
|
|||||||
@ -101,7 +101,6 @@
|
|||||||
(export gnc:make-radiobutton-option)
|
(export gnc:make-radiobutton-option)
|
||||||
(export gnc:make-radiobutton-callback-option)
|
(export gnc:make-radiobutton-callback-option)
|
||||||
(export gnc:make-list-option)
|
(export gnc:make-list-option)
|
||||||
(export gnc:render-options-changed)
|
|
||||||
(export gnc:options-make-end-date!)
|
(export gnc:options-make-end-date!)
|
||||||
(export gnc:options-make-date-interval!)
|
(export gnc:options-make-date-interval!)
|
||||||
(export gnc:option-make-internal!)
|
(export gnc:option-make-internal!)
|
||||||
|
|||||||
@ -2001,64 +2001,6 @@
|
|||||||
(gnc:option-value src-option)))))
|
(gnc:option-value src-option)))))
|
||||||
src-options)))
|
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)
|
(define (gnc:send-options db_handle options)
|
||||||
(gnc:options-for-each
|
(gnc:options-for-each
|
||||||
(lambda (option)
|
(lambda (option)
|
||||||
|
|||||||
@ -43,6 +43,9 @@ set(GUILE_DEPENDS
|
|||||||
set(test_app_utils_scheme_SOURCES
|
set(test_app_utils_scheme_SOURCES
|
||||||
test-c-interface.scm
|
test-c-interface.scm
|
||||||
test-load-app-utils-module.scm
|
test-load-app-utils-module.scm
|
||||||
|
)
|
||||||
|
|
||||||
|
set (test_app_utils_scheme_SRFI64_SOURCES
|
||||||
test-date-utilities.scm
|
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}")
|
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:
|
# 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)
|
gnc_add_test_with_guile(test-app-utils "${test_app_utils_SOURCES}" APP_UTILS_TEST_INCLUDE_DIRS APP_UTILS_TEST_LIBS)
|
||||||
|
|
||||||
|
|||||||
@ -1,10 +1,15 @@
|
|||||||
(use-modules (gnucash gnc-module))
|
(use-modules (gnucash gnc-module))
|
||||||
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
||||||
(use-modules (gnucash engine test test-extras))
|
(use-modules (gnucash engine test test-extras))
|
||||||
|
(use-modules (srfi srfi-64))
|
||||||
|
(use-modules (gnucash engine test srfi64-extras))
|
||||||
|
|
||||||
(define (run-test)
|
(define (run-test)
|
||||||
(and (test test-weeknum-calculator)
|
(test-runner-factory gnc:test-runner)
|
||||||
(test test-date-get-quarter-string)))
|
(test-begin "test-date-utilities.scm")
|
||||||
|
(test-weeknum-calculator)
|
||||||
|
(test-date-get-quarter-string)
|
||||||
|
(test-end "test-date-utilities.scm"))
|
||||||
|
|
||||||
(define (create-datevec l)
|
(define (create-datevec l)
|
||||||
(let ((now (gnc-localtime (current-time))))
|
(let ((now (gnc-localtime (current-time))))
|
||||||
@ -12,8 +17,8 @@
|
|||||||
(set-tm:min now (list-ref l 4))
|
(set-tm:min now (list-ref l 4))
|
||||||
(set-tm:hour now (list-ref l 3))
|
(set-tm:hour now (list-ref l 3))
|
||||||
(set-tm:mday now (list-ref l 2))
|
(set-tm:mday now (list-ref l 2))
|
||||||
(set-tm:mon now (list-ref l 1))
|
(set-tm:mon now (1- (list-ref l 1)))
|
||||||
(set-tm:year now (list-ref l 0))
|
(set-tm:year now (- (list-ref l 0) 1900))
|
||||||
(set-tm:isdst now -1)
|
(set-tm:isdst now -1)
|
||||||
now))
|
now))
|
||||||
|
|
||||||
@ -28,28 +33,39 @@
|
|||||||
(gnc:date-to-week (create-time64 d2)))))
|
(gnc:date-to-week (create-time64 d2)))))
|
||||||
|
|
||||||
(define (test-weeknum-calculator)
|
(define (test-weeknum-calculator)
|
||||||
(and (weeknums-equal? (cons '(1970 1 1 0 0 0)
|
(test-assert "weeknums 1/1/70early = 1/1/70late"
|
||||||
'(1970 1 1 23 59 59)))
|
(weeknums-equal? (cons '(1970 1 1 0 0 0)
|
||||||
(weeknums-equal? (cons '(1969 12 31 0 0 0)
|
'(1970 1 1 23 59 59))))
|
||||||
'(1969 12 31 23 59 59)))
|
|
||||||
(weeknums-equal? (cons '(1969 12 31 0 0 0)
|
(test-assert "weeknums 31/12/69early = 31/12/69late"
|
||||||
'(1970 1 1 0 0 1)))
|
(weeknums-equal? (cons '(1969 12 31 0 0 0)
|
||||||
(weeknums-equal? (cons '(2001 1 1 0 0 0)
|
'(1969 12 31 23 59 59))))
|
||||||
'(2001 1 1 23 59 59)))
|
|
||||||
(not (weeknums-equal? (cons '(1970 1 1 0 0 0)
|
(test-assert "weeknums 31/12/69 = 1/1/70"
|
||||||
'(1970 1 10 0 0 1))))
|
(weeknums-equal? (cons '(1969 12 31 0 0 0)
|
||||||
(not (weeknums-equal? (cons '(1969 12 28 0 0 1)
|
'(1970 1 1 0 0 1))))
|
||||||
'(1970 1 5 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)
|
(define (test-date-get-quarter-string)
|
||||||
(and (or (string=? "Q1" (gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))
|
(test-equal "14/02/2001 = Q1"
|
||||||
(begin (format #t "Expected Q1, got ~a~%" (gnc:date-get-quarter-string (creaete-datevec '(2001 2 14 11 42 23))))
|
"Q1"
|
||||||
#f))
|
(gnc:date-get-quarter-string (create-datevec '(2001 2 14 11 42 23))))
|
||||||
(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))))
|
(test-equal "23/04/2013 = Q2"
|
||||||
#f))
|
"Q2"
|
||||||
(or (string=? "Q3" (gnc:date-get-quarter-string (create-datevec '(1997 9 11 08 14 21))))
|
(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)))
|
(test-equal "11/09/1997 = Q3"
|
||||||
|
"Q3"
|
||||||
|
(gnc:date-get-quarter-string (create-datevec '(1997 9 11 08 14 21)))))
|
||||||
|
|||||||
@ -233,6 +233,20 @@ gnc_add_scheme_targets(scm-test-engine-extras
|
|||||||
FALSE
|
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
|
gnc_add_scheme_targets(scm-test-engine
|
||||||
"${engine_test_SCHEME}"
|
"${engine_test_SCHEME}"
|
||||||
""
|
""
|
||||||
@ -311,4 +325,5 @@ set(test_engine_EXTRA_DIST
|
|||||||
)
|
)
|
||||||
|
|
||||||
set_dist_list(test_engine_DIST CMakeLists.txt
|
set_dist_list(test_engine_DIST CMakeLists.txt
|
||||||
|
${srfi64_extras_SCHEME_DIST}
|
||||||
${test_engine_SOURCES_DIST} ${test_engine_SCHEME_DIST} ${test_engine_EXTRA_DIST})
|
${test_engine_SOURCES_DIST} ${test_engine_SCHEME_DIST} ${test_engine_EXTRA_DIST})
|
||||||
|
|||||||
49
libgnucash/engine/test/srfi64-extras.scm
Normal file
49
libgnucash/engine/test/srfi64-extras.scm
Normal 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))
|
||||||
@ -27,15 +27,7 @@
|
|||||||
(use-modules (sw_app_utils))
|
(use-modules (sw_app_utils))
|
||||||
(use-modules (sw_engine))
|
(use-modules (sw_engine))
|
||||||
|
|
||||||
(export logging-and)
|
|
||||||
(export test)
|
(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-account)
|
||||||
(export with-transaction)
|
(export with-transaction)
|
||||||
@ -62,15 +54,6 @@
|
|||||||
;; Random test related syntax and the like
|
;; 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)
|
(define (test the-test)
|
||||||
(format #t "(Running ~a " the-test)
|
(format #t "(Running ~a " the-test)
|
||||||
(let ((result (the-test)))
|
(let ((result (the-test)))
|
||||||
@ -112,8 +95,7 @@
|
|||||||
|
|
||||||
(define (create-test-env)
|
(define (create-test-env)
|
||||||
(list (cons 'random (seed->random-state (random 1000)))
|
(list (cons 'random (seed->random-state (random 1000)))
|
||||||
(cons 'counter (make-counter))
|
(cons 'counter (make-counter))))
|
||||||
(cons 'sink (make-test-sink))))
|
|
||||||
|
|
||||||
(define (env-random-amount env n)
|
(define (env-random-amount env n)
|
||||||
(/ (env-random env n) 1))
|
(/ (env-random env n) 1))
|
||||||
@ -130,9 +112,6 @@
|
|||||||
(define (env-select-price-source env)
|
(define (env-select-price-source env)
|
||||||
'pricedb-nearest)
|
'pricedb-nearest)
|
||||||
|
|
||||||
(define (env-test-sink env)
|
|
||||||
(assoc-ref env 'sink))
|
|
||||||
|
|
||||||
(define (env-any-date env) (gnc:get-today))
|
(define (env-any-date env) (gnc:get-today))
|
||||||
|
|
||||||
(define (env-create-transaction env date credit debit aaa)
|
(define (env-create-transaction env date credit debit aaa)
|
||||||
@ -324,69 +303,5 @@
|
|||||||
(list "Other")
|
(list "Other")
|
||||||
(list "Expenses"
|
(list "Expenses"
|
||||||
(list (cons 'type ACCT-TYPE-EXPENSE))))))
|
(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))
|
|
||||||
|
|
||||||
|
|||||||
@ -26,10 +26,7 @@
|
|||||||
(use-modules (sw_engine))
|
(use-modules (sw_engine))
|
||||||
|
|
||||||
(define (run-test)
|
(define (run-test)
|
||||||
(and (logging-and #t)
|
(test-create-account-structure))
|
||||||
(logging-and)
|
|
||||||
(not (logging-and #t #f))
|
|
||||||
(test-create-account-structure)))
|
|
||||||
|
|
||||||
(define (test-create-account-structure)
|
(define (test-create-account-structure)
|
||||||
(let ((env (create-test-env)))
|
(let ((env (create-test-env)))
|
||||||
|
|||||||
@ -42,6 +42,7 @@
|
|||||||
(export gnc:error)
|
(export gnc:error)
|
||||||
(export gnc:msg)
|
(export gnc:msg)
|
||||||
(export gnc:debug)
|
(export gnc:debug)
|
||||||
|
(export addto!)
|
||||||
|
|
||||||
;; Do this stuff very early -- but other than that, don't add any
|
;; 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.
|
;; executable code until the end of the file if you can help it.
|
||||||
@ -71,6 +72,10 @@
|
|||||||
(define (gnc:debug . items)
|
(define (gnc:debug . items)
|
||||||
(gnc-scm-log-debug (strify items)))
|
(gnc-scm-log-debug (strify items)))
|
||||||
|
|
||||||
|
(define-syntax addto!
|
||||||
|
(syntax-rules ()
|
||||||
|
((addto! alist element)
|
||||||
|
(set! alist (cons element alist)))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; gnc:substring-replace
|
;; gnc:substring-replace
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user