gnucash master: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Wed May 13 01:57:01 EDT 2020
Updated via https://github.com/Gnucash/gnucash/commit/a874483b (commit)
via https://github.com/Gnucash/gnucash/commit/f8bad131 (commit)
via https://github.com/Gnucash/gnucash/commit/710b559c (commit)
via https://github.com/Gnucash/gnucash/commit/f9fce766 (commit)
via https://github.com/Gnucash/gnucash/commit/7557c5b5 (commit)
via https://github.com/Gnucash/gnucash/commit/8b3841b4 (commit)
via https://github.com/Gnucash/gnucash/commit/d8c21c46 (commit)
via https://github.com/Gnucash/gnucash/commit/61afe53f (commit)
via https://github.com/Gnucash/gnucash/commit/9020c967 (commit)
via https://github.com/Gnucash/gnucash/commit/3d25a40d (commit)
via https://github.com/Gnucash/gnucash/commit/182d4d9d (commit)
from https://github.com/Gnucash/gnucash/commit/1510f349 (commit)
commit a874483b70673225732febb8512902ca7ced3f9b
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 13:55:59 2020 +0800
[register] show number columns right-aligned
diff --git a/gnucash/report/reports/standard/register.scm b/gnucash/report/reports/standard/register.scm
index 52a61f34f..14715714f 100644
--- a/gnucash/report/reports/standard/register.scm
+++ b/gnucash/report/reports/standard/register.scm
@@ -229,7 +229,7 @@
(if (shares-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup
- "text-cell"
+ "number-cell"
(if split-info?
(xaccSplitGetAmount split)
" "))))
@@ -243,7 +243,7 @@
(if (price-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup
- "text-cell"
+ "number-cell"
(if split-info?
(gnc:default-price-renderer
(gnc-account-get-currency-or-parent
commit f8bad131a5376baa6cfb401b252245b1bc545901
Merge: 1510f3492 710b559cc
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 13:20:09 2020 +0800
Merge branch 'maint-797743' #720 price renderers
diff --cc gnucash/report/html-style-info.scm
index b4c4a5366,000000000..8c6da4aff
mode 100644,000000..100644
--- a/gnucash/report/html-style-info.scm
+++ b/gnucash/report/html-style-info.scm
@@@ -1,317 -1,0 +1,325 @@@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; html-style-info.scm : generate HTML programmatically, with support
+;; for simple style elements.
+;; Copyright 2000 Bill Gribble <grib at gnumatic.com>
+;;
+;; 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 at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (ice-9 match))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; <html-markup-style-info> class
+;; this is what's stored for tags in the style hash tables.
+;; literal data types have their own style record type,
+;; <html-data-style-info>
+;;
+;; constructor takes pairs of args :
+;; (gnc:make-html-markup-style-info field1 value1 field2 value2 ...)
+;;
+;; values for field (should be passed as symbols):
+;; tag : string for start tag
+;; attributes : hash of attribute to value (unsafe!)
+;; attribute : single attribute-value pair in a list
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define <html-markup-style-info>
+ (make-record-type "<html-markup-style-info>"
+ '(tag
+ attributes
+ inheritable?)))
+
+(define gnc:html-markup-style-info?
+ (record-predicate <html-markup-style-info>))
+
+(define gnc:make-html-markup-style-info-internal
+ (record-constructor <html-markup-style-info>))
+
+(define (gnc:make-html-markup-style-info . rest)
+ (let ((retval (gnc:make-html-markup-style-info-internal
+ #f (make-hash-table) #t)))
+ (apply gnc:html-markup-style-info-set! retval rest)
+ retval))
+
+(define (gnc:html-markup-style-info-set! style . rest)
+ (let loop ((arglist rest))
+ (match arglist
+ (('attribute (key . val) . rest)
+ (gnc:html-markup-style-info-set-attribute!
+ style key (and (pair? val) (car val)))
+ (loop rest))
+
+ ((field value . rest)
+ ((record-modifier <html-markup-style-info> field) style value)
+ (loop rest))
+
+ (else style))))
+
+(define gnc:html-markup-style-info-tag
+ (record-accessor <html-markup-style-info> 'tag))
+
+(define gnc:html-markup-style-info-set-tag!
+ (record-modifier <html-markup-style-info> 'tag))
+
+(define gnc:html-markup-style-info-attributes
+ (record-accessor <html-markup-style-info> 'attributes))
+
+(define gnc:html-markup-style-info-set-attributes!
+ (record-modifier <html-markup-style-info> 'attributes))
+
+(define gnc:html-markup-style-info-inheritable?
+ (record-accessor <html-markup-style-info> 'inheritable?))
+
+(define gnc:html-markup-style-info-set-inheritable?!
+ (record-modifier <html-markup-style-info> 'inheritable?))
+
+(define (gnc:html-markup-style-info-set-attribute! info attr val)
+ (hash-set! (gnc:html-markup-style-info-attributes info) attr val))
+
+(define (gnc:html-markup-style-info-merge s1 s2)
+ (cond
+ ((not (gnc:html-markup-style-info? s1)) s2)
+ ((not (gnc:html-markup-style-info? s2)) s1)
+ (else
+ (gnc:make-html-markup-style-info-internal
+ ;; tag
+ (or (gnc:html-markup-style-info-tag s1)
+ (gnc:html-markup-style-info-tag s2))
+ ;; attributes: if the child is overriding the
+ ;; parent tag, don't initialize the attribute table
+ ;; to the parent's attributes. Otherwise, load
+ ;; parent attrs then load child attrs over them.
+ (let ((ht (make-hash-table)))
+ (unless (gnc:html-markup-style-info-tag s1)
+ (hash-for-each
+ (lambda (k v)
+ (hash-set! ht k v))
+ (gnc:html-markup-style-info-attributes s2)))
+ (hash-for-each
+ (lambda (k v) (hash-set! ht k v))
+ (gnc:html-markup-style-info-attributes s1))
+ ht)
+ ;; inheritable (get this always from child)
+ (gnc:html-markup-style-info-inheritable? s1)))))
+
+(define (gnc:html-style-info-merge s1 s2)
+ (cond
+ ((or (gnc:html-markup-style-info? s1) (gnc:html-markup-style-info? s2))
+ (gnc:html-markup-style-info-merge s1 s2))
+
+ ((or (gnc:html-data-style-info? s1) (gnc:html-data-style-info? s2))
+ (gnc:html-data-style-info-merge s1 s2))
+
+ (else #f)))
+
+(define (gnc:html-data-style-info-merge s1 s2)
+ (if (gnc:html-data-style-info? s1) s1 s2))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; <html-data-style-info> class
+;;
+;; literal data is rendered using the html-data-style for that type.
+;; ATM the rendering style is defined using a thunk to do the
+;; rendering and some data to pass in addition to the object to be
+;; rendered.
+;;
+;; the renderer is a function of two arguments. The first arg is the
+;; data to be rendered and the second is the 'data' specified in the
+;; style. The return should be an HTML string.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define <html-data-style-info>
+ (make-record-type "<html-data-style-info>"
+ '(renderer data inheritable?)))
+
+(define gnc:html-data-style-info?
+ (record-predicate <html-data-style-info>))
+
+(define gnc:make-html-data-style-info-internal
+ (record-constructor <html-data-style-info>))
+
+(define (gnc:make-html-data-style-info renderer data)
+ (gnc:make-html-data-style-info-internal renderer data #t))
+
+(define gnc:html-data-style-info?
+ (record-predicate <html-data-style-info>))
+
+(define gnc:html-data-style-info-renderer
+ (record-accessor <html-data-style-info> 'renderer))
+
+(define gnc:html-data-style-info-set-renderer!
+ (record-modifier <html-data-style-info> 'renderer))
+
+(define gnc:html-data-style-info-data
+ (record-accessor <html-data-style-info> 'data))
+
+(define gnc:html-data-style-info-set-data!
+ (record-modifier <html-data-style-info> 'data))
+
+(define gnc:html-data-style-info-inheritable?
+ (record-accessor <html-data-style-info> 'inheritable?))
+
+(define gnc:html-data-style-info-set-inheritable?!
+ (record-modifier <html-data-style-info> 'inheritable?))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; default renderers for some data types.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (gnc:default-html-string-renderer datum params)
+ datum)
+
+(define (gnc:default-html-gnc-numeric-renderer datum params)
+ (xaccPrintAmount datum (gnc-default-print-info #f)))
+
++;; renders a price to target currency
++(define (gnc:default-price-renderer currency amount)
++ (xaccPrintAmount amount (gnc-price-print-info currency #t)))
++
+(define (gnc:default-html-gnc-monetary-renderer datum params)
- (xaccPrintAmount
- (gnc:gnc-monetary-amount datum)
- (gnc-commodity-print-info (gnc:gnc-monetary-commodity datum) #t)))
++ (let* ((comm (gnc:gnc-monetary-commodity datum))
++ (scu (gnc-commodity-get-fraction comm))
++ (amount (gnc:gnc-monetary-amount datum))
++ (amt-display (if (exact? amount)
++ (gnc-numeric-convert amount scu GNC-HOW-RND-ROUND)
++ amount)))
++ (xaccPrintAmount amt-display (gnc-commodity-print-info comm #t))))
+
+(define (gnc:default-html-number-renderer datum params)
+ (xaccPrintAmount
+ (double-to-gnc-numeric datum 100 GNC-RND-ROUND)
+ (gnc-default-print-info #f)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; <html-style-table> class
+;;
+;; this used to just be bare hash tables stuck in the <html-object>
+;; but since we now support caching and compilation I think it
+;; deserves a record structure.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define <html-style-table>
+ (make-record-type "<html-style-table>"
+ '(primary compiled inheritable)))
+
+(define gnc:html-style-table?
+ (record-predicate <html-style-table>))
+
+(define gnc:make-html-style-table-internal
+ (record-constructor <html-style-table>))
+
+(define (gnc:make-html-style-table)
+ (gnc:make-html-style-table-internal (make-hash-table) #f #f))
+
+(define gnc:html-style-table-primary
+ (record-accessor <html-style-table> 'primary))
+
+(define gnc:html-style-table-compiled
+ (record-accessor <html-style-table> 'compiled))
+
+(define gnc:html-style-table-set-compiled!
+ (record-modifier <html-style-table> 'compiled))
+
+(define gnc:html-style-table-inheritable
+ (record-accessor <html-style-table> 'inheritable))
+
+(define gnc:html-style-table-set-inheritable!
+ (record-modifier <html-style-table> 'inheritable))
+
+(define (gnc:html-style-table-compiled? table)
+ (gnc:html-style-table-compiled table))
+
+(define (gnc:html-style-table-compile table antecedents)
+ ;; merge a key-value pair from an antecedent into the
+ ;; compiled table. Only add values to the inheritable table
+ ;; that are inheritable.
+ (define (key-merger key value ign)
+ (let* ((compiled (gnc:html-style-table-compiled table))
+ (inheritable (gnc:html-style-table-inheritable table))
+ (old-val (hash-ref compiled key))
+ (new-val (gnc:html-style-info-merge old-val value)))
+ (hash-set! compiled key new-val)
+ (if (and (gnc:html-markup-style-info? value)
+ (gnc:html-markup-style-info-inheritable? value))
+ (hash-set! inheritable key new-val))
+ (if (and (gnc:html-data-style-info? value)
+ (gnc:html-data-style-info-inheritable? value))
+ (hash-set! inheritable key new-val))))
+
+ ;; walk up the list of antecedents merging in style info
+ (define (compile-worker table-list)
+ (let ((next (car table-list)))
+ (if (gnc:html-style-table-compiled? next)
+ (begin
+ (hash-fold key-merger #f (gnc:html-style-table-compiled next))
+ #t)
+ (begin
+ (hash-fold key-merger #f (gnc:html-style-table-primary next))
+ (if (not (null? (cdr table-list)))
+ (compile-worker (cdr table-list))
+ #t)))))
+ ;; make the compiled hash table
+ (gnc:html-style-table-set-compiled! table (make-hash-table))
+ (gnc:html-style-table-set-inheritable! table (make-hash-table))
+
+ ;; merge the contents of the primary hash into the compiled table
+ (hash-fold key-merger #f (gnc:html-style-table-primary table))
+
+ ;; now merge in the antecedents
+ (if (not (null? antecedents))
+ (compile-worker antecedents)))
+
+
+(define (gnc:html-style-table-uncompile table)
+ (gnc:html-style-table-set-compiled! table #f)
+ (gnc:html-style-table-set-inheritable! table #f))
+
+(define (gnc:html-style-table-fetch table antecedents markup)
+ (define (get-inheritable-style ht)
+ (let ((s (hash-ref ht markup)))
+ (if (or (and (gnc:html-markup-style-info? s)
+ (gnc:html-markup-style-info-inheritable? s))
+ (and (gnc:html-data-style-info? s)
+ (gnc:html-data-style-info-inheritable? s)))
+ s #f)))
+
+ (define (fetch-worker style antecedents)
+ (cond
+ ((null? antecedents) style)
+ ((not (car antecedents)) (fetch-worker style (cdr antecedents)))
+ ((gnc:html-style-table-compiled? (car antecedents))
+ (gnc:html-style-info-merge
+ style (hash-ref (gnc:html-style-table-inheritable (car antecedents)) markup)))
+ (else
+ (fetch-worker
+ (gnc:html-style-info-merge
+ style (get-inheritable-style
+ (gnc:html-style-table-primary (car antecedents))))
+ (cdr antecedents)))))
+
+ (if (and table (gnc:html-style-table-compiled? table))
+ (hash-ref (gnc:html-style-table-compiled table) markup)
+ (fetch-worker
+ (and table (hash-ref (gnc:html-style-table-primary table) markup))
+ antecedents)))
+
+(define (gnc:html-style-table-set! table markup style-info)
+ (hash-set! (gnc:html-style-table-primary table) markup style-info))
diff --cc gnucash/report/html-utilities.scm
index 9dfd59285,000000000..de6bf81a8
mode 100644,000000..100644
--- a/gnucash/report/html-utilities.scm
+++ b/gnucash/report/html-utilities.scm
@@@ -1,342 -1,0 +1,345 @@@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; html-utilities.scm: Useful functions when using the HTML generator.
+;;
+;; Modified slightly by David Montenegro 2004.06.18.
+;;
+;; Copyright 2001 Christian Stimming <stimming at tu-harburg.de>
+;; 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 at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (gnucash engine))
+(use-modules (gnucash utilities))
+
+;; returns a list with n #f (empty cell) values
+(define (gnc:html-make-empty-cell) #f)
+(define (gnc:html-make-empty-cells n)
+ (if (> n 0)
+ (cons #f (gnc:html-make-empty-cells (- n 1)))
+ (list)))
+
+(define (gnc:register-guid type guid)
+ (gnc-build-url URL-TYPE-REGISTER (string-append type guid) ""))
+
+(define (gnc:account-anchor-text acct)
+ (gnc:register-guid "acct-guid=" (gncAccountGetGUID acct)))
+
+(define (gnc:split-anchor-text split)
+ (gnc:register-guid "split-guid=" (gncSplitGetGUID split)))
+
+(define (gnc:transaction-anchor-text trans)
+ (gnc:register-guid "trans-guid=" (gncTransGetGUID trans)))
+
+(define (gnc:report-anchor-text report-id)
+ (gnc-build-url URL-TYPE-REPORT
+ (string-append "id=" (number->string report-id))
+ ""))
+
+(define (gnc:price-anchor-text price)
+ (gnc-build-url URL-TYPE-PRICE
+ (string-append "price-guid=" (gncPriceGetGUID price))
+ ""))
+
+(define (guid-ref idstr type guid)
+ (gnc-build-url type (string-append idstr guid) ""))
+
+(define (gnc:customer-anchor-text customer)
+ (guid-ref "customer=" URL-TYPE-CUSTOMER (gncCustomerReturnGUID customer)))
+
+(define (gnc:job-anchor-text job)
+ (guid-ref "job=" URL-TYPE-JOB (gncJobReturnGUID job)))
+
+(define (gnc:vendor-anchor-text vendor)
+ (guid-ref "vendor=" URL-TYPE-VENDOR (gncVendorReturnGUID vendor)))
+
+(define (gnc:employee-anchor-text employee)
+ (guid-ref "employee=" URL-TYPE-EMPLOYEE (gncEmployeeReturnGUID employee)))
+
+(define (gnc:invoice-anchor-text invoice)
+ (guid-ref "invoice=" URL-TYPE-INVOICE (gncInvoiceReturnGUID invoice)))
+
+(define (gnc:owner-anchor-text owner)
+ (let ((type (gncOwnerGetType (gncOwnerGetEndOwner owner))))
+ (cond
+ ((eqv? type GNC-OWNER-CUSTOMER)
+ (gnc:customer-anchor-text (gncOwnerGetCustomer owner)))
+
+ ((eqv? type GNC-OWNER-VENDOR)
+ (gnc:vendor-anchor-text (gncOwnerGetVendor owner)))
+
+ ((eqv? type GNC-OWNER-EMPLOYEE)
+ (gnc:employee-anchor-text (gncOwnerGetEmployee owner)))
+
+ ((eqv? type GNC-OWNER-JOB)
+ (gnc:job-anchor-text (gncOwnerGetJob owner)))
+
+ (else
+ ""))))
+
+(define (gnc:owner-report-text owner acc)
+ (let* ((end-owner (gncOwnerGetEndOwner owner))
+ (type (gncOwnerGetType end-owner)))
+ (gnc-build-url
+ URL-TYPE-OWNERREPORT
+ (string-append
+ (cond ((eqv? type GNC-OWNER-CUSTOMER) "owner=c:")
+ ((eqv? type GNC-OWNER-VENDOR) "owner=v:")
+ ((eqv? type GNC-OWNER-EMPLOYEE) "owner=e:")
+ (else "unknown-type="))
+ (gncOwnerReturnGUID end-owner)
+ (if (null? acc) "" (string-append "&acct=" (gncAccountGetGUID acc))))
+ "")))
+
+;; Make a new report and return the anchor to it. The new report of
+;; type 'reportname' will have the option values copied from
+;; 'src-options', and additionally this function sets all options
+;; according to 'optionlist'. Each element of optionlist is a list of
+;; section, name, and value of the function.
+(define (gnc:make-report-anchor reportname src-report
+ optionlist)
+ (let ((src-options (gnc:report-options src-report))
+ (options (gnc:make-report-options reportname)))
+ (if options
+ (begin
+ (gnc:options-copy-values src-options options)
+ (for-each
+ (lambda (l)
+ (let ((o (gnc:lookup-option options (car l) (cadr l))))
+ (if o
+ (gnc:option-set-value o (caddr l))
+ (warn "gnc:make-report-anchor:" reportname
+ " No such option: " (car l) (cadr l)))))
+ optionlist)
+ (let ((id (gnc:make-report reportname options)))
+ (gnc:report-anchor-text id)))
+ (warn "gnc:make-report-anchor: No such report: " reportname))))
+
+
+;; returns the account name as html-text and anchor to the register.
+(define (gnc:html-account-anchor acct)
+ (gnc:make-html-text (if (and acct (not (null? acct)))
+ (gnc:html-markup-anchor
+ (gnc:account-anchor-text acct)
+ (xaccAccountGetName acct))
+ "")))
+
+(define (gnc:html-split-anchor split text)
+ (gnc:make-html-text (if (not (null? (xaccSplitGetAccount split)))
+ (gnc:html-markup-anchor
+ (gnc:split-anchor-text split)
+ text)
+ text)))
+
+(define (gnc:html-transaction-anchor trans text)
+ (gnc:make-html-text (gnc:html-markup-anchor
+ (gnc:transaction-anchor-text trans)
+ text)))
+
+(define (gnc:html-price-anchor price value)
+ (gnc:make-html-text (if price
+ (gnc:html-markup-anchor
+ (gnc:price-anchor-text price)
+ (if value
+ value
+ (gnc-price-get-value price)))
+ value)))
+
+(define (gnc:assign-colors num-colors)
+ ;; default CSS colours
+ ;; (define base-colors '("red" "orange" "yellow" "green"
+ ;; "cyan" "blue" "purple" "magenta"
+ ;; "orchid" "khaki" "gold" "orange"
+ ;; "red3" "orange3" "yellow3" "green3"
+ ;; "cyan3" "blue3" "purple3" "magenta3"
+ ;; "orchid3" "khaki3" "gold3" "orange3"))
+
+ ;; new base-colors from http://clrs.cc/ and flatuicolors.com
+ (define base-colors (list "#FF4136" "#FF851B" "#FFDC00" "#2ECC40"
+ "#0074D9" "#001f3f" "#85144b" "#7FDBFF"
+ "#F012BE" "#3D9970" "#39CCCC" "#f39c12"
+ "#e74c3c" "#e67e22" "#9b59b6" "#8e44ad"
+ "#16a085" "#d35400"))
+ (let lp ((i 0) (result '()) (colors base-colors))
+ (cond
+ ((<= num-colors i) (reverse result))
+ ((null? colors) (lp (1+ i) (cons (car base-colors) result) (cdr base-colors)))
+ (else (lp (1+ i) (cons (car colors) result) (cdr colors))))))
+
+(define (gnc:html-table-append-ruler! table colspan)
+ (gnc:html-table-append-row!
+ table (list (gnc:make-html-table-cell/size
+ 1 colspan (gnc:make-html-text (gnc:html-markup-hr))))))
+
+;; Create a html-table of all exchange rates. The report-commodity is
+;; 'common-commodity', the exchange rates are given through the
+;; function 'exchange-fn' and the 'accounts' determine which
+;; commodities to show. Returns a html-object, a <html-table>.
+(define (gnc:html-make-exchangerates common-commodity exchange-fn accounts)
+ (let ((comm-list (gnc:accounts-get-commodities accounts common-commodity))
+ (markup (lambda (c) (gnc:make-html-table-cell/markup "number-cell" c)))
+ (table (gnc:make-html-table)))
+ (unless (null? comm-list)
+ (for-each
+ (lambda (commodity)
+ (let* ((orig-amt (gnc:make-gnc-monetary commodity 1))
- (exchanged (exchange-fn orig-amt common-commodity)))
++ (exchanged (exchange-fn orig-amt common-commodity))
++ (conv-amount (gnc:gnc-monetary-amount exchanged)))
+ (gnc:html-table-append-row!
- table (map markup (list orig-amt exchanged)))))
++ table (list (markup orig-amt)
++ (markup (gnc:default-price-renderer common-commodity
++ conv-amount))))))
+ comm-list)
+ (gnc:html-table-set-col-headers!
+ table (list (gnc:make-html-table-header-cell/size
+ 1 2 (if (null? (cdr comm-list))
+ (_ "Exchange rate")
+ (_ "Exchange rates"))))))
+ table))
+
+
+(define (gnc:html-make-generic-budget-warning report-title-string)
+ (gnc:html-make-generic-simple-warning
+ report-title-string
+ (_ "No budgets exist. You must create at least one budget.")))
+
+
+(define (gnc:html-make-generic-simple-warning report-title-string message)
+ (let ((p (gnc:make-html-text)))
+ (gnc:html-text-append!
+ p
+ (gnc:html-markup-h2 (string-append report-title-string ":"))
+ (gnc:html-markup-h2 "")
+ (gnc:html-markup-p message))
+ p))
+
+
+(define (gnc:html-make-options-link report-id)
+ (if report-id
+ (gnc:html-markup-p
+ (gnc:html-markup-anchor
+ (gnc-build-url URL-TYPE-OPTIONS
+ (string-append "report-id=" (format #f "~a" report-id))
+ "")
+ (_ "Edit report options")))))
+
+(define* (gnc:html-render-options-changed options #:optional plaintext?)
+ ;; options -> html-object or string, depending on plaintext?. This
+ ;; summarises options that were changed by the user. Set plaintext?
+ ;; to #t for unit-tests only.
+ (define (disp d)
+ ;; option-value -> string. The option is passed to various
+ ;; scm->string converters; ultimately a generic stringify
+ ;; function handles symbol/string/other types.
+ (define (try proc)
+ ;; Try proc with d as a parameter, catching 'wrong-type-arg
+ ;; exceptions to return #f to the or evaluator.
+ (catch 'wrong-type-arg
+ (lambda () (proc d))
+ (const #f)))
+ (or (and (boolean? d) (if d (_ "Enabled") (_ "Disabled")))
+ (and (null? d) "null")
+ (and (list? d) (string-join (map disp d) ", "))
+ (and (pair? d) (format #f "~a . ~a"
+ (car d)
+ (if (eq? (car d) 'absolute)
+ (qof-print-date (cdr d))
+ (disp (cdr d)))))
+ (try gnc-commodity-get-mnemonic)
+ (try xaccAccountGetName)
+ (try gnc-budget-get-name)
+ (format #f "~a" d)))
+ (let ((render-list '()))
+ (define (add-option-if-changed option)
+ (let* ((section (gnc:option-section option))
+ (name (gnc:option-name option))
+ (default-value (gnc:option-default-value option))
+ (value (gnc:option-value option))
+ (retval (cons (format #f "~a / ~a" section name)
+ (disp value))))
+ (if (not (or (equal? default-value value)
+ (char=? (string-ref section 0) #\_)))
+ (addto! render-list retval))))
+ (gnc:options-for-each add-option-if-changed options)
+ (if plaintext?
+ (string-append
+ (string-join
+ (map (lambda (item)
+ (format #f "~a: ~a\n" (car item) (cdr item)))
+ render-list)
+ "")
+ "\n")
+ (apply
+ gnc:make-html-text
+ (apply
+ append
+ (map
+ (lambda (item)
+ (list
+ (gnc:html-markup-b (car item))
+ ": "
+ (cdr item)
+ (gnc:html-markup-br)))
+ render-list))))))
+
+(define (gnc:html-make-generic-warning
+ report-title-string report-id
+ warning-title-string warning-string)
+ (let ((p (gnc:make-html-text)))
+ (gnc:html-text-append!
+ p
+ (gnc:html-markup-h2 (string-append (_ report-title-string) ":"))
+ (gnc:html-markup-h2 warning-title-string)
+ (gnc:html-markup-p warning-string)
+ (gnc:html-make-options-link report-id))
+ p))
+
+(define (gnc:html-make-generic-options-warning
+ report-title-string report-id)
+ (gnc:html-make-generic-warning
+ report-title-string
+ report-id
+ ""
+ (_ "This report requires you to specify certain report options.")))
+
+(define (gnc:html-make-no-account-warning
+ report-title-string report-id)
+ (gnc:html-make-generic-warning
+ report-title-string
+ report-id
+ (_ "No accounts selected")
+ (_ "This report requires accounts to be selected in the report options.")))
+
+(define (gnc:html-make-empty-data-warning
+ report-title-string report-id)
+ (gnc:html-make-generic-warning
+ report-title-string
+ report-id
+ (_ "No data")
+ (_ "The selected accounts contain no data/transactions (or only zeroes) for the selected time period")))
+
+(define (gnc:html-js-include file)
+ (format #f
+ "<script language=\"javascript\" type=\"text/javascript\" src=\"file:///~a\"></script>\n"
+ (gnc-path-find-localized-html-file file)))
+
+(define (gnc:html-css-include file)
+ (format #f
+ "<link rel=\"stylesheet\" type=\"text/css\" href=\"file:///~a\" />\n"
+ (gnc-path-find-localized-html-file file)))
+
+
+
diff --cc gnucash/report/report.scm
index 5d64278e0,000000000..174ba9d6a
mode 100644,000000..100644
--- a/gnucash/report/report.scm
+++ b/gnucash/report/report.scm
@@@ -1,839 -1,0 +1,840 @@@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; report.scm
+;; module definition for the report system code
+;;
+;; Copyright (c) 2001 Linux Developers Group, Inc.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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 at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-module (gnucash report))
+(use-modules (gnucash utilities))
+(use-modules (ice-9 regex))
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-19))
+(use-modules (gnucash core-utils))
+(use-modules (gnucash engine))
+(use-modules (gnucash app-utils))
+(use-modules (gnucash gnome-utils))
+(use-modules (gnucash html))
+
+;; commodity-utilities.scm
+(export gnc:get-match-commodity-splits)
+(export gnc:get-match-commodity-splits-sorted)
+(export gnc:get-all-commodity-splits )
+(export gnc:exchange-by-euro-numeric)
+(export gnc:get-commodity-totalavg-prices)
+(export gnc:get-commoditylist-totalavg-prices)
+(export gnc:get-commodity-inst-prices)
+(export gnc:pricelist-price-find-nearest)
+(export gnc:pricealist-lookup-nearest-in-time)
+(export gnc:resolve-unknown-comm)
+(export gnc:get-exchange-totals)
+(export gnc:get-exchange-cost-totals)
+(export gnc:make-exchange-alist)
+(export gnc:make-exchange-cost-alist)
+(export gnc:exchange-by-euro)
+(export gnc:exchange-if-same)
+(export gnc:make-exchange-function)
+(export gnc:exchange-by-pricedb-latest )
+(export gnc:exchange-by-pricedb-nearest)
+(export gnc:exchange-by-pricealist-nearest)
+(export gnc:case-exchange-fn)
+(export gnc:case-exchange-time-fn)
+(export gnc:sum-collector-commodity)
+
+;; options-utilities.scm
+
+(export gnc:options-add-report-date!)
+(export gnc:options-add-date-interval!)
+(export gnc:options-add-interval-choice!)
+(export gnc:options-add-account-levels!)
+(export gnc:options-add-account-selection!)
+(export gnc:options-add-currency!)
+(export gnc:options-add-price-source!)
+(export gnc:options-add-plot-size!)
+(export gnc:options-add-marker-choice!)
+(export gnc:options-add-sort-method!)
+(export gnc:options-add-subtotal-view!)
+
+;; html-fonts.scm
+
+(export register-font-options)
+(export add-css-information-to-doc)
+
+;; html-utilities.scm
+
+(export gnc:html-make-empty-cell)
+(export gnc:html-make-empty-cells)
+(export gnc:account-anchor-text)
+(export gnc:split-anchor-text)
+(export gnc:transaction-anchor-text)
+(export gnc:report-anchor-text)
+(export gnc:make-report-anchor)
+(export gnc:html-account-anchor)
+(export gnc:html-split-anchor)
+(export gnc:html-transaction-anchor)
+(export gnc:html-price-anchor)
+(export gnc:customer-anchor-text)
+(export gnc:job-anchor-text)
+(export gnc:vendor-anchor-text)
+(export gnc:invoice-anchor-text)
+(export gnc:owner-anchor-text)
+(export gnc:owner-report-text)
+(export gnc:assign-colors)
+(export gnc:html-table-append-ruler!)
+(export gnc:html-make-exchangerates)
+(export gnc:html-render-options-changed)
+(export gnc:html-make-generic-warning)
+(export gnc:html-make-no-account-warning)
+(export gnc:html-make-generic-budget-warning)
+(export gnc:html-make-generic-options-warning)
+(export gnc:html-make-generic-simple-warning)
+(export gnc:html-make-empty-data-warning)
+(export gnc:html-make-options-link)
+(export gnc:html-js-include)
+(export gnc:html-css-include)
+
+;; report-core.scm
+(export gnc:menuname-reports)
+(export gnc:menuname-asset-liability)
+(export gnc:menuname-income-expense)
+(export gnc:menuname-budget)
+(export gnc:menuname-taxes)
+(export gnc:menuname-example)
+(export gnc:menuname-multicolumn)
+(export gnc:menuname-experimental)
+(export gnc:menuname-custom)
+(export gnc:menuname-business-reports)
+(export gnc:pagename-general)
+(export gnc:pagename-accounts)
+(export gnc:pagename-display)
+(export gnc:optname-reportname)
+(export gnc:optname-invoice-number)
+
+(export gnc:define-report)
+(export <report>)
+(export gnc:report-template-new-options/report-guid)
+(export gnc:report-template-menu-name/report-guid)
+(export gnc:report-template-renderer/report-guid)
+(export gnc:report-template-new-options)
+(export gnc:report-template-version)
+(export gnc:report-template-name)
+(export gnc:report-template-report-guid)
+(export gnc:report-template-set-report-guid!)
+(export gnc:report-template-options-generator)
+(export gnc:report-template-options-cleanup-cb)
+(export gnc:report-template-options-changed-cb)
+(export gnc:report-template-renderer)
+(export gnc:report-template-in-menu?)
+(export gnc:report-template-menu-path)
+(export gnc:report-template-menu-name)
+(export gnc:report-template-menu-tip)
+(export gnc:report-template-export-types)
+(export gnc:report-template-export-thunk)
+(export gnc:report-template-has-unique-name?)
+(export gnc:report-type)
+(export gnc:report-set-type!)
+(export gnc:report-id)
+(export gnc:report-set-id!)
+(export gnc:report-options)
+(export gnc:report-set-options!)
+(export gnc:report-needs-save?)
+(export gnc:report-set-needs-save?!)
+(export gnc:report-dirty?)
+(export gnc:report-set-dirty?!)
+(export gnc:report-editor-widget)
+(export gnc:report-set-editor-widget!)
+(export gnc:report-ctext)
+(export gnc:report-set-ctext!)
+(export gnc:make-report)
+(export gnc:restore-report-by-guid)
+(export gnc:restore-report-by-guid-with-custom-template)
+(export gnc:make-report-options)
+(export gnc:report-export-types)
+(export gnc:report-export-thunk)
+(export gnc:report-menu-name)
+(export gnc:report-name)
+(export gnc:report-stylesheet)
+(export gnc:report-set-stylesheet!)
+(export gnc:all-report-template-guids)
+(export gnc:custom-report-template-guids)
+(export gnc:delete-report)
+(export gnc:rename-report)
+(export gnc:find-report-template)
+(export gnc:report-serialize)
+(export gnc:report-to-template-new)
+(export gnc:report-to-template-update)
+(export gnc:report-render-html)
+(export gnc:report-run)
+(export gnc:report-templates-for-each)
+(export gnc:report-embedded-list)
+(export gnc:report-template-is-custom/template-guid?)
+(export gnc:is-custom-report-type)
+
+;; html-barchart.scm
+
+(export <html-barchart>)
+(export gnc:html-barchart? )
+(export gnc:make-html-barchart-internal)
+(export gnc:make-html-barchart)
+(export gnc:html-barchart-data)
+(export gnc:html-barchart-set-data!)
+(export gnc:html-barchart-width)
+(export gnc:html-barchart-set-width!)
+(export gnc:html-barchart-height)
+(export gnc:html-barchart-set-height!)
+(export gnc:html-barchart-x-axis-label)
+(export gnc:html-barchart-set-x-axis-label!)
+(export gnc:html-barchart-y-axis-label)
+(export gnc:html-barchart-set-y-axis-label!)
+(export gnc:html-barchart-row-labels)
+(export gnc:html-barchart-set-row-labels!)
+(export gnc:html-barchart-row-labels-rotated?)
+(export gnc:html-barchart-set-row-labels-rotated?!)
+(export gnc:html-barchart-stacked?)
+(export gnc:html-barchart-set-stacked?!)
+(export gnc:html-barchart-col-labels)
+(export gnc:html-barchart-set-col-labels!)
+(export gnc:html-barchart-col-colors)
+(export gnc:html-barchart-set-col-colors!)
+(export gnc:html-barchart-legend-reversed?)
+(export gnc:html-barchart-set-legend-reversed?!)
+(export gnc:html-barchart-title)
+(export gnc:html-barchart-set-title!)
+(export gnc:html-barchart-subtitle)
+(export gnc:html-barchart-set-subtitle!)
+(export gnc:html-barchart-button-1-bar-urls)
+(export gnc:html-barchart-set-button-1-bar-urls!)
+(export gnc:html-barchart-button-2-bar-urls)
+(export gnc:html-barchart-set-button-2-bar-urls!)
+(export gnc:html-barchart-button-3-bar-urls)
+(export gnc:html-barchart-set-button-3-bar-urls!)
+(export gnc:html-barchart-button-1-legend-urls)
+(export gnc:html-barchart-set-button-1-legend-urls!)
+(export gnc:html-barchart-button-2-legend-urls)
+(export gnc:html-barchart-set-button-2-legend-urls!)
+(export gnc:html-barchart-button-3-legend-urls)
+(export gnc:html-barchart-set-button-3-legend-urls!)
+(export gnc:html-barchart-append-row!)
+(export gnc:html-barchart-prepend-row!)
+(export gnc:html-barchart-append-column!)
+(export gnc:not-all-zeros)
+(export gnc:html-barchart-prepend-column!)
+(export gnc:html-barchart-render barchart)
+
+;; html-document.scm
+
+(export <html-document>)
+(export gnc:html-document?)
+(export gnc:make-html-document-internal)
+(export gnc:make-html-document)
+(export gnc:html-document-set-title!)
+(export gnc:html-document-title)
+(export gnc:html-document-set-headline!)
+(export gnc:html-document-headline)
+(export gnc:html-document-set-style-text!)
+(export gnc:html-document-style-text)
+(export gnc:html-document-set-style-sheet!)
+(export gnc:html-document-style-sheet)
+(export gnc:html-document-set-style-stack!)
+(export gnc:html-document-style-stack)
+(export gnc:html-document-set-style-internal!)
+(export gnc:html-document-style)
+(export gnc:html-document-set-objects!)
+(export gnc:html-document-objects)
+(export gnc:html-document?)
+(export gnc:html-document-set-style!)
+(export gnc:html-document-tree-collapse)
+(export gnc:html-document-render)
+(export gnc:html-document-push-style)
+(export gnc:html-document-pop-style)
+(export gnc:html-document-add-object!)
+(export gnc:html-document-append-objects!)
+(export gnc:html-document-fetch-markup-style)
+(export gnc:html-document-fetch-data-style)
+(export gnc:html-document-markup-start)
+(export gnc:html-document-markup-end)
+(export gnc:html-document-render-data)
+(export <html-object>)
+(export gnc:html-object?)
+(export gnc:make-html-object-internal)
+(export gnc:make-html-object)
+(export gnc:html-object-renderer)
+(export gnc:html-object-set-renderer!)
+(export gnc:html-object-data)
+(export gnc:html-object-set-data!)
+(export gnc:html-object-render)
+
+;; html-piechart.scm
+
+(export <html-piechart>)
+(export gnc:html-piechart?)
+(export gnc:make-html-piechart-internal)
+(export gnc:make-html-piechart)
+(export gnc:html-piechart-data)
+(export gnc:html-piechart-set-data!)
+(export gnc:html-piechart-width)
+(export gnc:html-piechart-set-width!)
+(export gnc:html-piechart-height)
+(export gnc:html-piechart-set-height!)
+(export gnc:html-piechart-labels)
+(export gnc:html-piechart-set-labels!)
+(export gnc:html-piechart-colors)
+(export gnc:html-piechart-set-colors!)
+(export gnc:html-piechart-title)
+(export gnc:html-piechart-set-title!)
+(export gnc:html-piechart-subtitle)
+(export gnc:html-piechart-set-subtitle!)
+(export gnc:html-piechart-button-1-slice-urls)
+(export gnc:html-piechart-set-button-1-slice-urls!)
+(export gnc:html-piechart-button-2-slice-urls)
+(export gnc:html-piechart-set-button-2-slice-urls!)
+(export gnc:html-piechart-button-3-slice-urls)
+(export gnc:html-piechart-set-button-3-slice-urls!)
+(export gnc:html-piechart-button-1-legend-urls)
+(export gnc:html-piechart-set-button-1-legend-urls!)
+(export gnc:html-piechart-button-2-legend-urls)
+(export gnc:html-piechart-set-button-2-legend-urls!)
+(export gnc:html-piechart-button-3-legend-urls)
+(export gnc:html-piechart-set-button-3-legend-urls!)
+(export gnc:html-piechart-render)
+
+;; html-scatter.scm
+
+(export <html-scatter>)
+(export gnc:html-scatter?)
+(export gnc:make-html-scatter-internal)
+(export gnc:make-html-scatter)
+(export gnc:html-scatter-width)
+(export gnc:html-scatter-set-width!)
+(export gnc:html-scatter-height)
+(export gnc:html-scatter-set-height!)
+(export gnc:html-scatter-title)
+(export gnc:html-scatter-set-title!)
+(export gnc:html-scatter-subtitle)
+(export gnc:html-scatter-set-subtitle!)
+(export gnc:html-scatter-x-axis-label)
+(export gnc:html-scatter-set-x-axis-label!)
+(export gnc:html-scatter-y-axis-label)
+(export gnc:html-scatter-set-y-axis-label!)
+(export gnc:html-scatter-data)
+(export gnc:html-scatter-set-data!)
+(export gnc:html-scatter-marker)
+(export gnc:html-scatter-set-marker!)
+(export gnc:html-scatter-markercolor)
+(export gnc:html-scatter-set-markercolor!)
+(export gnc:html-scatter-add-datapoint!)
+(export gnc:html-scatter-render)
+
+;; html-linechart.scm
+
+(export <html-linechart>)
+(export gnc:html-linechart? )
+(export gnc:make-html-linechart-internal)
+(export gnc:make-html-linechart)
+(export gnc:html-linechart-data)
+(export gnc:html-linechart-set-data!)
+(export gnc:html-linechart-width)
+(export gnc:html-linechart-set-width!)
+(export gnc:html-linechart-height)
+(export gnc:html-linechart-set-height!)
+(export gnc:html-linechart-x-axis-label)
+(export gnc:html-linechart-set-x-axis-label!)
+(export gnc:html-linechart-y-axis-label)
+(export gnc:html-linechart-set-y-axis-label!)
+(export gnc:html-linechart-row-labels)
+(export gnc:html-linechart-set-row-labels!)
+(export gnc:html-linechart-row-labels-rotated?)
+(export gnc:html-linechart-set-row-labels-rotated?!)
+(export gnc:html-linechart-stacked?)
+(export gnc:html-linechart-set-stacked?!)
+(export gnc:html-linechart-markers?)
+(export gnc:html-linechart-set-markers?!)
+(export gnc:html-linechart-major-grid?)
+(export gnc:html-linechart-set-major-grid?!)
+(export gnc:html-linechart-minor-grid?)
+(export gnc:html-linechart-set-minor-grid?!)
+(export gnc:html-linechart-col-labels)
+(export gnc:html-linechart-set-col-labels!)
+(export gnc:html-linechart-col-colors)
+(export gnc:html-linechart-set-col-colors!)
+(export gnc:html-linechart-legend-reversed?)
+(export gnc:html-linechart-set-legend-reversed?!)
+(export gnc:html-linechart-title)
+(export gnc:html-linechart-set-title!)
+(export gnc:html-linechart-subtitle)
+(export gnc:html-linechart-set-subtitle!)
+(export gnc:html-linechart-button-1-line-urls)
+(export gnc:html-linechart-set-button-1-line-urls!)
+(export gnc:html-linechart-button-2-line-urls)
+(export gnc:html-linechart-set-button-2-line-urls!)
+(export gnc:html-linechart-button-3-line-urls)
+(export gnc:html-linechart-set-button-3-line-urls!)
+(export gnc:html-linechart-button-1-legend-urls)
+(export gnc:html-linechart-set-button-1-legend-urls!)
+(export gnc:html-linechart-button-2-legend-urls)
+(export gnc:html-linechart-set-button-2-legend-urls!)
+(export gnc:html-linechart-button-3-legend-urls)
+(export gnc:html-linechart-set-button-3-legend-urls!)
+(export gnc:html-linechart-append-row!)
+(export gnc:html-linechart-prepend-row!)
+(export gnc:html-linechart-append-column!)
+(export gnc:html-linechart-prepend-column!)
+(export gnc:html-linechart-render linechart)
+(export gnc:html-linechart-set-line-width!)
+(export gnc:html-linechart-line-width)
+
+;; html-style-info.scm
+
+(export <html-markup-style-info>)
+(export gnc:html-markup-style-info?)
+(export gnc:make-html-markup-style-info-internal)
+(export gnc:make-html-markup-style-info)
+(export gnc:html-markup-style-info-set!)
+(export gnc:html-markup-style-info-tag)
+(export gnc:html-markup-style-info-set-tag!)
+(export gnc:html-markup-style-info-attributes)
+(export gnc:html-markup-style-info-set-attributes!)
+(export gnc:html-markup-style-info-inheritable?)
+(export gnc:html-markup-style-info-set-inheritable?!)
+(export gnc:html-markup-style-info-set-attribute!)
+(export gnc:html-markup-style-info-merge)
+(export gnc:html-style-info-merge)
+(export gnc:html-data-style-info-merge)
+(export <html-data-style-info>)
+(export gnc:html-data-style-info?)
+(export gnc:make-html-data-style-info-internal)
+(export gnc:make-html-data-style-info)
+(export gnc:html-data-style-info?)
+(export gnc:html-data-style-info-renderer)
+(export gnc:html-data-style-info-set-renderer!)
+(export gnc:html-data-style-info-data)
+(export gnc:html-data-style-info-set-data!)
+(export gnc:html-data-style-info-inheritable?)
+(export gnc:html-data-style-info-set-inheritable?!)
+(export gnc:default-html-string-renderer)
+(export gnc:default-html-gnc-numeric-renderer)
+(export gnc:default-html-gnc-monetary-renderer)
+(export gnc:default-html-number-renderer)
+(export <html-style-table>)
+(export gnc:html-style-table?)
+(export gnc:make-html-style-table-internal)
+(export gnc:make-html-style-table)
+(export gnc:html-style-table-primary)
+(export gnc:html-style-table-compiled)
+(export gnc:html-style-table-set-compiled!)
+(export gnc:html-style-table-inheritable)
+(export gnc:html-style-table-set-inheritable!)
+(export gnc:html-style-table-compiled?)
+(export gnc:html-style-table-compile)
+(export gnc:html-style-table-uncompile)
+(export gnc:html-style-table-fetch)
+(export gnc:html-style-table-set!)
+
+;; html-style-sheet.scm
+
+(export <html-style-sheet-template>)
+(export gnc:html-style-sheet-template?)
+(export gnc:html-style-sheet-template-version)
+(export gnc:html-style-sheet-template-set-version!)
+(export gnc:html-style-sheet-template-name)
+(export gnc:html-style-sheet-template-set-name!)
+(export gnc:html-style-sheet-template-options-generator)
+(export gnc:html-style-sheet-template-set-options-generator!)
+(export gnc:html-style-sheet-template-renderer)
+(export gnc:html-style-sheet-template-set-renderer!)
+(export gnc:html-style-sheet-template-find)
+(export gnc:define-html-style-sheet)
+(export <html-style-sheet>)
+(export gnc:html-style-sheet?)
+(export gnc:html-style-sheet-name)
+(export gnc:html-style-sheet-set-name!)
+(export gnc:html-style-sheet-type)
+(export gnc:html-style-sheet-set-type!)
+(export gnc:html-style-sheet-options)
+(export gnc:html-style-sheet-set-options!)
+(export gnc:html-style-sheet-renderer)
+(export gnc:html-style-sheet-set-renderer!)
+(export gnc:make-html-style-sheet-internal)
+(export gnc:html-style-sheet-style)
+(export gnc:html-style-sheet-set-style!)
+(export gnc:make-html-style-sheet)
+(export gnc:restore-html-style-sheet)
+(export gnc:html-style-sheet-apply-changes)
+(export gnc:html-style-sheet-render)
+(export gnc:get-html-style-sheets)
+(export gnc:get-html-templates)
+(export gnc:html-style-sheet-find)
+(export gnc:html-style-sheet-remove)
+
+;; html-acct-table.scm
+
+(export <html-acct-table>)
+(export gnc:html-acct-table?)
+(export gnc:_make-html-acct-table_)
+(export gnc:make-html-acct-table)
+(export gnc:make-html-acct-table/env)
+(export gnc:make-html-acct-table/env/accts)
+(export gnc:_html-acct-table-matrix_)
+(export gnc:_html-acct-table-set-matrix!_)
+(export gnc:_html-acct-table-env_)
+(export gnc:_html-acct-table-set-env!_)
+(export gnc:html-acct-table-add-accounts!)
+(export gnc:html-acct-table-num-rows)
+(export gnc:html-acct-table-get-row)
+(export gnc:html-acct-table-get-cell)
+(export gnc:html-acct-table-set-cell!)
+(export gnc:html-acct-table-get-row-env)
+(export gnc:html-acct-table-set-row-env!)
+(export gnc:account-code-less-p)
+(export gnc:account-name-less-p)
+(export gnc:account-path-less-p)
+(export gnc:html-table-add-labeled-amount-line!)
+(export gnc:html-table-add-account-balances)
+(export gnc-commodity-table)
+(export gnc:uniform-commodity?)
+
+;; html-chart.scm
+
+(export gnc:html-chart?)
+(export gnc:make-html-chart)
+(export gnc:html-chart-data)
+(export gnc:html-chart-set-data!)
+(export gnc:html-chart-width)
+(export gnc:html-chart-set-width!)
+(export gnc:html-chart-height)
+(export gnc:html-chart-set-height!)
+(export gnc:html-chart-type)
+(export gnc:html-chart-set-type!)
+(export gnc:html-chart-title)
+(export gnc:html-chart-get)
+(export gnc:html-chart-set!)
+(export gnc:html-chart-currency-iso)
+(export gnc:html-chart-set-currency-iso!)
+(export gnc:html-chart-currency-symbol)
+(export gnc:html-chart-set-currency-symbol!)
+(export gnc:html-chart-render)
+
+;; html-table.scm
+
+(export <html-table>)
+(export gnc:html-table?)
+(export <html-table-cell>)
+(export gnc:make-html-table-cell-internal)
+(export gnc:make-html-table-cell)
+(export gnc:make-html-table-cell/size)
+(export gnc:make-html-table-cell/markup)
+(export gnc:make-html-table-cell/size/markup)
+(export gnc:make-html-table-header-cell)
+(export gnc:make-html-table-header-cell/markup)
+(export gnc:make-html-table-header-cell/size)
+(export gnc:make-html-table-cell/min-width)
+(export gnc:html-table-cell?)
+(export gnc:html-table-cell-rowspan)
+(export gnc:html-table-cell-set-rowspan!)
+(export gnc:html-table-cell-colspan)
+(export gnc:html-table-cell-set-colspan!)
+(export gnc:html-table-cell-tag)
+(export gnc:html-table-cell-set-tag!)
+(export gnc:html-table-cell-data)
+(export gnc:html-table-cell-set-data-internal!)
+(export gnc:html-table-cell-style)
+(export gnc:html-table-cell-set-style-internal!)
+(export gnc:html-table-cell-set-style!)
+(export gnc:html-table-cell-append-objects!)
+(export gnc:html-table-cell-render)
+(export gnc:make-html-table-internal)
+(export gnc:make-html-table)
+(export gnc:html-table-data)
+(export gnc:html-table-set-data!)
+(export gnc:html-table-caption)
+(export gnc:html-table-set-caption!)
+(export gnc:html-table-col-headers)
+(export gnc:html-table-set-col-headers!)
+(export gnc:html-table-multirow-col-headers)
+(export gnc:html-table-set-multirow-col-headers!)
+(export gnc:html-table-row-headers)
+(export gnc:html-table-set-row-headers!)
+(export gnc:html-table-style)
+(export gnc:html-table-set-style-internal!)
+(export gnc:html-table-row-styles)
+(export gnc:html-table-set-row-styles!)
+(export gnc:html-table-row-markup-table)
+(export gnc:html-table-row-markup)
+(export gnc:html-table-set-row-markup-table!)
+(export gnc:html-table-set-row-markup!)
+(export gnc:html-table-col-styles)
+(export gnc:html-table-set-col-styles!)
+(export gnc:html-table-col-headers-style)
+(export gnc:html-table-set-col-headers-style!)
+(export gnc:html-table-row-headers-style)
+(export gnc:html-table-set-row-headers-style!)
+(export gnc:html-table-set-last-row-style!)
+(export gnc:html-table-set-style!)
+(export gnc:html-table-set-col-style!)
+(export gnc:html-table-set-row-style!)
+(export gnc:html-table-row-style)
+(export gnc:html-table-col-style)
+(export gnc:html-table-num-rows)
+(export gnc:html-table-set-num-rows-internal!)
+(export gnc:html-table-num-columns)
+(export gnc:html-table-append-row/markup!)
+(export gnc:html-table-prepend-row/markup!)
+(export gnc:html-table-append-row!)
+(export gnc:html-table-prepend-row!)
+(export gnc:html-table-get-cell)
+(export gnc:html-table-set-cell!)
+(export gnc:html-table-set-cell/tag!)
+(export gnc:html-table-append-column!)
+(export gnc:html-table-render)
+
+;; html-anytag.scm
+(export <html-anytag>)
+(export html-anytag?)
+(export gnc:html-anytag-data)
+(export gnc:html-anytag-set-data!)
+(export gnc:html-anytag-style)
+(export gnc:html-anytag-append-data!)
+(export gnc:html-anytag-set-style!)
+(export gnc:html-anytag-render div doc)
+(export gnc:make-html-div)
+(export gnc:make-html-div/markup)
+(export gnc:make-html-span)
+(export gnc:make-html-span/markup)
+
+;; html-text.scm
+
+(export <html-text>)
+(export gnc:html-text?)
+(export gnc:make-html-text-internal)
+(export gnc:make-html-text)
+(export gnc:html-text?)
+(export gnc:html-text-body)
+(export gnc:html-text-set-body-internal!)
+(export gnc:html-text-set-body!)
+(export gnc:html-text-style)
+(export gnc:html-text-set-style-internal!)
+(export gnc:html-text-set-style!)
+(export gnc:html-text-append!)
+(export gnc:html-markup)
+(export gnc:html-markup/attr)
+(export gnc:html-markup/no-end)
+(export gnc:html-markup/attr/no-end)
+(export gnc:html-markup/format)
+(export gnc:html-markup-p)
+(export gnc:html-markup-tt)
+(export gnc:html-markup-em)
+(export gnc:html-markup-b)
+(export gnc:html-markup-i)
+(export gnc:html-markup-h1)
+(export gnc:html-markup-h2)
+(export gnc:html-markup-h3)
+(export gnc:html-markup-br)
+(export gnc:html-markup-hr)
+(export gnc:html-markup-ol)
+(export gnc:html-markup-ul)
+(export gnc:html-markup-anchor)
+(export gnc:html-markup-img)
+(export gnc:html-text-render)
+(export gnc:html-text-render-markup)
+
+;; report-utilities.scm
+
+(export list-ref-safe)
+(export list-set-safe!)
+(export gnc:monetary->string)
+(export gnc:account-has-shares?)
+(export gnc:account-is-stock?)
+(export gnc:account-is-inc-exp?)
+(export gnc:filter-accountlist-type)
+(export gnc:decompose-accountlist)
+(export gnc:account-get-type-string-plural)
+(export gnc:accounts-get-commodities)
+(export gnc:get-current-account-tree-depth)
+(export gnc:accounts-and-all-descendants)
+(export gnc:make-value-collector)
+(export gnc:make-commodity-collector)
+(export gnc:collector+)
+(export gnc:collector-)
+(export gnc:commodity-collector-get-negated)
+(export gnc:account-accumulate-at-dates)
+(export gnc:account-get-balance-at-date)
+(export gnc:account-get-balances-at-dates)
+(export gnc:account-get-comm-balance-at-date)
+(export gnc:account-get-comm-value-interval)
+(export gnc:account-get-comm-value-at-date)
+(export gnc:accounts-get-balance-helper)
+(export gnc:accounts-get-comm-total-profit)
+(export gnc:accounts-get-comm-total-income)
+(export gnc:accounts-get-comm-total-expense)
+(export gnc:accounts-get-comm-total-assets)
+(export gnc:account-get-balance-interval)
+(export gnc:account-get-comm-balance-interval)
+(export gnc:accountlist-get-comm-balance-interval)
+(export gnc:accountlist-get-comm-balance-interval-with-closing)
+(export gnc:accountlist-get-comm-balance-at-date)
+(export gnc:accountlist-get-comm-balance-at-date-with-closing)
+(export gnc:query-set-match-non-voids-only!)
+(export gnc:query-set-match-voids-only!)
+(export gnc:split-voided?)
+(export gnc:report-starting)
+(export gnc:report-render-starting)
+(export gnc:report-percent-done)
+(export gnc:report-finished)
+(export gnc:accounts-count-splits)
+(export gnc-commodity-collector-allzero?)
+(export gnc:monetary+)
+(export gnc:monetaries-add)
+(export gnc:account-get-trans-type-balance-interval)
+(export gnc:account-get-trans-type-balance-interval-with-closing)
+(export gnc:account-get-trans-type-splits-interval)
+(export gnc:budget-get-start-date)
+(export gnc:budget-get-end-date)
+(export gnc:budget-account-get-net)
+(export gnc:budget-accountlist-get-net)
+(export gnc:budget-account-get-initial-balance)
+(export gnc:budget-accountlist-get-initial-balance)
+(export budget-account-sum budget)
+(export gnc:get-account-period-rolledup-budget-value)
+(export gnc:budget-account-get-rolledup-net)
+(export gnc:get-assoc-account-balances)
+(export gnc:select-assoc-account-balance)
+(export gnc:get-assoc-account-balances-total)
+(export gnc:multiline-to-html-text)
++(export gnc:default-price-renderer)
+(export make-file-url)
+(export gnc:strify)
+(export gnc:pk)
+(export gnc:dump-book)
+(export gnc:dump-invoices)
+(export gnc:dump-lot)
+
+;; trep-engine.scm
+(export gnc:trep-options-generator)
+(export gnc:trep-renderer)
+
+;; report-register-hooks.scm
+
+(export gnc:register-report-hook)
+(export gnc:lookup-register-report)
+
+
+(load-from-path "gnucash/report/commodity-utilities")
+(load-from-path "gnucash/report/html-chart")
+(load-from-path "gnucash/report/html-barchart")
+(load-from-path "gnucash/report/html-document")
+(load-from-path "gnucash/report/html-piechart")
+(load-from-path "gnucash/report/html-scatter")
+(load-from-path "gnucash/report/html-linechart")
+(load-from-path "gnucash/report/html-style-info")
+(load-from-path "gnucash/report/html-fonts")
+
+(load-from-path "gnucash/report/html-style-sheet")
+(load-from-path "gnucash/report/html-anytag")
+(load-from-path "gnucash/report/html-table")
+(load-from-path "gnucash/report/html-text")
+(load-from-path "gnucash/report/html-acct-table")
+(load-from-path "gnucash/report/html-utilities")
+(load-from-path "gnucash/report/options-utilities")
+(load-from-path "gnucash/report/report-utilities")
+(load-from-path "gnucash/report/report-register-hooks")
+(load-from-path "gnucash/report/report-core")
+(load-from-path "gnucash/report/trep-engine")
+
+;; Report uuids used for the category barcharts
+
+(export category-barchart-income-uuid
+ category-barchart-expense-uuid
+ category-barchart-asset-uuid
+ category-barchart-liability-uuid)
+
+(define category-barchart-income-uuid "44f81bee049b4b3ea908f8dac9a9474e")
+(define category-barchart-expense-uuid "b1f15b2052c149df93e698fe85a81ea6")
+(define category-barchart-asset-uuid "e9cf815f79db44bcb637d0295093ae3d")
+(define category-barchart-liability-uuid "faf410e8f8da481fbc09e4763da40bcc")
+
+(export report-module-loader)
+;; Given a list of module prefixes, load all guile modules with these prefixes
+;; This assumes the modules are located on the file system in a
+;; path matching the module prefix
+;; For example passing
+;; '('(gnucash report stylesheets) '(gnucash reports standard))
+;; will search for scm files in
+;; - <gnc-guile-dir>/gnucash/report/stylesheets
+;; - <gnc-guile-dir>/gnucash/reports/standard
+;; and try to load them.
+;; This function is non-recursive so it won't
+;; descend in subdirectories.
+(define (report-module-loader mod-prefix-list)
+
+ ;; Returns a list of files in a directory
+ ;;
+ ;; Param:
+ ;; dir - directory name
+ ;;
+ ;; Return value:
+ ;; list of files in the directory
+ (define (directory-files dir)
+ (cond
+ ((file-exists? dir)
+ (let ((dir-stream (opendir dir)))
+ (let loop ((fname (readdir dir-stream))
+ (acc '()))
+ (cond
+ ((eof-object? fname)
+ (closedir dir-stream)
+ acc)
+ (else
+ (loop (readdir dir-stream)
+ (if (string-suffix? ".scm" fname)
+ (cons (string-drop-right fname 4) acc)
+ acc)))))))
+ (else
+ (gnc:warn "Can't access " dir ".\nEmpty list will be returned.")
+ '())))
+
+ ;; Return a list of symbols representing modules in the directory
+ ;; matching the prefix
+ ;;
+ ;; Return value:
+ ;; List of symbols for modules
+ (define (get-module-list mod-prefix)
+ (let* ((subdir (string-join (map symbol->string mod-prefix) "/"))
+ (mod-dir (gnc-build-scm-path subdir))
+ (mod-list (directory-files mod-dir)))
+ (gnc:debug "rpt-subdir=" subdir)
+ (gnc:debug "mod-dir=" mod-dir)
+ (gnc:debug "dir-files=" mod-list)
+ (map string->symbol mod-list)))
+
+ (for-each
+ (lambda (mod-prefix)
+ (for-each
+ (lambda (mod-file)
+ (let* ((module (append mod-prefix (list mod-file))))
+ (module-use!
+ (current-module)
+ (resolve-interface module))))
+ (get-module-list mod-prefix)))
+ mod-prefix-list))
+
+;; Add hooks when this module is loaded
+(gnc-hook-add-scm-dangler HOOK-SAVE-OPTIONS gnc:save-style-sheet-options)
diff --cc gnucash/report/reports/standard/advanced-portfolio.scm
index 5568b2bb4,000000000..279fcb91f
mode 100644,000000..100644
--- a/gnucash/report/reports/standard/advanced-portfolio.scm
+++ b/gnucash/report/reports/standard/advanced-portfolio.scm
@@@ -1,1221 -1,0 +1,1215 @@@
+;; -*-scheme-*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; advanced-portfolio.scm
+;; by Martijn van Oosterhout (kleptog at svana.org) Feb 2002
+;; modified for GnuCash 1.8 by Herbert Thoma (herbie at hthoma.de) Oct 2002
+;;
+;; Heavily based on portfolio.scm
+;; by Robert Merkel (rgmerk at mira.net)
+;;
+;; 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 at gnu.org
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (gnucash reports standard advanced-portfolio))
+
+(use-modules (gnucash engine))
+(use-modules (gnucash utilities))
+(use-modules (gnucash core-utils))
+(use-modules (gnucash app-utils))
+(use-modules (gnucash report))
+(use-modules (srfi srfi-1))
+
+(define reportname (N_ "Advanced Portfolio"))
+
+(define optname-price-source (N_ "Price Source"))
+(define optname-shares-digits (N_ "Share decimal places"))
+(define optname-zero-shares (N_ "Include accounts with no shares"))
+(define optname-show-symbol (N_ "Show ticker symbols"))
+(define optname-show-listing (N_ "Show listings"))
+(define optname-show-price (N_ "Show prices"))
+(define optname-show-shares (N_ "Show number of shares"))
+(define optname-basis-method (N_ "Basis calculation method"))
+(define optname-prefer-pricelist (N_ "Set preference for price list data"))
+(define optname-brokerage-fees (N_ "How to report brokerage fees"))
+
+(define OVERFLOW-ERROR "<h3>Error</h3>There is an error processing the
+transaction '~a'. This may to be caused by a sell transaction causing
+a negative stock balance, and a subsequent buy transaction causing a
+zero balance. This leads to a division-by-zero error. It can be fixed
+by preventing negative stock balances.<br/>")
+
+;; To avoid overflows in our calculations, define a denominator for prices and unit values
+(define price-denom 100000000)
+(define units-denom 100000000)
+
+(define (options-generator)
+ (let* ((options (gnc:new-options))
+ ;; This is just a helper function for making options.
+ ;; See libgnucash/scm/options.scm for details.
+ (add-option
+ (lambda (new-option)
+ (gnc:register-option options new-option))))
+
+ ;; General Tab
+ ;; date at which to report balance
+ (gnc:options-add-report-date!
+ options gnc:pagename-general
+ (N_ "Date") "a")
+
+ (gnc:options-add-currency!
+ options gnc:pagename-general (N_ "Report's currency") "c")
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-price-source
+ "d" (N_ "The source of price information.") 'pricedb-nearest
+ (list (vector 'pricedb-latest
+ (N_ "Most recent")
+ (N_ "The most recent recorded price."))
+ (vector 'pricedb-nearest
+ (N_ "Nearest in time")
+ (N_ "The price recorded nearest in time to the report date."))
+ )))
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-basis-method
+ "e" (N_ "Basis calculation method.") 'average-basis
+ (list (vector 'average-basis
+ (N_ "Average")
+ (N_ "Use average cost of all shares for basis."))
+ (vector 'fifo-basis
+ (N_ "FIFO")
+ (N_ "Use first-in first-out method for basis."))
+ (vector 'filo-basis
+ (N_ "LIFO")
+ (N_ "Use last-in first-out method for basis."))
+ )))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-prefer-pricelist "f"
+ (N_ "Prefer use of price editor pricing over transactions, where applicable.")
+ #t))
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-brokerage-fees
+ "g" (N_ "How to report commissions and other brokerage fees.") 'include-in-basis
+ (list (vector 'include-in-basis
+ (N_ "Include in basis")
+ (N_ "Include brokerage fees in the basis for the asset."))
+ (vector 'include-in-gain
+ (N_ "Include in gain")
+ (N_ "Include brokerage fees in the gain and loss but not in the basis."))
+ (vector 'ignore-brokerage
+ (N_ "Ignore")
+ (N_ "Ignore brokerage fees entirely."))
+ )))
+
+ (gnc:register-option
+ options
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-show-symbol "a"
+ (N_ "Display the ticker symbols.")
+ #t))
+
+ (gnc:register-option
+ options
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-show-listing "b"
+ (N_ "Display exchange listings.")
+ #t))
+
+ (gnc:register-option
+ options
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-show-shares "c"
+ (N_ "Display numbers of shares in accounts.")
+ #t))
+
+ (add-option
+ (gnc:make-number-range-option
+ gnc:pagename-display optname-shares-digits
+ "d" (N_ "The number of decimal places to use for share numbers.") 2
+ 0 6 0 1))
+
+ (gnc:register-option
+ options
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-show-price "e"
+ (N_ "Display share prices.")
+ #t))
+
+ ;; Account tab
+ (add-option
+ (gnc:make-account-list-option
+ gnc:pagename-accounts (N_ "Accounts")
+ "b"
+ (N_ "Stock Accounts to report on.")
+ (lambda () (filter gnc:account-is-stock?
+ (gnc-account-get-descendants-sorted
+ (gnc-get-current-root-account))))
+ (lambda (accounts) (list #t
+ (filter gnc:account-is-stock? accounts)))
+ #t))
+
+ (gnc:register-option
+ options
+ (gnc:make-simple-boolean-option
+ gnc:pagename-accounts optname-zero-shares "e"
+ (N_ "Include accounts that have a zero share balances.")
+ #f))
+
+ (gnc:options-set-default-section options gnc:pagename-general)
+ options))
+
+;; This is the rendering function. It accepts a database of options
+;; and generates an object of type <html-document>. See the file
+;; report-html.txt for documentation; the file report-html.scm
+;; includes all the relevant Scheme code. The option database passed
+;; to the function is one created by the options-generator function
+;; defined above.
+
+(define (advanced-portfolio-renderer report-obj)
+
+ (let ((work-done 0)
+ (work-to-do 0)
+ (warn-no-price #f)
+ (warn-price-dirty #f))
+
+ ;; These are some helper functions for looking up option values.
+ (define (get-op section name)
+ (gnc:lookup-option (gnc:report-options report-obj) section name))
+
+ (define (get-option section name)
+ (gnc:option-value (get-op section name)))
+
+ (define (split-account-type? split type)
+ (eq? type (xaccAccountGetType (xaccSplitGetAccount split))))
+
+ (define (same-split? s1 s2)
+ (equal? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
+
+ (define (same-account? a1 a2)
+ (equal? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
+
+ ;; sum up the contents of the b-list built by basis-builder below
+ (define (sum-basis b-list currency-frac)
+ (if (not (eqv? b-list '()))
+ (gnc-numeric-add (gnc-numeric-mul (caar b-list) (cdar b-list) currency-frac GNC-RND-ROUND)
+ (sum-basis (cdr b-list) currency-frac) currency-frac GNC-RND-ROUND)
+ (gnc-numeric-zero)
+ )
+ )
+
+ ;; sum up the total number of units in the b-list built by basis-builder below
+ (define (units-basis b-list)
+ (if (not (eqv? b-list '()))
+ (gnc-numeric-add (caar b-list) (units-basis (cdr b-list))
+ units-denom GNC-RND-ROUND)
+ (gnc-numeric-zero)
+ )
+ )
+
+ ;; apply a ratio to an existing basis-list, useful for splits/mergers and spinoffs
+ ;; I need to get a brain and use (map) for this.
+ (define (apply-basis-ratio b-list units-ratio value-ratio)
+ (if (not (eqv? b-list '()))
+ (cons (cons (gnc-numeric-mul units-ratio (caar b-list) units-denom GNC-RND-ROUND)
+ (gnc-numeric-mul value-ratio (cdar b-list) price-denom GNC-RND-ROUND))
+ (apply-basis-ratio (cdr b-list) units-ratio value-ratio))
+ '()
+ )
+ )
+
+ ;; this builds a list for basis calculation and handles average, fifo and lifo methods
+ ;; the list is cons cells of (units-of-stock . price-per-unit)... average method produces only one
+ ;; cell that mutates to the new average. Need to add a date checker so that we allow for prices
+ ;; coming in out of order, such as a transfer with a price adjusted to carryover the basis.
+ (define (basis-builder b-list b-units b-value b-method currency-frac)
+ (gnc:debug "actually in basis-builder")
+ (gnc:debug "b-list is " b-list " b-units is " (gnc-numeric-to-string b-units)
+ " b-value is " (gnc-numeric-to-string b-value) " b-method is " b-method)
+
+ ;; if there is no b-value, then this is a split/merger and needs special handling
+ (cond
+
+ ;; we have value and positive units, add units to basis
+ ((and (not (gnc-numeric-zero-p b-value))
+ (gnc-numeric-positive-p b-units))
+ (case b-method
+ ((average-basis)
+ (if (not (eqv? b-list '()))
+ (list (cons (gnc-numeric-add b-units
+ (caar b-list) units-denom GNC-RND-ROUND)
+ (gnc-numeric-div
+ (gnc-numeric-add b-value
+ (gnc-numeric-mul (caar b-list)
+ (cdar b-list)
+ GNC-DENOM-AUTO GNC-DENOM-REDUCE)
+ GNC-DENOM-AUTO GNC-DENOM-REDUCE)
+ (let ((denom (gnc-numeric-add b-units
+ (caar b-list) GNC-DENOM-AUTO GNC-DENOM-REDUCE)))
+ (if (zero? denom)
+ (throw 'div/0 (format #f "buying ~0,4f share units" b-units))
+ denom))
+ price-denom GNC-RND-ROUND)))
+ (append b-list
+ (list (cons b-units (gnc-numeric-div
+ b-value b-units price-denom GNC-RND-ROUND))))))
+ (else (append b-list
+ (list (cons b-units (gnc-numeric-div
+ b-value b-units price-denom GNC-RND-ROUND)))))))
+
+ ;; we have value and negative units, remove units from basis
+ ((and (not (gnc-numeric-zero-p b-value))
+ (gnc-numeric-negative-p b-units))
+ (if (not (eqv? b-list '()))
+ (case b-method
+ ((fifo-basis)
+ (case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar b-list))
+ ((-1)
+ ;; Sold less than the first lot, create a new first lot from the remainder
+ (let ((new-units (gnc-numeric-add b-units (caar b-list) units-denom GNC-RND-ROUND)))
+ (cons (cons new-units (cdar b-list)) (cdr b-list))))
+ ((0)
+ ;; Sold all of the first lot
+ (cdr b-list))
+ ((1)
+ ;; Sold more than the first lot, delete it and recurse
+ (basis-builder (cdr b-list) (gnc-numeric-add b-units (caar b-list) units-denom GNC-RND-ROUND)
+ b-value ;; Only the sign of b-value matters since the new b-units is negative
+ b-method currency-frac))))
+ ((filo-basis)
+ (let ((rev-b-list (reverse b-list)))
+ (case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar rev-b-list))
+ ((-1)
+ ;; Sold less than the last lot
+ (let ((new-units (gnc-numeric-add b-units (caar rev-b-list) units-denom GNC-RND-ROUND)))
+ (reverse (cons (cons new-units (cdar rev-b-list)) (cdr rev-b-list)))))
+ ((0)
+ ;; Sold all of the last lot
+ (reverse (cdr rev-b-list))
+ )
+ ((1)
+ ;; Sold more than the last lot
+ (basis-builder (reverse (cdr rev-b-list)) (gnc-numeric-add b-units (caar rev-b-list) units-denom GNC-RND-ROUND)
+ b-value b-method currency-frac)
+ ))))
+ ((average-basis)
+ (list (cons (gnc-numeric-add
+ (caar b-list) b-units units-denom GNC-RND-ROUND)
+ (cdar b-list)))))
+ '()
+ ))
+
+ ;; no value, just units, this is a split/merge...
+ ((and (gnc-numeric-zero-p b-value)
+ (not (gnc-numeric-zero-p b-units)))
+ (let* ((current-units (units-basis b-list))
+ ;; If current-units is zero then so should be everything else.
+ (units-ratio (if (zero? current-units) (gnc-numeric-zero)
+ (gnc-numeric-div (gnc-numeric-add b-units current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE)
+ current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE)))
+ ;; If the units ratio is zero the stock is worthless and the value should be zero too
+ (value-ratio (if (gnc-numeric-zero-p units-ratio)
+ (gnc-numeric-zero)
+ (gnc-numeric-div 1/1 units-ratio GNC-DENOM-AUTO GNC-DENOM-REDUCE))))
+
+ (gnc:debug "blist is " b-list " current units is "
+ (gnc-numeric-to-string current-units)
+ " value ratio is " (gnc-numeric-to-string value-ratio)
+ " units ratio is " (gnc-numeric-to-string units-ratio))
+ (apply-basis-ratio b-list units-ratio value-ratio)
+ ))
+
+ ;; If there are no units, just a value, then its a spin-off,
+ ;; calculate a ratio for the values, but leave the units alone
+ ;; with a ratio of 1
+ ((and (gnc-numeric-zero-p b-units)
+ (not (gnc-numeric-zero-p b-value)))
+ (let* ((current-value (sum-basis b-list GNC-DENOM-AUTO))
+ (value-ratio (if (zero? current-value)
+ (throw 'div/0 (format #f "spinoff of ~,2f currency units" current-value))
+ (gnc-numeric-div (gnc-numeric-add b-value current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE)
+ current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE))))
+
+ (gnc:debug "this is a spinoff")
+ (gnc:debug "blist is " b-list " value ratio is " (gnc-numeric-to-string value-ratio))
+ (apply-basis-ratio b-list 1/1 value-ratio))
+ )
+
+ ;; when all else fails, just send the b-list back
+ (else
+ b-list)
+ )
+ )
+
+ ;; Given a price list and a currency find the price for that currency on the list.
+ ;; If there is none for the requested currency, return the first one.
+ ;; The price list is released but the price returned is ref counted.
+ (define (find-price price-list currency)
+ (if (eqv? price-list '()) #f
+ (let ((price (car price-list)))
+ (for-each
+ (lambda (p)
+ (if (gnc-commodity-equiv currency (gnc-price-get-currency p))
+ (set! price p))
+ (if (gnc-commodity-equiv currency (gnc-price-get-commodity p))
+ (set! price (gnc-price-invert p))))
+ price-list)
+ (gnc-price-ref price)
+ (gnc-price-list-destroy price-list)
+ price)))
+
+ ;; Return true if either account is the parent of the other or they are siblings
+ (define (parent-or-sibling? a1 a2)
+ (let ((a2parent (gnc-account-get-parent a2))
+ (a1parent (gnc-account-get-parent a1)))
+ (or (same-account? a2parent a1)
+ (same-account? a1parent a2)
+ (same-account? a1parent a2parent))))
+
+ ;; Test whether the given split is the source of a spin off transaction
+ ;; This will be a no-units split with only one other split.
+ ;; xaccSplitGetOtherSplit only returns on a two-split txn. It's not a spinoff
+ ;; is the other split is in an income or expense account.
+ (define (spin-off? split current)
+ (let ((other-split (xaccSplitGetOtherSplit split)))
+ (and (gnc-numeric-zero-p (xaccSplitGetAmount split))
+ (same-account? current (xaccSplitGetAccount split))
+ (not (null? other-split))
+ (not (split-account-type? other-split ACCT-TYPE-EXPENSE))
+ (not (split-account-type? other-split ACCT-TYPE-INCOME)))))
+
+
+(define (table-add-stock-rows table accounts to-date
+ currency price-fn exchange-fn price-source
+ include-empty show-symbol show-listing show-shares show-price
+ basis-method prefer-pricelist handle-brokerage-fees
+ total-basis total-value
+ total-moneyin total-moneyout total-income total-gain
+ total-ugain total-brokerage)
+
+ (let ((share-print-info
+ (gnc-share-print-info-places
+ (inexact->exact (get-option gnc:pagename-display
+ optname-shares-digits)))))
+
+ (define (table-add-stock-rows-internal accounts odd-row?)
+ (if (null? accounts) total-value
+ (let* ((row-style (if odd-row? "normal-row" "alternate-row"))
+ (current (car accounts))
+ (rest (cdr accounts))
+ ;; commodity is the actual stock/thing we are looking at
+ (commodity (xaccAccountGetCommodity current))
+ (ticker-symbol (gnc-commodity-get-mnemonic commodity))
+ (listing (gnc-commodity-get-namespace commodity))
+ (unit-collector (gnc:account-get-comm-balance-at-date
+ current to-date #f))
+ (units (cadr (unit-collector 'getpair commodity #f)))
+
+ ;; Counter to keep track of stuff
+ (brokeragecoll (gnc:make-commodity-collector))
+ (dividendcoll (gnc:make-commodity-collector))
+ (moneyincoll (gnc:make-commodity-collector))
+ (moneyoutcoll (gnc:make-commodity-collector))
+ (gaincoll (gnc:make-commodity-collector))
+
+
+ ;; the price of the commodity at the time of the report
+ (price (price-fn commodity currency to-date))
+ ;; the value of the commodity, expressed in terms of
+ ;; the report's currency.
+ (value (gnc:make-gnc-monetary currency (gnc-numeric-zero))) ;; Set later
+ (currency-frac (gnc-commodity-get-fraction currency))
+
+ (pricing-txn #f)
+ (use-txn #f)
+ (basis-list '())
+ ;; setup an alist for the splits we've already seen.
+ (seen_trans '())
+ ;; Account used to hold remainders from income reinvestments and
+ ;; running total of amount moved there
+ (drp-holding-account #f)
+ (drp-holding-amount (gnc-numeric-zero))
+ )
+
+ (define (my-exchange-fn fromunits tocurrency)
+ (if (and (gnc-commodity-equiv currency tocurrency)
+ (gnc-commodity-equiv (gnc:gnc-monetary-commodity fromunits) commodity))
+ ;; Have a price for this commodity, but not necessarily in the report's
+ ;; currency. Get the value in the commodity's currency and convert it to
+ ;; report currency.
+ (exchange-fn
+ ;; This currency will usually be the same as tocurrency so the
+ ;; call to exchange-fn below will do nothing
+ (gnc:make-gnc-monetary
+ (if use-txn
+ (gnc:gnc-monetary-commodity price)
+ (gnc-price-get-currency price))
+ (gnc-numeric-mul (gnc:gnc-monetary-amount fromunits)
+ (if use-txn
+ (gnc:gnc-monetary-amount price)
+ (gnc-price-get-value price))
+ currency-frac GNC-RND-ROUND))
+ tocurrency)
+ (exchange-fn fromunits tocurrency)))
+
+ (gnc:debug "Starting account " (xaccAccountGetName current) ", initial price: "
+ (and price
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary
+ (gnc-price-get-currency price) (gnc-price-get-value price)))))
+
+ ;; If we have a price that can't be converted to the report currency
+ ;; don't use it
+ (if (and price (gnc-numeric-zero-p (gnc:gnc-monetary-amount
+ (exchange-fn
+ (gnc:make-gnc-monetary
+ (gnc-price-get-currency price)
+ 100/1)
+ currency))))
+ (set! price #f))
+
+ ;; If we are told to use a pricing transaction, or if we don't have a price
+ ;; from the price DB, find a good transaction to use.
+ (if (and (not use-txn)
+ (or (not price) (not prefer-pricelist)))
+ (let ((split-list (reverse (gnc:get-match-commodity-splits-sorted
+ (list current)
+ (case price-source
+ ((pricedb-latest) (gnc:get-today))
+ ((pricedb-nearest) to-date)
+ (else (gnc:get-today))) ;; error, but don't crash
+ #f)))) ;; Any currency
+ ;; Find the first (most recent) one that can be converted to report currency
+ (while (and (not use-txn) (not (eqv? split-list '())))
+ (let ((split (car split-list)))
+ (if (and (not (gnc-numeric-zero-p (xaccSplitGetAmount split)))
+ (not (gnc-numeric-zero-p (xaccSplitGetValue split))))
+ (let* ((trans (xaccSplitGetParent split))
+ (trans-currency (xaccTransGetCurrency trans))
+ (trans-price (exchange-fn (gnc:make-gnc-monetary
+ trans-currency
+ (xaccSplitGetSharePrice split))
+ currency)))
+ (if (not (gnc-numeric-zero-p (gnc:gnc-monetary-amount trans-price)))
+ ;; We can exchange the price from this transaction into the report currency
+ (begin
+ (if price (gnc-price-unref price))
+ (set! pricing-txn trans)
+ (set! price trans-price)
+ (gnc:debug "Transaction price is " (gnc:monetary->string price))
+ (set! use-txn #t))
+ (set! split-list (cdr split-list))))
+ (set! split-list (cdr split-list)))
+ ))))
+
+ ;; If we still don't have a price, use a price of 1 and complain later
+ (if (not price)
+ (begin
+ (set! price (gnc:make-gnc-monetary currency 1/1))
+ ;; If use-txn is set, but pricing-txn isn't set, it's a bogus price
+ (set! use-txn #t)
+ (set! pricing-txn #f)
+ )
+ )
+
+ ;; Now that we have a pricing transaction if needed, set the value of the asset
+ (set! value (my-exchange-fn (gnc:make-gnc-monetary commodity units) currency))
+ (gnc:debug "Value " (gnc:monetary->string value)
+ " from " (gnc:monetary->string
+ (gnc:make-gnc-monetary commodity units)))
+
+ (for-each
+ ;; we're looking at each split we find in the account. these splits
+ ;; could refer to the same transaction, so we have to examine each
+ ;; split, determine what kind of split it is and then act accordingly.
+ (lambda (split)
+ (set! work-done (+ 1 work-done))
+ (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
+
+ (let* ((parent (xaccSplitGetParent split))
+ (txn-date (xaccTransGetDate parent))
+ (commod-currency (xaccTransGetCurrency parent))
+ (commod-currency-frac (gnc-commodity-get-fraction commod-currency)))
+
+ (if (and (<= txn-date to-date)
+ (not (assoc-ref seen_trans (gncTransGetGUID parent))))
+ (let ((trans-income (gnc-numeric-zero))
+ (trans-brokerage (gnc-numeric-zero))
+ (trans-shares (gnc-numeric-zero))
+ (shares-bought (gnc-numeric-zero))
+ (trans-sold (gnc-numeric-zero))
+ (trans-bought (gnc-numeric-zero))
+ (trans-spinoff (gnc-numeric-zero))
+ (trans-drp-residual (gnc-numeric-zero))
+ (trans-drp-account #f))
+
+ (gnc:debug "Transaction " (xaccTransGetDescription parent))
+ ;; Add this transaction to the list of processed transactions so we don't
+ ;; do it again if there is another split in it for this account
+ (set! seen_trans (acons (gncTransGetGUID parent) #t seen_trans))
+
+ ;; Go through all the splits in the transaction to get an overall idea of
+ ;; what it does in terms of income, money in or out, shares bought or sold, etc.
+ (for-each
+ (lambda (s)
+ (let ((split-units (xaccSplitGetAmount s))
+ (split-value (xaccSplitGetValue s)))
+
+ (gnc:debug "Pass 1: split units " (gnc-numeric-to-string split-units) " split-value "
+ (gnc-numeric-to-string split-value) " commod-currency "
+ (gnc-commodity-get-printname commod-currency))
+
+ (cond
+ ((split-account-type? s ACCT-TYPE-EXPENSE)
+ ;; Brokerage expense unless a two split transaction with other split
+ ;; in the stock account in which case it's a stock donation to charity.
+ (if (not (same-account? current (xaccSplitGetAccount (xaccSplitGetOtherSplit s))))
+ (set! trans-brokerage
+ (gnc-numeric-add trans-brokerage split-value commod-currency-frac GNC-RND-ROUND))))
+
+ ((split-account-type? s ACCT-TYPE-INCOME)
+ (set! trans-income (gnc-numeric-sub trans-income split-value
+ commod-currency-frac GNC-RND-ROUND)))
+
+ ((same-account? current (xaccSplitGetAccount s))
+ (set! trans-shares (gnc-numeric-add trans-shares (gnc-numeric-abs split-units)
+ units-denom GNC-RND-ROUND))
+ (if (gnc-numeric-zero-p split-units)
+ (if (spin-off? s current)
+ ;; Count money used in a spin off as money out
+ (if (gnc-numeric-negative-p split-value)
+ (set! trans-spinoff (gnc-numeric-sub trans-spinoff split-value
+ commod-currency-frac GNC-RND-ROUND)))
+ (if (not (gnc-numeric-zero-p split-value))
+ ;; Gain/loss split (amount zero, value non-zero, and not spinoff). There will be
+ ;; a corresponding income split that will incorrectly be added to trans-income
+ ;; Fix that by subtracting it here
+ (set! trans-income (gnc-numeric-sub trans-income split-value
+ commod-currency-frac GNC-RND-ROUND))))
+ ;; Non-zero amount, add the value to the sale or purchase total.
+ (if (gnc-numeric-positive-p split-value)
+ (begin
+ (set! trans-bought
+ (gnc-numeric-add trans-bought split-value commod-currency-frac GNC-RND-ROUND))
+ (set! shares-bought
+ (gnc-numeric-add shares-bought split-units units-denom GNC-RND-ROUND)))
+ (set! trans-sold
+ (gnc-numeric-sub trans-sold split-value commod-currency-frac GNC-RND-ROUND)))))
+
+ ((split-account-type? s ACCT-TYPE-ASSET)
+ ;; If all the asset accounts mentioned in the transaction are siblings of each other
+ ;; keep track of the money transferred to them if it is in the correct currency
+ (if (not trans-drp-account)
+ (begin
+ (set! trans-drp-account (xaccSplitGetAccount s))
+ (if (gnc-commodity-equiv commod-currency (xaccAccountGetCommodity trans-drp-account))
+ (set! trans-drp-residual split-value)
+ (set! trans-drp-account 'none)))
+ (if (not (eq? trans-drp-account 'none))
+ (if (parent-or-sibling? trans-drp-account (xaccSplitGetAccount s))
+ (set! trans-drp-residual (gnc-numeric-add trans-drp-residual split-value
+ commod-currency-frac GNC-RND-ROUND))
+ (set! trans-drp-account 'none))))))
+ ))
+ (xaccTransGetSplitList parent)
+ )
+
+ (gnc:debug "Income: " (gnc-numeric-to-string trans-income)
+ " Brokerage: " (gnc-numeric-to-string trans-brokerage)
+ " Shares traded: " (gnc-numeric-to-string trans-shares)
+ " Shares bought: " (gnc-numeric-to-string shares-bought))
+ (gnc:debug " Value sold: " (gnc-numeric-to-string trans-sold)
+ " Value purchased: " (gnc-numeric-to-string trans-bought)
+ " Spinoff value " (gnc-numeric-to-string trans-spinoff)
+ " Trans DRP residual: " (gnc-numeric-to-string trans-drp-residual))
+
+ ;; We need to calculate several things for this transaction:
+ ;; 1. Total income: this is already in trans-income
+ ;; 2. Change in basis: calculated by loop below that looks at every
+ ;; that acquires or disposes of shares
+ ;; 3. Realized gain: also calculated below while calculating basis
+ ;; 4. Money in to the account: this is the value of shares bought
+ ;; except those purchased with reinvested income
+ ;; 5. Money out: the money received by disposing of shares. This
+ ;; is in trans-sold plus trans-spinoff
+ ;; 6. Brokerage fees: this is in trans-brokerage
+
+ ;; Income
+ (dividendcoll 'add commod-currency trans-income)
+
+ ;; Brokerage fees. May be either ignored or part of basis, but that
+ ;; will be dealt with elsewhere.
+ (brokeragecoll 'add commod-currency trans-brokerage)
+
+ ;; Add brokerage fees to trans-bought if not ignoring them and there are any
+ (if (and (not (eq? handle-brokerage-fees 'ignore-brokerage))
+ (gnc-numeric-positive-p trans-brokerage)
+ (gnc-numeric-positive-p trans-shares))
+ (let* ((fee-frac (gnc-numeric-div shares-bought trans-shares GNC-DENOM-AUTO GNC-DENOM-REDUCE))
+ (fees (gnc-numeric-mul trans-brokerage fee-frac commod-currency-frac GNC-RND-ROUND)))
+ (set! trans-bought (gnc-numeric-add trans-bought fees commod-currency-frac GNC-RND-ROUND))))
+
+ ;; Update the running total of the money in the DRP residual account. This is relevant
+ ;; if this is a reinvestment transaction (both income and purchase) and there seems to
+ ;; asset accounts used to hold excess income.
+ (if (and trans-drp-account
+ (not (eq? trans-drp-account 'none))
+ (gnc-numeric-positive-p trans-income)
+ (gnc-numeric-positive-p trans-bought))
+ (if (not drp-holding-account)
+ (begin
+ (set! drp-holding-account trans-drp-account)
+ (set! drp-holding-amount trans-drp-residual))
+ (if (and (not (eq? drp-holding-account 'none))
+ (parent-or-sibling? trans-drp-account drp-holding-account))
+ (set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-drp-residual
+ commod-currency-frac GNC-RND-ROUND))
+ (begin
+ ;; Wrong account (or no account), assume there isn't a DRP holding account
+ (set! drp-holding-account 'none)
+ (set trans-drp-residual (gnc-numeric-zero))
+ (set! drp-holding-amount (gnc-numeric-zero))))))
+
+ ;; Set trans-bought to the amount of money moved in to the account which was used to
+ ;; purchase more shares. If this is not a DRP transaction then all money used to purchase
+ ;; shares is money in.
+ (if (and (gnc-numeric-positive-p trans-income)
+ (gnc-numeric-positive-p trans-bought))
+ (begin
+ (set! trans-bought (gnc-numeric-sub trans-bought trans-income
+ commod-currency-frac GNC-RND-ROUND))
+ (set! trans-bought (gnc-numeric-add trans-bought trans-drp-residual
+ commod-currency-frac GNC-RND-ROUND))
+ (set! trans-bought (gnc-numeric-sub trans-bought drp-holding-amount
+ commod-currency-frac GNC-RND-ROUND))
+ ;; If the DRP holding account balance is negative, adjust it by the amount
+ ;; used in this transaction
+ (if (and (gnc-numeric-negative-p drp-holding-amount)
+ (gnc-numeric-positive-p trans-bought))
+ (set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-bought
+ commod-currency-frac GNC-RND-ROUND)))
+ ;; Money in is never more than amount spent to purchase shares
+ (if (gnc-numeric-negative-p trans-bought)
+ (set! trans-bought (gnc-numeric-zero)))))
+
+ (gnc:debug "Adjusted trans-bought " (gnc-numeric-to-string trans-bought)
+ " DRP holding account " (gnc-numeric-to-string drp-holding-amount))
+
+ (moneyincoll 'add commod-currency trans-bought)
+ (moneyoutcoll 'add commod-currency trans-sold)
+ (moneyoutcoll 'add commod-currency trans-spinoff)
+
+ ;; Look at splits again to handle changes in basis and realized gains
+ (for-each
+ (lambda (s)
+ (let
+ ;; get the split's units and value
+ ((split-units (xaccSplitGetAmount s))
+ (split-value (xaccSplitGetValue s)))
+
+ (gnc:debug "Pass 2: split units " (gnc-numeric-to-string split-units) " split-value "
+ (gnc-numeric-to-string split-value) " commod-currency "
+ (gnc-commodity-get-printname commod-currency))
+
+ (cond
+ ((and (not (gnc-numeric-zero-p split-units))
+ (same-account? current (xaccSplitGetAccount s)))
+ ;; Split into subject account with non-zero amount. This is a purchase
+ ;; or a sale, adjust the basis
+ (let* ((split-value-currency (gnc:gnc-monetary-amount
+ (my-exchange-fn (gnc:make-gnc-monetary
+ commod-currency split-value) currency)))
+ (orig-basis (sum-basis basis-list currency-frac))
+ ;; proportion of the fees attributable to this split
+ (fee-ratio (gnc-numeric-div (gnc-numeric-abs split-units) trans-shares
+ GNC-DENOM-AUTO GNC-DENOM-REDUCE))
+ ;; Fees for this split in report currency
+ (fees-currency (gnc:gnc-monetary-amount (my-exchange-fn
+ (gnc:make-gnc-monetary commod-currency
+ (gnc-numeric-mul fee-ratio trans-brokerage
+ commod-currency-frac GNC-RND-ROUND))
+ currency)))
+ (split-value-with-fees (if (eq? handle-brokerage-fees 'include-in-basis)
+ ;; Include brokerage fees in basis
+ (gnc-numeric-add split-value-currency fees-currency
+ currency-frac GNC-RND-ROUND)
+ split-value-currency)))
+ (gnc:debug "going in to basis list " basis-list " " (gnc-numeric-to-string split-units) " "
+ (gnc-numeric-to-string split-value-with-fees))
+
+ ;; adjust the basis
+ (set! basis-list (basis-builder basis-list split-units split-value-with-fees
+ basis-method currency-frac))
+ (gnc:debug "coming out of basis list " basis-list)
+
+ ;; If it's a sale or the stock is worthless, calculate the gain
+ (if (not (gnc-numeric-positive-p split-value))
+ ;; Split value is zero or negative. If it's zero it's either a stock split/merge
+ ;; or the stock has become worthless (which looks like a merge where the number
+ ;; of shares goes to zero). If the value is negative then it's a disposal of some sort.
+ (let ((new-basis (sum-basis basis-list currency-frac)))
+ (if (or (gnc-numeric-zero-p new-basis)
+ (gnc-numeric-negative-p split-value))
+ ;; Split value is negative or new basis is zero (stock is worthless),
+ ;; Capital gain is money out minus change in basis
+ (let ((gain (gnc-numeric-sub (gnc-numeric-abs split-value-with-fees)
+ (gnc-numeric-sub orig-basis new-basis
+ currency-frac GNC-RND-ROUND)
+ currency-frac GNC-RND-ROUND)))
+ (gnc:debug "Old basis=" (gnc-numeric-to-string orig-basis)
+ " New basis=" (gnc-numeric-to-string new-basis)
+ " Gain=" (gnc-numeric-to-string gain))
+ (gaincoll 'add currency gain)))))))
+
+ ;; here is where we handle a spin-off txn. This will be a no-units
+ ;; split with only one other split. xaccSplitGetOtherSplit only
+ ;; returns on a two-split txn. It's not a spinoff is the other split is
+ ;; in an income or expense account.
+ ((spin-off? s current)
+ (gnc:debug "before spin-off basis list " basis-list)
+ (set! basis-list (basis-builder basis-list split-units (gnc:gnc-monetary-amount
+ (my-exchange-fn (gnc:make-gnc-monetary
+ commod-currency split-value)
+ currency))
+ basis-method
+ currency-frac))
+ (gnc:debug "after spin-off basis list " basis-list))
+ )
+ ))
+ (xaccTransGetSplitList parent)
+ )
+ )
+ )
+ )
+ )
+ (xaccAccountGetSplitList current)
+ )
+
+ ;; Look for income and expense transactions that don't have a split in the
+ ;; the account we're processing. We do this as follow
+ ;; 1. Make sure the parent account is a currency-valued asset or bank account
+ ;; 2. If so go through all the splits in that account
+ ;; 3. If a split is part of a two split transaction where the other split is
+ ;; to an income or expense account and the leaf name of that account is the
+ ;; same as the leaf name of the account we're processing, add it to the
+ ;; income or expense accumulator
+ ;;
+ ;; In other words with an account structure like
+ ;;
+ ;; Assets (type ASSET)
+ ;; Broker (type ASSET)
+ ;; Widget Stock (type STOCK)
+ ;; Income (type INCOME)
+ ;; Dividends (type INCOME)
+ ;; Widget Stock (type INCOME)
+ ;;
+ ;; If you are producing a report on "Assets:Broker:Widget Stock" a
+ ;; transaction that debits the Assets:Broker account and credits the
+ ;; "Income:Dividends:Widget Stock" account will count as income in
+ ;; the report even though it doesn't have a split in the account
+ ;; being reported on.
+
+ (let ((parent-account (gnc-account-get-parent current))
+ (account-name (xaccAccountGetName current)))
+ (if (and (not (null? parent-account))
+ (member (xaccAccountGetType parent-account) (list ACCT-TYPE-ASSET ACCT-TYPE-BANK))
+ (gnc-commodity-is-currency (xaccAccountGetCommodity parent-account)))
+ (for-each
+ (lambda (split)
+ (let* ((other-split (xaccSplitGetOtherSplit split))
+ ;; This is safe because xaccSplitGetAccount returns null for a null split
+ (other-acct (xaccSplitGetAccount other-split))
+ (parent (xaccSplitGetParent split))
+ (txn-date (xaccTransGetDate parent)))
+ (if (and (not (null? other-acct))
+ (<= txn-date to-date)
+ (string=? (xaccAccountGetName other-acct) account-name)
+ (gnc-commodity-is-currency (xaccAccountGetCommodity other-acct)))
+ ;; This is a two split transaction where the other split is to an
+ ;; account with the same name as the current account. If it's an
+ ;; income or expense account accumulate the value of the transaction
+ (let ((val (xaccSplitGetValue split))
+ (curr (xaccAccountGetCommodity other-acct)))
+ (cond ((split-account-type? other-split ACCT-TYPE-INCOME)
+ (gnc:debug "More income " (gnc-numeric-to-string val))
+ (dividendcoll 'add curr val))
+ ((split-account-type? other-split ACCT-TYPE-EXPENSE)
+ (gnc:debug "More expense " (gnc-numeric-to-string
+ (gnc-numeric-neg val)))
+ (brokeragecoll 'add curr (gnc-numeric-neg val)))
+ )
+ )
+ )
+ )
+ )
+ (xaccAccountGetSplitList parent-account)
+ )
+ )
+ )
+
+ (gnc:debug "pricing txn is " pricing-txn)
+ (gnc:debug "use txn is " use-txn)
+ (gnc:debug "prefer-pricelist is " prefer-pricelist)
+ (gnc:debug "price is " price)
+
+ (gnc:debug "basis we're using to build rows is " (gnc-numeric-to-string (sum-basis basis-list
+ currency-frac)))
+ (gnc:debug "but the actual basis list is " basis-list)
+
+ (if (eq? handle-brokerage-fees 'include-in-gain)
+ (gaincoll 'minusmerge brokeragecoll #f))
+
+ (if (or include-empty (not (gnc-numeric-zero-p units)))
+ (let* ((moneyin (gnc:sum-collector-commodity moneyincoll currency my-exchange-fn))
+ (moneyout (gnc:sum-collector-commodity moneyoutcoll currency my-exchange-fn))
+ (brokerage (gnc:sum-collector-commodity brokeragecoll currency my-exchange-fn))
+ (income (gnc:sum-collector-commodity dividendcoll currency my-exchange-fn))
+ ;; just so you know, gain == realized gain, ugain == un-realized gain, bothgain, well..
+ (gain (gnc:sum-collector-commodity gaincoll currency my-exchange-fn))
+ (ugain (gnc:make-gnc-monetary currency
+ (gnc-numeric-sub (gnc:gnc-monetary-amount (my-exchange-fn value currency))
+ (sum-basis basis-list (gnc-commodity-get-fraction currency))
+ currency-frac GNC-RND-ROUND)))
+ (bothgain (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount gain)
+ (gnc:gnc-monetary-amount ugain)
+ currency-frac GNC-RND-ROUND)))
+ (totalreturn (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount bothgain)
+ (gnc:gnc-monetary-amount income)
+ currency-frac GNC-RND-ROUND)))
+
+ (activecols (list (gnc:html-account-anchor current)))
+ )
+
+ ;; If we're using the txn, warn the user
+ (if use-txn
+ (if pricing-txn
+ (set! warn-price-dirty #t)
+ (set! warn-no-price #t)
+ ))
+
+ (total-value 'add (gnc:gnc-monetary-commodity value) (gnc:gnc-monetary-amount value))
+ (total-moneyin 'merge moneyincoll #f)
+ (total-moneyout 'merge moneyoutcoll #f)
+ (total-brokerage 'merge brokeragecoll #f)
+ (total-income 'merge dividendcoll #f)
+ (total-gain 'merge gaincoll #f)
+ (total-ugain 'add (gnc:gnc-monetary-commodity ugain) (gnc:gnc-monetary-amount ugain))
+ (total-basis 'add currency (sum-basis basis-list currency-frac))
+
+ ;; build a list for the row based on user selections
+ (if show-symbol (append! activecols (list (gnc:make-html-table-header-cell/markup "text-cell" ticker-symbol))))
+ (if show-listing (append! activecols (list (gnc:make-html-table-header-cell/markup "text-cell" listing))))
+ (if show-shares (append! activecols (list (gnc:make-html-table-header-cell/markup
+ "number-cell" (xaccPrintAmount units share-print-info)))))
+ (if show-price (append! activecols (list (gnc:make-html-table-header-cell/markup
+ "number-cell"
+ (if use-txn
+ (if pricing-txn
- (gnc:html-transaction-anchor
- pricing-txn
- price
- )
- price
- )
++ (gnc:html-transaction-anchor pricing-txn price)
++ price)
+ (gnc:html-price-anchor
- price
- (gnc:make-gnc-monetary
- (gnc-price-get-currency price)
- (gnc-price-get-value price)))
- )))))
++ price (gnc:default-price-renderer
++ (gnc-price-get-currency price)
++ (gnc-price-get-value price))))))))
+ (append! activecols (list (if use-txn (if pricing-txn "*" "**") " ")
+ (gnc:make-html-table-header-cell/markup
+ "number-cell" (gnc:make-gnc-monetary currency (sum-basis basis-list
+ currency-frac)))
+ (gnc:make-html-table-header-cell/markup "number-cell" value)
+ (gnc:make-html-table-header-cell/markup "number-cell" moneyin)
+ (gnc:make-html-table-header-cell/markup "number-cell" moneyout)
+ (gnc:make-html-table-header-cell/markup "number-cell" gain)
+ (gnc:make-html-table-header-cell/markup "number-cell" ugain)
+ (gnc:make-html-table-header-cell/markup "number-cell" bothgain)
+ (gnc:make-html-table-header-cell/markup "number-cell"
+ (let* ((moneyinvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount moneyin)))
+ (bothgainvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount bothgain)))
+ )
+ (if (= 0.0 moneyinvalue)
+ ""
+ (format #f "~,2f%" (* 100 (/ bothgainvalue moneyinvalue)))))
+ )
+ (gnc:make-html-table-header-cell/markup "number-cell" income)))
+ (if (not (eq? handle-brokerage-fees 'ignore-brokerage))
+ (append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" brokerage))))
+ (append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" totalreturn)
+ (gnc:make-html-table-header-cell/markup "number-cell"
+ (let* ((moneyinvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount moneyin)))
+ (totalreturnvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount totalreturn)))
+ )
+ (if (= 0.0 moneyinvalue)
+ ""
+ (format #f "~,2f%" (* 100 (/ totalreturnvalue moneyinvalue))))))
+ )
+ )
+
+ (gnc:html-table-append-row/markup!
+ table
+ row-style
+ activecols)
+
+ (if (and (not use-txn) price) (gnc-price-unref price))
+ (table-add-stock-rows-internal rest (not odd-row?))
+ )
+ (begin
+ (if (and (not use-txn) price) (gnc-price-unref price))
+ (table-add-stock-rows-internal rest odd-row?)
+ )
+ )
+ )))
+
+ (set! work-to-do (gnc:accounts-count-splits accounts))
+ (table-add-stock-rows-internal accounts #t)))
+
+ ;; Tell the user that we're starting.
+ (gnc:report-starting reportname)
+
+ ;; The first thing we do is make local variables for all the specific
+ ;; options in the set of options given to the function. This set will
+ ;; be generated by the options generator above.
+ (let ((to-date (gnc:time64-end-day-time
+ (gnc:date-option-absolute-time
+ (get-option gnc:pagename-general "Date"))))
+ (accounts (get-option gnc:pagename-accounts "Accounts"))
+ (currency (get-option gnc:pagename-general "Report's currency"))
+ (price-source (get-option gnc:pagename-general
+ optname-price-source))
+ (report-title (get-option gnc:pagename-general
+ gnc:optname-reportname))
+ (include-empty (get-option gnc:pagename-accounts
+ optname-zero-shares))
+ (show-symbol (get-option gnc:pagename-display
+ optname-show-symbol))
+ (show-listing (get-option gnc:pagename-display
+ optname-show-listing))
+ (show-shares (get-option gnc:pagename-display
+ optname-show-shares))
+ (show-price (get-option gnc:pagename-display
+ optname-show-price))
+ (basis-method (get-option gnc:pagename-general
+ optname-basis-method))
+ (prefer-pricelist (get-option gnc:pagename-general
+ optname-prefer-pricelist))
+ (handle-brokerage-fees (get-option gnc:pagename-general
+ optname-brokerage-fees))
+
+ (total-basis (gnc:make-commodity-collector))
+ (total-value (gnc:make-commodity-collector))
+ (total-moneyin (gnc:make-commodity-collector))
+ (total-moneyout (gnc:make-commodity-collector))
+ (total-income (gnc:make-commodity-collector))
+ (total-gain (gnc:make-commodity-collector)) ;; realized gain
+ (total-ugain (gnc:make-commodity-collector)) ;; unrealized gain
+ (total-brokerage (gnc:make-commodity-collector))
+ ;;document will be the HTML document that we return.
+ (table (gnc:make-html-table))
+ (document (gnc:make-html-document)))
+
+ (gnc:html-document-set-title!
+ document (string-append
+ report-title
+ (format #f " ~a" (qof-print-date to-date))))
+
+ (if (not (null? accounts))
+ ; at least 1 account selected
+ (let* ((exchange-fn (gnc:case-exchange-fn price-source currency to-date))
+ (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
+ (price-fn
+ (case price-source
+ ((pricedb-latest)
+ (lambda (foreign domestic date)
+ (find-price (gnc-pricedb-lookup-latest-any-currency pricedb foreign)
+ domestic)))
+ ((pricedb-nearest)
+ (lambda (foreign domestic date)
+ (find-price (gnc-pricedb-lookup-nearest-in-time-any-currency-t64
+ pricedb foreign (time64CanonicalDayTime date)) domestic)))))
+ (headercols (list (_ "Account")))
+ (totalscols (list (gnc:make-html-table-cell/markup "total-label-cell" (_ "Total"))))
+ (sum-total-moneyin (gnc-numeric-zero))
+ (sum-total-income (gnc-numeric-zero))
+ (sum-total-both-gains (gnc-numeric-zero))
+ (sum-total-gain (gnc-numeric-zero))
+ (sum-total-ugain (gnc-numeric-zero))
+ (sum-total-brokerage (gnc-numeric-zero))
+ (sum-total-totalreturn (gnc-numeric-zero))) ;;end of let
+
+ ;;begin building lists for which columns to display
+ (if show-symbol
+ (begin (append! headercols (list (_ "Symbol")))
+ (append! totalscols (list " "))))
+
+ (if show-listing
+ (begin (append! headercols (list (_ "Listing")))
+ (append! totalscols (list " "))))
+
+ (if show-shares
+ (begin (append! headercols (list (_ "Shares")))
+ (append! totalscols (list " "))))
+
+ (if show-price
+ (begin (append! headercols (list (_ "Price")))
+ (append! totalscols (list " "))))
+
+ (append! headercols (list " "
+ (_ "Basis")
+ (_ "Value")
+ (_ "Money In")
+ (_ "Money Out")
+ (_ "Realized Gain")
+ (_ "Unrealized Gain")
+ (_ "Total Gain")
+ (_ "Rate of Gain")
+ (_ "Income")))
+
+ (if (not (eq? handle-brokerage-fees 'ignore-brokerage))
+ (append! headercols (list (_ "Brokerage Fees"))))
+
+ (append! headercols (list (_ "Total Return")
+ (_ "Rate of Return")))
+
+ (append! totalscols (list " "))
+
+ (gnc:html-table-set-col-headers!
+ table
+ headercols)
+
+ (catch 'div/0
+ (lambda ()
+ (table-add-stock-rows
+ table accounts to-date currency price-fn exchange-fn price-source
+ include-empty show-symbol show-listing show-shares show-price basis-method
+ prefer-pricelist handle-brokerage-fees
+ total-basis total-value total-moneyin total-moneyout
+ total-income total-gain total-ugain total-brokerage))
+ (lambda (k reason)
+ (gnc:html-document-add-object!
+ document (format #f OVERFLOW-ERROR reason))))
+
+
+ (set! sum-total-moneyin (gnc:sum-collector-commodity total-moneyin currency exchange-fn))
+ (set! sum-total-income (gnc:sum-collector-commodity total-income currency exchange-fn))
+ (set! sum-total-gain (gnc:sum-collector-commodity total-gain currency exchange-fn))
+ (set! sum-total-ugain (gnc:sum-collector-commodity total-ugain currency exchange-fn))
+ (set! sum-total-both-gains (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount sum-total-gain)
+ (gnc:gnc-monetary-amount sum-total-ugain)
+ (gnc-commodity-get-fraction currency) GNC-RND-ROUND)))
+ (set! sum-total-brokerage (gnc:sum-collector-commodity total-brokerage currency exchange-fn))
+ (set! sum-total-totalreturn (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount sum-total-both-gains)
+ (gnc:gnc-monetary-amount sum-total-income)
+ (gnc-commodity-get-fraction currency) GNC-RND-ROUND)))
+
+ (gnc:html-table-append-row/markup!
+ table
+ "grand-total"
+ (list
+ (gnc:make-html-table-cell/size
+ 1 17 (gnc:make-html-text (gnc:html-markup-hr)))))
+
+ ;; finish building the totals columns, now that totals are complete
+ (append! totalscols (list
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity total-basis currency exchange-fn))
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity total-value currency exchange-fn))
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-moneyin)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity total-moneyout currency exchange-fn))
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-gain)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-ugain)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-both-gains)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (let* ((totalinvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount sum-total-moneyin)))
+ (totalgainvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount sum-total-both-gains)))
+ )
+ (if (= 0.0 totalinvalue)
+ ""
+ (format #f "~,2f%" (* 100 (/ totalgainvalue totalinvalue))))))
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-income)))
+ (if (not (eq? handle-brokerage-fees 'ignore-brokerage))
+ (append! totalscols (list
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-brokerage))))
+ (append! totalscols (list
+ (gnc:make-html-table-cell/markup
+ "total-number-cell" sum-total-totalreturn)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (let* ((totalinvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount sum-total-moneyin)))
+ (totalreturnvalue (gnc-numeric-to-double
+ (gnc:gnc-monetary-amount sum-total-totalreturn)))
+ )
+ (if (= 0.0 totalinvalue)
+ ""
+ (format #f "~,2f%" (* 100 (/ totalreturnvalue totalinvalue))))))
+ ))
+
+
+ (gnc:html-table-append-row/markup!
+ table
+ "grand-total"
+ totalscols
+ )
+
+ (gnc:html-document-add-object! document table)
+ (if warn-price-dirty
+ (gnc:html-document-append-objects! document
+ (list (gnc:make-html-text (_ "* this commodity data was built using transaction pricing instead of the price list."))
+ (gnc:make-html-text (gnc:html-markup-br))
+ (gnc:make-html-text (_ "If you are in a multi-currency situation, the exchanges may not be correct.")))))
+
+ (if warn-no-price
+ (gnc:html-document-append-objects! document
+ (list (gnc:make-html-text (if warn-price-dirty (gnc:html-markup-br) ""))
+ (gnc:make-html-text (_ "** this commodity has no price and a price of 1 has been used.")))))
+)
+
+ ;if no accounts selected.
+ (gnc:html-document-add-object!
+ document
+ (gnc:html-make-no-account-warning
+ report-title (gnc:report-id report-obj))))
+
+ (gnc:report-finished)
+ document)))
+
+(gnc:define-report
+ 'version 1
+ 'report-guid "21d7cfc59fc74f22887596ebde7e462d"
+ 'name reportname
+ 'menu-path (list gnc:menuname-asset-liability)
+ 'options-generator options-generator
+ 'renderer advanced-portfolio-renderer)
diff --cc gnucash/report/reports/standard/balsheet-pnl.scm
index cf820d317,000000000..792c47e3b
mode 100644,000000..100644
--- a/gnucash/report/reports/standard/balsheet-pnl.scm
+++ b/gnucash/report/reports/standard/balsheet-pnl.scm
@@@ -1,1309 -1,0 +1,1311 @@@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; balsheet-pnl.scm: multi-column report. includes
+;; balance-sheet and p&l reports.
+;;
+;; By Christopher Lam, 2018
+;;
+;; Improved from balance-sheet.scm
+;;
+;; 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 at gnu.org
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (gnucash reports standard balsheet-pnl))
+(use-modules (gnucash engine))
+(use-modules (gnucash utilities))
+(use-modules (gnucash core-utils))
+(use-modules (gnucash app-utils))
+(use-modules (gnucash report))
+(use-modules (srfi srfi-1))
+(use-modules (srfi srfi-2))
+(use-modules (srfi srfi-9))
+
+;; the column-data record. the gnc:account-accumulate-at-dates will
+;; create a record for each report-date with split-data as follows:
+(define-record-type :col-datum
+ (make-datum last-split split-balance split-value-balance)
+ col-datum?
+ (last-split col-datum-get-last-split)
+ (split-balance col-datum-get-split-balance)
+ (split-value-balance col-datum-get-split-value-balance))
+
+(define FOOTER-TEXT
+ (gnc:make-html-text
+ (_ "WARNING: Foreign currency conversions, and unrealized gains
+calculations are not confirmed correct. This report may be modified
+without notice. Bug reports are very welcome at
+https://bugs.gnucash.org/")))
+
+;; define all option's names and help text so that they are properly
+
+(define optname-startdate (N_ "Start Date"))
+(define optname-enddate (N_ "End Date"))
+
+(define optname-period (N_ "Period duration"))
+(define opthelp-period (N_ "Duration between time periods"))
+
+(define optname-dual-columns (N_ "Enable dual columns"))
+(define opthelp-dual-columns (N_ "Selecting this option will enable double-column \
+reporting."))
+
+(define optname-disable-amount-indent (N_ "Disable amount indenting"))
+(define opthelp-disable-amount-indent (N_ "Selecting this option will disable amount indenting, and condense amounts into a single column."))
+
+(define optname-options-summary (N_ "Add options summary"))
+(define opthelp-options-summary (N_ "Add summary of options."))
+
+(define optname-account-full-name (N_ "Account full name instead of indenting"))
+(define opthelp-account-full-name (N_ "Selecting this option enables full account name instead, and disables indenting account names."))
+
+(define optname-accounts (N_ "Accounts"))
+(define opthelp-accounts (N_ "Report on these accounts, if display depth allows."))
+
+(define optname-depth-limit (N_ "Levels of Subaccounts"))
+(define opthelp-depth-limit (N_ "Maximum number of levels in the account tree displayed."))
+
+(define optname-parent-balance-mode (N_ "Parent account amounts include children"))
+(define opthelp-parent-balance-mode (N_ "If this option is enabled, subtotals are \
+displayed within parent amounts, and if parent has own amount, it is displayed on \
+the next row as a child account. If this option is disabled, subtotals are displayed \
+below parent and children groups."))
+
+(define optname-show-zb-accts (N_ "Include accounts with zero total balances"))
+(define opthelp-show-zb-accts (N_ "Include accounts with zero total (recursive) balances in this report."))
+
+(define optname-omit-zb-bals (N_ "Omit zero balance figures"))
+(define opthelp-omit-zb-bals (N_ "Show blank space in place of any zero balances which would be shown."))
+
+(define optname-account-links (N_ "Display accounts as hyperlinks"))
+(define opthelp-account-links (N_ "Shows each account in the table as a hyperlink to its register window."))
+
+(define optname-amount-links (N_ "Display amounts as hyperlinks"))
+(define opthelp-amount-links (N_ "Shows each amounts in the table as a hyperlink to a register or report."))
+
+;; section labels
+(define optname-label-sections (N_ "Label sections"))
+(define opthelp-label-sections (N_ "Whether or not to include a label for sections."))
+(define optname-total-sections (N_ "Include totals"))
+(define opthelp-total-sections (N_ "Whether or not to include a line indicating total amounts."))
+
+;; commodities
+(define pagename-commodities (N_ "Commodities"))
+(define optname-include-chart (N_ "Enable chart"))
+(define opthelp-include-chart (N_ "Enable link to chart"))
+
+(define optname-common-currency (N_ "Common Currency"))
+(define opthelp-common-currency (N_ "Convert all amounts to a single currency."))
+
+(define optname-report-commodity (N_ "Report's currency"))
+
+(define optname-price-source (N_ "Price Source"))
+
+(define optname-show-foreign (N_ "Show original currency amount"))
+(define opthelp-show-foreign (N_ "Also show original currency amounts"))
+
+(define optname-include-overall-period (N_ "If more than 1 period column, include overall period?"))
+(define opthelp-include-overall-period (N_ "If several profit & loss period columns are shown, \
+also show overall period profit & loss."))
+
+(define optname-show-rates (N_ "Show Exchange Rates"))
+(define opthelp-show-rates (N_ "Show the exchange rates used."))
+
+(define trep-uuid "2fe3b9833af044abb929a88d5a59620f")
+(define networth-barchart-uuid "cbba1696c8c24744848062c7f1cf4a72")
+(define pnl-barchart-uuid "80769921e87943adade887b9835a7685")
+
+(define periodlist
+ (list
+ (list #f
+ (cons 'text (_ "Disabled"))
+ (cons 'tip (_ "Disabled")))
+
+ (list 'YearDelta
+ (cons 'text (_ "Year"))
+ (cons 'tip (_ "One year.")))
+
+ (list 'HalfYearDelta
+ (cons 'text (_ "Half Year"))
+ (cons 'tip (_ "Half Year.")))
+
+ (list 'QuarterDelta
+ (cons 'text (_ "Quarter"))
+ (cons 'tip (_ "One Quarter.")))
+
+ (list 'MonthDelta
+ (cons 'text (_ "Month"))
+ (cons 'tip (_ "One Month.")))
+
+ (list 'TwoWeekDelta
+ (cons 'text (_ "2Week"))
+ (cons 'tip (_ "Two Weeks.")))
+
+ (list 'WeekDelta
+ (cons 'text (_ "Week"))
+ (cons 'tip (_ "One Week.")))))
+
+(define (keylist->vectorlist keylist)
+ (map
+ (lambda (item)
+ (vector
+ (car item)
+ (keylist-get-info keylist (car item) 'text)
+ (keylist-get-info keylist (car item) 'tip)))
+ keylist))
+
+(define (keylist-get-info keylist key info)
+ (assq-ref (assq-ref keylist key) info))
+
+;; options generator
+(define (multicol-report-options-generator report-type)
+ (let* ((options (gnc:new-options))
+ (book (gnc-get-current-book))
+ (add-option
+ (lambda (new-option)
+ (gnc:register-option options new-option))))
+
+ ;; date at which to report balance
+ (gnc:options-add-date-interval!
+ options gnc:pagename-general optname-startdate optname-enddate "c")
+
+ (add-option
+ (gnc:make-multichoice-callback-option
+ gnc:pagename-general optname-period
+ "c2" opthelp-period
+ #f
+ (keylist->vectorlist periodlist)
+ #f
+ (lambda (x)
+ (gnc-option-db-set-option-selectable-by-name
+ options
+ gnc:pagename-general optname-disable-amount-indent
+ (not x))
+ (gnc-option-db-set-option-selectable-by-name
+ options
+ gnc:pagename-general optname-dual-columns
+ (not x))
+ (case report-type
+ ((balsheet)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-general optname-include-chart x)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-general optname-startdate x))
+
+ ((pnl)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-general optname-include-overall-period x))))))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-disable-amount-indent
+ "c3" opthelp-disable-amount-indent #f))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-include-chart
+ "c5" opthelp-include-chart #f))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-dual-columns
+ "c4" opthelp-dual-columns #t))
+
+ (add-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-options-summary
+ "d" opthelp-options-summary
+ 'never
+ (list (vector 'always
+ (_ "Always")
+ (_ "Always display summary."))
+ (vector 'never
+ (_ "Never")
+ (_ "Disable report summary.")))))
+
+ ;; accounts to work on
+ (add-option
+ (gnc:make-account-list-option
+ gnc:pagename-accounts optname-accounts
+ "a"
+ opthelp-accounts
+ (lambda ()
+ (gnc:filter-accountlist-type
+ (list ACCT-TYPE-BANK ACCT-TYPE-CASH ACCT-TYPE-CREDIT
+ ACCT-TYPE-ASSET ACCT-TYPE-LIABILITY
+ ACCT-TYPE-STOCK ACCT-TYPE-MUTUAL ACCT-TYPE-CURRENCY
+ ACCT-TYPE-PAYABLE ACCT-TYPE-RECEIVABLE
+ ACCT-TYPE-EQUITY ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE
+ ACCT-TYPE-TRADING)
+ (gnc-account-get-descendants-sorted (gnc-get-current-root-account))))
+ #f #t))
+
+ ;; the depth-limit option is not well debugged; it may be better
+ ;; to disable it altogether
+ (gnc:options-add-account-levels!
+ options gnc:pagename-accounts optname-depth-limit
+ "b" opthelp-depth-limit 'all)
+
+ ;; all about currencies
+ (add-option
+ (gnc:make-complex-boolean-option
+ pagename-commodities optname-common-currency
+ "b" opthelp-common-currency #f #f
+ (lambda (x)
+ (for-each
+ (lambda (optname)
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-commodities optname x))
+ (list optname-report-commodity
+ optname-show-rates
+ optname-show-foreign
+ optname-price-source)))))
+
+ (gnc:options-add-currency!
+ options pagename-commodities
+ optname-report-commodity "c")
+
+ (gnc:options-add-price-source!
+ options pagename-commodities
+ optname-price-source "d" 'pricedb-nearest)
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ pagename-commodities optname-show-foreign
+ "e" opthelp-show-foreign #t))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ pagename-commodities optname-show-rates
+ "f" opthelp-show-rates #t))
+
+ ;; what to show for zero-balance accounts
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-show-zb-accts
+ "a" opthelp-show-zb-accts #t))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-omit-zb-bals
+ "b" opthelp-omit-zb-bals #f))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-parent-balance-mode
+ "c" opthelp-parent-balance-mode #t))
+
+ ;; some detailed formatting options
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-account-links
+ "e" opthelp-account-links #t))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-amount-links
+ "e5" opthelp-amount-links #t))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-account-full-name
+ "f" opthelp-account-full-name #f))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-label-sections "g" opthelp-label-sections #t))
+
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display optname-total-sections "h" opthelp-total-sections #t))
+
+ (when (eq? report-type 'pnl)
+ ;; include overall period column?
+ (add-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-include-overall-period
+ "c6" opthelp-include-overall-period #f)))
+
+ (gnc:options-set-default-section options gnc:pagename-general)
+
+ options))
+
+(define* (add-multicolumn-acct-table
+ table title accountlist maxindent get-cell-monetary-fn cols-data #:key
+ (omit-zb-bals? #f)
+ (show-zb-accts? #t)
+ (disable-account-indent? #f)
+ (disable-amount-indent? #f)
+ (show-orig-cur? #t)
+ (show-title? #t)
+ (show-accounts? #t)
+ (show-total? #t)
+ (depth-limit #f)
+ (negate-amounts? #f)
+ (recursive-bals? #f)
+ (account-anchor? #t)
+ (get-col-header-fn #f)
+ (convert-curr-fn #f)
+ (get-cell-anchor-fn #f))
+
+ ;; this function will add a 2D grid into the html-table
+ ;; the data cells are generated from (get-cell-monetary-fn account col-datum)
+ ;; the data cells may request an alternative (eg. original currency) monetary
+ ;; horizontal labels are generated from calling (get-col-header-fn col-datum)
+ ;; vertical labels are the account list. it can have multilevel subtotals.
+
+ ;; the following are compulsory arguments:
+ ;; table - an existing html-table object
+ ;; title - string as the first row
+ ;; accountlist - list of accounts
+ ;; maxindent - maximum account depth
+ ;; cols-data - list of data to be passed as parameter to the following helper functions
+ ;; get-cell-monetary-fn - a lambda (account cols-data) which produces a gnc-monetary or #f (eg price conversion impossible)
+
+ ;; the following are optional:
+ ;; omit-zb-bals? - a boolean to omit "$0.00" amounts
+ ;; show-zb-accts? - a boolean to omit whole account lines where all amounts are $0.00 (eg closed accts)
+ ;; show-title? - a bool to show/hide individual sections: title row
+ ;; show-accounts? - a bool to show/hide individual sections: accounts list and data columns
+ ;; show-total? - a bool to show/hide individual sections: accounts total
+ ;; disable-account-indent? - a boolean to disable narrow-cell indenting, and render account full-name instead
+ ;; disable-amount-indent? - a bool to disable amount indenting (only for single data column reports)
+ ;; negate-amounts? - a boolean to negate amounts. useful for e.g. income-type accounts.
+ ;; depth-limit - (untested) accounts whose levels exceed this depth limit are not shown
+ ;; recursive-bals? - a boolean to confirm recursive-balances enabled (parent-accounts show balances) or
+ ;; disabled (multilevel subtotals after each parent+children)
+ ;; account-anchor? - a boolean to enable/disable account link to account
+ ;; amount-anchor? - a boolean to enable/disable amount link to report/register
+ ;; get-col-header-fn - a lambda (accounts cols-data) to produce html-object - this is optional
+ ;; convert-curr-fn - a lambda (monetary cols-data) which produces a gnc-monetary or #f - optional
+ ;; show-orig-cur? - a boolean to enable/disable original currency after convert-curr-fn
+ ;; get-cell-anchor-fn - a lambda (account cols-data) which produces a url string - optional
+
+ (define num-columns (length cols-data))
+
+ (define amount-indenting? (and (not disable-amount-indent?) (= num-columns 1)))
+
+ (define (make-list-thunk n thunk)
+ (let loop ((result '()) (n n))
+ (if (zero? n) result
+ (loop (cons (thunk) result) (1- n)))))
+
+ (define (make-narrow-cell)
+ (gnc:make-html-table-cell/min-width 1))
+
+ (define (add-indented-row indent label label-markup row-markup amount-indent rest)
+ (when (or (not depth-limit) (<= indent depth-limit))
+ (let* ((account-cell (if label-markup
+ (gnc:make-html-table-cell/size/markup
+ 1 (if disable-account-indent? 1 (- maxindent indent))
+ label-markup label)
+ (gnc:make-html-table-cell/size
+ 1 (if disable-account-indent? 1 (- maxindent indent))
+ label)))
+ (row (append
+ (if disable-account-indent?
+ '()
+ (make-list-thunk indent make-narrow-cell))
+ (list account-cell)
+ (gnc:html-make-empty-cells
+ (if amount-indenting? (1- amount-indent) 0))
+ rest
+ (gnc:html-make-empty-cells
+ (if amount-indenting? (- maxindent amount-indent) 0)))))
+ (if row-markup
+ (gnc:html-table-append-row/markup! table row-markup row)
+ (gnc:html-table-append-row! table row)))))
+
+ (define (monetary+ . monetaries)
+ ;; usage: (monetary+ monetary...)
+ ;; inputs: list of gnc-monetary (e.g. USD 10, USD 25, GBP 5, GBP 8)
+ ;; outputs: list of gnc-monetary (e.g. USD 35, GBP 13), or '()
+ (let ((coll (gnc:make-commodity-collector)))
+ (for-each
+ (lambda (monetary)
+ (if monetary
+ (coll 'add
+ (gnc:gnc-monetary-commodity monetary)
+ (let ((amount (gnc:gnc-monetary-amount monetary)))
+ (if negate-amounts? (- amount) amount)))))
+ monetaries)
+ (coll 'format gnc:make-gnc-monetary #f)))
+
+ (define (list-of-monetary->html-text monetaries col-datum anchor)
+ ;; inputs:
+ ;; monetaries: list of gnc-monetary (or #f, or html-text object)
+ ;; col-datum: col-datum to help convert monetary currency
+ ;; anchor: url string for monetaries (or #f) (all have same anchor)
+ ;;
+ ;; outputs: html-text object
+ (let ((text (gnc:make-html-text)))
+ (for-each
+ (lambda (monetary)
+ (let ((converted (and show-orig-cur?
+ convert-curr-fn
+ (convert-curr-fn monetary col-datum))))
+ (if (not (and omit-zb-bals?
+ (gnc:gnc-monetary? monetary)
+ (zero? (gnc:gnc-monetary-amount monetary))))
+ (gnc:html-text-append! text
+ (if converted
+ (gnc:html-markup-i
+ (gnc:html-markup "small" monetary " "))
+ "")
+ (if anchor
+ (gnc:html-markup-anchor
+ anchor (or converted monetary))
+ (or converted monetary))
+ (gnc:html-markup-br)))))
+ monetaries)
+ text))
+
+ (define (account->depth acc)
+ (cond ((vector? acc) 0)
+ (else (gnc-account-get-current-depth acc))))
+
+ (define (account->descendants acc)
+ (cond ((vector? acc) '())
+ (else (gnc-account-get-descendants acc))))
+
+ (define (render-account account total?)
+ ;; input: account-name
+ ;; outputs: string or html-markup-anchor object
+ (let* ((virtual? (vector? account))
+ (acct-name (cond
+ (virtual? (vector-ref account 0))
+ (disable-account-indent? (gnc-account-get-full-name account))
+ (else (xaccAccountGetName account))))
+ (acct-label (if (and (not virtual?) total?)
+ (string-append (_ "Total For ") acct-name)
+ acct-name))
+ (acct-url (and account-anchor?
+ (not total?)
+ (not virtual?)
+ (not (xaccAccountGetPlaceholder account))
+ (gnc:account-anchor-text account))))
+ (gnc:make-html-text
+ (if acct-url
+ (gnc:html-markup-anchor acct-url acct-label)
+ acct-label))))
+
+ (define (add-whole-line contents)
+ (gnc:html-table-append-row!
+ table (gnc:make-html-table-cell/size
+ 1 (+ 1 (if disable-account-indent? 0 maxindent) num-columns)
+ contents)))
+
+ (define (account-and-descendants account)
+ (cons account (filter (lambda (acc) (member acc accountlist))
+ (account->descendants account))))
+
+ (define (sum-accounts-at-col accounts datum convert?)
+ ;; outputs: list of gnc-monetary
+
+ (let loop ((accounts accounts)
+ (result '()))
+ (cond
+ ((null? accounts)
+ (apply monetary+ result))
+ (else
+ (let* ((acc (car accounts))
+ (monetary (if (vector? acc)
+ ((vector-ref acc 1) datum)
+ (get-cell-monetary-fn acc datum)))
+ (amt (or (and convert? convert-curr-fn
+ (not (list? monetary))
+ (convert-curr-fn monetary datum))
+ monetary)))
+ (loop (cdr accounts)
+ (if (list? amt)
+ (append-reverse amt result)
+ (cons amt result))))))))
+
+ (define (is-not-zero? accts)
+ ;; this function tests whether accounts (with descendants) of all
+ ;; columns are zero.
+ (not (every zero? (concatenate
+ (map
+ (lambda (col-datum)
+ (map gnc:gnc-monetary-amount
+ (sum-accounts-at-col accts col-datum #f)))
+ cols-data)))))
+
+ (define* (add-recursive-subtotal lvl lvl-acct #:key account-style-normal?)
+ (if (or show-zb-accts?
+ (is-not-zero? (account-and-descendants lvl-acct)))
+ (add-indented-row lvl
+ (render-account lvl-acct (not account-style-normal?))
+ (if account-style-normal?
+ "text-cell"
+ "total-label-cell")
+ #f
+ (- maxindent lvl)
+ (map
+ (lambda (col-datum)
+ (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (list-of-monetary->html-text
+ (sum-accounts-at-col (account-and-descendants lvl-acct)
+ col-datum
+ #t)
+ col-datum
+ (and get-cell-anchor-fn
+ (get-cell-anchor-fn
+ (account-and-descendants lvl-acct)
+ col-datum)))))
+ cols-data))))
+
+ (define* (add-account-row lvl-curr curr #:key
+ (override-show-zb-accts? #f)
+ (account-indent 0))
+ (if (or show-zb-accts?
+ override-show-zb-accts?
+ (is-not-zero? (list curr)))
+ (add-indented-row lvl-curr
+ (render-account curr #f)
+ "text-cell"
+ #f
+ (- maxindent lvl-curr account-indent)
+ (map
+ (lambda (col-datum)
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (list-of-monetary->html-text
+ (sum-accounts-at-col
+ (list curr)
+ col-datum
+ (not show-orig-cur?))
+ col-datum
+ (and get-cell-anchor-fn
+ (not (vector? curr))
+ (get-cell-anchor-fn curr col-datum)))))
+ cols-data))))
+
+ ;; header ASSET/LIABILITY etc
+ (if show-title?
+ (add-indented-row 0
+ title
+ "total-label-cell"
+ "primary-subheading"
+ maxindent
+ (if get-col-header-fn
+ (map
+ (lambda (col-datum)
+ (get-col-header-fn accountlist col-datum))
+ cols-data)
+ (gnc:html-make-empty-cells num-columns))))
+
+ (let loop ((accounts (if show-accounts? accountlist '())))
+ (if (pair? accounts)
+ (let* ((curr (car accounts))
+ (rest (cdr accounts))
+ (next (and (pair? rest) (car rest)))
+ (lvl-curr (account->depth curr))
+ (lvl-next (if next (account->depth next) 0))
+ (curr-descendants-list (filter
+ (lambda (acc) (member acc accountlist))
+ (account->descendants curr)))
+ (recursive-parent-acct? (and recursive-bals?
+ (pair? curr-descendants-list)))
+ (multilevel-parent-acct? (and (not recursive-bals?)
+ (pair? curr-descendants-list))))
+
+ (if recursive-parent-acct?
+ (begin
+ (add-recursive-subtotal lvl-curr curr #:account-style-normal? #t)
+ (if (is-not-zero? (list curr))
+ (add-account-row (1+ lvl-curr) curr #:override-show-zb-accts? #t)))
+ (add-account-row lvl-curr curr
+ #:account-indent (if multilevel-parent-acct? 1 0)
+ #:override-show-zb-accts? multilevel-parent-acct?))
+
+ (if (and (not recursive-bals?)
+ (> lvl-curr lvl-next))
+ (let multilevel-loop ((lvl (1- lvl-curr))
+ (lvl-acct (gnc-account-get-parent curr)))
+ (unless (or (zero? lvl)
+ (not (member lvl-acct accountlist))
+ (< lvl lvl-next))
+ (add-recursive-subtotal lvl lvl-acct)
+ (multilevel-loop (1- lvl)
+ (gnc-account-get-parent lvl-acct)))))
+ (loop rest))))
+
+ (if show-total?
+ (add-indented-row 0
+ (string-append (_ "Total For ") title)
+ "total-label-cell"
+ "primary-subheading"
+ maxindent
+ (map
+ (lambda (col-datum)
+ (let ((total-cell (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (list-of-monetary->html-text
+ (sum-accounts-at-col accountlist
+ col-datum
+ #t)
+ col-datum
+ #f))))
+ (gnc:html-table-cell-set-style!
+ total-cell "total-number-cell"
+ 'attribute '("style" "border-top-style:solid; border-top-width: 1px; border-bottom-style:double"))
+ total-cell))
+ cols-data)))
+ (add-whole-line #f))
+
+(define (monetary-less . monetaries)
+ ;; syntax: (monetary-less mon0 mon1 mon2 ...)
+ ;; equiv: (- mon0 mon1 mon2 ...)
+ ;; this works only if all monetaries have the same commodity
+ (let ((res (gnc:make-commodity-collector)))
+ (res 'add (gnc:gnc-monetary-commodity (car monetaries))
+ (gnc:gnc-monetary-amount (car monetaries)))
+ (for-each
+ (lambda (mon)
+ (res 'add (gnc:gnc-monetary-commodity mon) (- (gnc:gnc-monetary-amount mon))))
+ (cdr monetaries))
+ (let ((reslist (res 'format gnc:make-gnc-monetary #f)))
+ (if (null? (cdr reslist))
+ (car reslist)
+ (gnc:error "monetary-less: 1 commodity only" monetaries)))))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; multicol-report-renderer
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (multicol-report-renderer report-obj report-type)
+ (define (get-option pagename optname)
+ (gnc:option-value
+ (gnc:lookup-option
+ (gnc:report-options report-obj) pagename optname)))
+
+ (gnc:report-starting (get-option gnc:pagename-general gnc:optname-reportname))
+
+ ;; get all options values
+ (let* ((report-title (get-option gnc:pagename-general gnc:optname-reportname))
+ (startdate ((if (eq? report-type 'pnl)
+ gnc:time64-start-day-time
+ gnc:time64-end-day-time)
+ (gnc:date-option-absolute-time
+ (get-option gnc:pagename-general optname-startdate))))
+ (enddate (gnc:time64-end-day-time
+ (gnc:date-option-absolute-time
+ (get-option gnc:pagename-general optname-enddate))))
+ (disable-account-indent? (get-option gnc:pagename-display
+ optname-account-full-name))
+ (incr (get-option gnc:pagename-general optname-period))
+ (disable-amount-indent? (and (not incr)
+ (get-option gnc:pagename-general
+ optname-disable-amount-indent)))
+ (enable-dual-columns? (and (not incr)
+ (get-option gnc:pagename-general
+ optname-dual-columns)))
+ (accounts (get-option gnc:pagename-accounts
+ optname-accounts))
+ (depth-limit (let ((limit (get-option gnc:pagename-accounts
+ optname-depth-limit)))
+ (and (not (eq? limit 'all)) limit)))
+ (show-zb-accts? (get-option gnc:pagename-display
+ optname-show-zb-accts))
+ (omit-zb-bals? (get-option gnc:pagename-display
+ optname-omit-zb-bals))
+ (recursive-bals? (get-option gnc:pagename-display
+ optname-parent-balance-mode))
+ (label-sections? (get-option gnc:pagename-display
+ optname-label-sections))
+ (total-sections? (get-option gnc:pagename-display
+ optname-total-sections))
+ (use-links? (get-option gnc:pagename-display
+ optname-account-links))
+ (use-amount-links? (get-option gnc:pagename-display
+ optname-amount-links))
+ (include-chart? (get-option gnc:pagename-general optname-include-chart))
+ (common-currency (and
+ (get-option pagename-commodities optname-common-currency)
+ (get-option pagename-commodities optname-report-commodity)))
+ (has-price? (lambda (commodity)
+ ;; the following tests whether an amount in
+ ;; commodity can be converted to
+ ;; common-currency. if conversion successful,
+ ;; it will be a non-zero value. note if we use
+ ;; API gnc-pricedb-has-prices, we're only
+ ;; querying the pricedb. if we use
+ ;; gnc-pricedb-convert-balance-latest-price, we
+ ;; can potentially use an intermediate
+ ;; currency.
+ (not (zero? (gnc-pricedb-convert-balance-latest-price
+ (gnc-pricedb-get-db (gnc-get-current-book))
+ (gnc-commodity-get-fraction commodity)
+ commodity
+ common-currency)))))
+ (price-source (and common-currency
+ (get-option pagename-commodities optname-price-source)))
+
+ (report-dates
+ (cond
+ (incr (gnc:make-date-list startdate enddate (gnc:deltasym-to-delta incr)))
+ ((eq? report-type 'pnl) (list startdate enddate))
+ (else (list enddate))))
+
+ ;; an alist of (cons account account-cols-data) whereby
+ ;; account-cols-data is a list of col-datum records
+ (accounts-cols-data
+ (map
+ (lambda (acc)
+ (let* ((comm (xaccAccountGetCommodity acc))
+ (val-coll (gnc:make-commodity-collector))
+ (amt->monetary (lambda (amt) (gnc:make-gnc-monetary comm amt))))
+ (cons acc
+ (gnc:account-accumulate-at-dates
+ acc report-dates
+ #:nosplit->elt (make-datum #f (amt->monetary 0)
+ (gnc:make-commodity-collector))
+ #:split->elt
+ (lambda (s)
+ (unless (xaccTransGetIsClosingTxn (xaccSplitGetParent s))
+ (val-coll 'add
+ (xaccTransGetCurrency (xaccSplitGetParent s))
+ (xaccSplitGetValue s)))
+ (make-datum s (amt->monetary (xaccSplitGetNoclosingBalance s))
+ (gnc:collector+ val-coll)))))))
+ accounts))
+
+ ;; an alist of (cons account account-balances) whereby
+ ;; account-balances is a list of monetary amounts
+ (accounts-balances
+ (map
+ (lambda (acc)
+ (cons acc (let ((cols-data (assoc-ref accounts-cols-data acc)))
+ (map col-datum-get-split-balance cols-data))))
+ accounts))
+
+ (exchange-fn (and common-currency
+ (gnc:case-exchange-time-fn
+ price-source common-currency
+ (map xaccAccountGetCommodity accounts) enddate
+ #f #f)))
+
+ ;; this function will convert the monetary found at col-idx
+ ;; into report-currency if the latter exists. The price
+ ;; applicable to the col-idx column is used. If the monetary
+ ;; cannot be converted (eg. missing price) then it is not converted.
+ (convert-curr-fn
+ (lambda (monetary col-idx)
+ (and common-currency
+ (not (gnc-commodity-equal
+ (gnc:gnc-monetary-commodity monetary)
+ common-currency))
+ (has-price? (gnc:gnc-monetary-commodity monetary))
+ (exchange-fn
+ monetary common-currency
+ (cond
+ ((eq? price-source 'pricedb-latest) (current-time))
+ ((eq? col-idx 'overall-period) (last report-dates))
+ ((eq? report-type 'balsheet) (list-ref report-dates col-idx))
+ ((eq? report-type 'pnl) (list-ref report-dates (1+ col-idx))))))))
+
+ ;; the following function generates an gnc:html-text object
+ ;; to dump exchange rate for a particular column. From the
+ ;; accountlist given, obtain commodities, and convert 1 unit
+ ;; currency into report-currency. If cannot convert due to
+ ;; missing price, say so.
+ (get-exchange-rates-fn
+ (lambda (accounts col-idx)
+ (let ((commodities (gnc:accounts-get-commodities accounts common-currency))
+ (cell (gnc:make-html-text)))
+ (for-each
+ (lambda (commodity)
+ (let ((orig-monetary (gnc:make-gnc-monetary commodity 1)))
+ (if (has-price? commodity)
- (let ((conv-monetary (convert-curr-fn orig-monetary col-idx)))
++ (let* ((conv-monetary (convert-curr-fn orig-monetary col-idx))
++ (conv-amount (gnc:gnc-monetary-amount conv-monetary)))
+ (gnc:html-text-append!
+ cell
+ (format #f "~a ~a"
+ (gnc:monetary->string orig-monetary)
- (gnc:monetary->string conv-monetary))))
++ (gnc:default-price-renderer common-currency
++ conv-amount))))
+ (gnc:html-text-append!
+ cell
+ (string-append
+ (format #f "~a ~a "
+ (gnc:monetary->string orig-monetary)
+ (gnc-commodity-get-nice-symbol common-currency))
+ (_ "missing")))))
+ (gnc:html-text-append! cell (gnc:html-markup-br)))
+ commodities)
+ (gnc:make-html-table-cell/markup "number-cell" cell))))
+
+ ;; scan accounts' commodities, filter currencies only, create
+ ;; hash-map counter, convert to alist, sort descending tally,
+ ;; return first pair's car. result=most used currency. the
+ ;; (cons default-currency 0) avoids crash in an empty-book by
+ ;; ensuring there is at least 1 currency.
+ (book-main-currency
+ (let ((h (make-hash-table)))
+ (for-each
+ (lambda (curr)
+ (hash-set! h curr (1+ (hash-ref h curr 0))))
+ (filter gnc-commodity-is-currency (map xaccAccountGetCommodity accounts)))
+ (caar (sort! (cons (cons (gnc-default-report-currency) 0)
+ (hash-map->list cons h))
+ (lambda (a b) (> (cdr a) (cdr b)))))))
+
+ ;; decompose the account list
+ (show-foreign? (get-option pagename-commodities optname-show-foreign))
+ (show-rates? (get-option pagename-commodities optname-show-rates))
+ (split-up-accounts (gnc:decompose-accountlist accounts))
+ (asset-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-ASSET))
+ (liability-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-LIABILITY))
+ (income-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-INCOME))
+ (expense-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-EXPENSE))
+ (equity-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-EQUITY))
+ (trading-accounts
+ (assoc-ref split-up-accounts ACCT-TYPE-TRADING))
+
+ (asset-liability (append-reverse asset-accounts liability-accounts))
+ (income-expense (append-reverse income-accounts expense-accounts))
+
+ (doc (gnc:make-html-document))
+ (multicol-table-left (gnc:make-html-table))
+ (multicol-table-right (if enable-dual-columns?
+ (gnc:make-html-table)
+ multicol-table-left))
+ (maxindent (1+ (apply max (cons 0 (map gnc-account-get-current-depth
+ accounts))))))
+
+ (define (sum-balances-of-accounts alist accts adder)
+ (let ((balances
+ (fold (lambda (a b) (if (member (car a) accts) (cons (cdr a) b) b))
+ '() alist)))
+ (list->vector
+ (if (null? balances)
+ (map (const (adder)) report-dates)
+ (apply map adder balances)))))
+
+ (gnc:html-document-set-title!
+ doc (with-output-to-string
+ (lambda ()
+ (display report-title)
+ (display " ")
+ (if (or incr (eq? report-type 'pnl))
+ (format #t (_ "~a to ~a")
+ (qof-print-date startdate) (qof-print-date enddate))
+ (display (qof-print-date enddate))))))
+
+ (if (eq? (get-option gnc:pagename-general optname-options-summary) 'always)
+ (gnc:html-document-add-object!
+ doc (gnc:html-render-options-changed (gnc:report-options report-obj))))
+
+ (cond
+ ((null? accounts)
+ (gnc:html-document-add-object!
+ doc
+ (gnc:html-make-no-account-warning
+ report-title (gnc:report-id report-obj))))
+
+ ((eq? report-type 'balsheet)
+ (let* ((get-cell-monetary-fn
+ (lambda (account col-idx)
+ (list-ref (assoc-ref accounts-balances account) col-idx)))
+
+ ;; an alist of (cons account vector-of-splits) where each
+ ;; split is the last one at date boundary
+ (accounts-splits-dates
+ (map
+ (lambda (acc)
+ (cons acc (let ((cols-data (assoc-ref accounts-cols-data acc)))
+ (list->vector
+ (map col-datum-get-last-split cols-data)))))
+ accounts))
+
+ (get-cell-anchor-fn
+ (lambda (account col-idx)
+ (and-let* (((not (pair? account)))
+ (date-splits (assoc-ref accounts-splits-dates account))
+ (split (vector-ref date-splits col-idx)))
+ (gnc:split-anchor-text split))))
+
+ ;; a vector of collectors whereby collector is the sum of
+ ;; asset and liabilities at report dates
+ (asset-liability-balances
+ (sum-balances-of-accounts
+ accounts-balances asset-liability gnc:monetaries-add))
+
+ ;; a vector of collectors whereby collector is the sum of
+ ;; incomes and expenses at report dates
+ (income-expense-balances
+ (sum-balances-of-accounts
+ accounts-balances income-expense gnc:monetaries-add))
+
+ ;; an alist of (cons account list-of-collectors) whereby each
+ ;; collector is the split-value-balances at report
+ ;; dates. split-value-balance determined by transaction currency.
+ (accounts-value-balances
+ (map
+ (lambda (acc)
+ (cons acc (let ((cols-data (assoc-ref accounts-cols-data acc)))
+ (map col-datum-get-split-value-balance cols-data))))
+ accounts))
+
+ ;; a vector of collectors whereby each collector is the sum
+ ;; of asset and liability split-value-balances at report
+ ;; dates
+ (asset-liability-value-balances
+ (sum-balances-of-accounts
+ accounts-value-balances asset-liability gnc:collector+))
+
+ ;; converts monetaries to common currency
+ (monetaries->exchanged
+ (lambda (monetaries target-currency price-source date)
+ (let ((exchange-fn (gnc:case-exchange-fn
+ price-source target-currency date)))
+ (apply gnc:monetary+
+ (cons (gnc:make-gnc-monetary target-currency 0)
+ (map
+ (lambda (mon)
+ (exchange-fn mon target-currency))
+ (monetaries 'format gnc:make-gnc-monetary #f)))))))
+
+ ;; the unrealized gain calculator retrieves the
+ ;; asset-and-liability report-date balance and
+ ;; value-balance, and calculates the difference,
+ ;; converted to report currency.
+ (unrealized-gain-fn
+ (lambda (col-idx)
+ (and-let* (common-currency
+ (date (case price-source
+ ((pricedb-latest) (current-time))
+ (else (list-ref report-dates col-idx))))
+ (asset-liability-balance
+ (vector-ref asset-liability-balances col-idx))
+ (asset-liability-basis
+ (vector-ref asset-liability-value-balances col-idx))
+ (unrealized (gnc:collector- asset-liability-basis
+ asset-liability-balance)))
+ (monetaries->exchanged
+ unrealized common-currency price-source date))))
+
+ ;; the retained earnings calculator retrieves the
+ ;; income-and-expense report-date balance, and converts
+ ;; to report currency.
+ (retained-earnings-fn
+ (lambda (col-idx)
+ (let* ((date (case price-source
+ ((pricedb-latest) (current-time))
+ (else (list-ref report-dates col-idx))))
+ (income-expense-balance
+ (vector-ref income-expense-balances col-idx)))
+ (if (and common-currency
+ (every has-price?
+ (gnc:accounts-get-commodities income-expense #f)))
+ (monetaries->exchanged income-expense-balance
+ common-currency price-source date)
+ (income-expense-balance 'format gnc:make-gnc-monetary #f)))))
+
+ (chart (and-let* (include-chart?
+ incr
+ (curr (or common-currency book-main-currency))
+ (price (or price-source 'pricedb-nearest)))
+ (gnc:make-report-anchor
+ networth-barchart-uuid report-obj
+ (list (list "General" "Start Date" (cons 'absolute startdate))
+ (list "General" "End Date" (cons 'absolute enddate))
+ (list "General" "Report's currency" curr)
+ (list "General" "Step Size" incr)
+ (list "General" "Price Source" price)
+ (list "Accounts" "Accounts" asset-liability)))))
+
+ (get-col-header-fn
+ (lambda (accounts col-idx)
+ (let* ((date (list-ref report-dates col-idx))
+ (header (qof-print-date date))
+ (cell (gnc:make-html-table-cell/markup
+ "total-label-cell" header)))
+ (gnc:html-table-cell-set-style!
+ cell "total-label-cell"
+ 'attribute '("style" "text-align:right"))
+ cell)))
+
+ (add-to-table (lambda* (table title accounts #:key
+ (get-col-header-fn #f)
+ (show-accounts? #t)
+ (show-total? #t)
+ (show-title? #t)
+ (force-total? #f)
+ (convert-fn #f)
+ (negate-amounts? #f))
+ (add-multicolumn-acct-table
+ table title accounts
+ maxindent get-cell-monetary-fn
+ (iota (length report-dates))
+ #:omit-zb-bals? omit-zb-bals?
+ #:show-zb-accts? show-zb-accts?
+ #:disable-account-indent? disable-account-indent?
+ #:negate-amounts? negate-amounts?
+ #:disable-amount-indent? disable-amount-indent?
+ #:depth-limit (if get-col-header-fn 0 depth-limit)
+ #:show-orig-cur? (and (not convert-fn) show-foreign?)
+ #:show-title? (and show-title? label-sections?)
+ #:show-accounts? show-accounts?
+ #:show-total? (or (and total-sections? show-total?)
+ force-total?)
+ #:recursive-bals? recursive-bals?
+ #:account-anchor? use-links?
+ #:convert-curr-fn (and common-currency
+ (or convert-fn convert-curr-fn))
+ #:get-col-header-fn get-col-header-fn
+ #:get-cell-anchor-fn (and use-amount-links?
+ get-cell-anchor-fn)
+ ))))
+
+ (when incr
+ (add-to-table multicol-table-left (_ "Date") '()
+ #:get-col-header-fn get-col-header-fn
+ #:show-accounts? #f
+ #:show-total? #f)
+ (if enable-dual-columns?
+ (add-to-table multicol-table-right (_ "Date") '()
+ #:get-col-header-fn get-col-header-fn
+ #:show-accounts? #f
+ #:show-total? #f)))
+
+ (unless (null? asset-accounts)
+ (add-to-table multicol-table-left (_ "Asset") asset-accounts))
+
+ (unless (null? liability-accounts)
+ (add-to-table multicol-table-right (_ "Liability") liability-accounts
+ #:negate-amounts? #t))
+
+ (add-to-table
+ multicol-table-right (_ "Equity")
+ (append equity-accounts
+ (if common-currency
+ (list (vector (_ "Unrealized Gains")
+ unrealized-gain-fn))
+ '())
+ (if (null? income-expense)
+ '()
+ (list (vector (_ "Retained Earnings")
+ retained-earnings-fn))))
+ #:negate-amounts? #t)
+
+ (if (and common-currency show-rates?)
+ (add-to-table multicol-table-right (_ "Exchange Rates")
+ asset-liability
+ #:get-col-header-fn get-exchange-rates-fn
+ #:show-accounts? #f
+ #:show-total? #f))
+
+ (if (and include-chart? incr)
+ (gnc:html-document-add-object!
+ doc
+ (gnc:make-html-text
+ (gnc:html-markup-anchor chart (_ "Barchart")))))))
+
+ ((eq? report-type 'pnl)
+ (let* ((include-overall-period? (get-option gnc:pagename-general
+ optname-include-overall-period))
+ (col-idx->datepair
+ (lambda (idx)
+ (cond
+ ((eq? idx 'overall-period)
+ (cons (car report-dates) (last report-dates)))
+ ((= idx (- (length report-dates) 2))
+ (cons (list-ref report-dates idx) (last report-dates)))
+ (else
+ (cons (list-ref report-dates idx)
+ (decdate (list-ref report-dates (1+ idx)) DayDelta))))))
+
+ (col-idx->monetarypair (lambda (balancelist idx)
+ (if (eq? idx 'overall-period)
+ (cons (car balancelist) (last balancelist))
+ (cons (list-ref balancelist idx)
+ (list-ref balancelist (1+ idx))))))
+
+ (get-cell-monetary-fn
+ (lambda (account col-idx)
+ (let* ((balances (assoc-ref accounts-balances account))
+ (monetarypair (col-idx->monetarypair balances col-idx)))
+ (monetary-less
+ (cdr monetarypair)
+ (car monetarypair)))))
+
+ (get-cell-anchor-fn
+ (lambda (account col-idx)
+ (let ((datepair (col-idx->datepair col-idx))
+ (show-orig? (and common-currency #t))
+ (curr (or common-currency book-main-currency))
+ (delta (or incr 'MonthDelta))
+ (price (or price-source 'pricedb-nearest))
+ (accts (if (pair? account) account (list account))))
+ (gnc:make-report-anchor
+ trep-uuid report-obj
+ (list
+ (list "General" "Start Date" (cons 'absolute (car datepair)))
+ (list "General" "End Date" (cons 'absolute (cdr datepair)))
+ (list "General" "Show original currency amount" show-orig?)
+ (list "General" "Common Currency" common-currency)
+ (list "General" "Report's currency" curr)
+ (list "Display" "Amount" 'double)
+ (list "Accounts" "Accounts" accts))))))
+
+ (chart
+ (and-let* (include-chart?
+ (curr (or common-currency book-main-currency))
+ (delta (or incr 'MonthDelta))
+ (price (or price-source 'pricedb-nearest)))
+ (gnc:make-report-anchor
+ pnl-barchart-uuid report-obj
+ (list (list "General" "Start Date" (cons 'absolute startdate))
+ (list "General" "End Date" (cons 'absolute enddate))
+ (list "General" "Report's currency" curr)
+ (list "General" "Step Size" delta)
+ (list "General" "Price Source" price)
+ (list "Accounts" "Accounts" income-expense)))))
+
+ (get-col-header-fn
+ (lambda (accounts col-idx)
+ (let* ((datepair (col-idx->datepair col-idx))
+ (header (gnc:make-html-text
+ (qof-print-date (car datepair))
+ (gnc:html-markup-br)
+ (_ " to ")
+ (qof-print-date (cdr datepair))))
+ (cell (gnc:make-html-table-cell/markup
+ "total-label-cell" header)))
+ (gnc:html-table-cell-set-style!
+ cell "total-label-cell"
+ 'attribute '("style" "text-align:right"))
+ cell)))
+
+ (add-to-table (lambda* (table title accounts #:key
+ (get-col-header-fn #f)
+ (show-accounts? #t)
+ (show-total? #t)
+ (force-total? #f)
+ (negate-amounts? #f))
+ (add-multicolumn-acct-table
+ table title accounts
+ maxindent get-cell-monetary-fn
+ (append
+ (iota (1- (length report-dates)))
+ (if (and include-overall-period?
+ (> (length report-dates) 2))
+ '(overall-period)
+ '()))
+ #:omit-zb-bals? omit-zb-bals?
+ #:show-zb-accts? show-zb-accts?
+ #:disable-account-indent? disable-account-indent?
+ #:negate-amounts? negate-amounts?
+ #:disable-amount-indent? disable-amount-indent?
+ #:depth-limit (if get-col-header-fn 0 depth-limit)
+ #:show-orig-cur? show-foreign?
+ #:show-title? label-sections?
+ #:show-accounts? show-accounts?
+ #:show-total? (or (and total-sections? show-total?)
+ force-total?)
+ #:recursive-bals? recursive-bals?
+ #:account-anchor? use-links?
+ #:convert-curr-fn (and common-currency convert-curr-fn)
+ #:get-col-header-fn get-col-header-fn
+ #:get-cell-anchor-fn (and use-amount-links?
+ get-cell-anchor-fn)))))
+
+ (when incr
+ (add-to-table multicol-table-left (_ "Period") '()
+ #:get-col-header-fn get-col-header-fn
+ #:show-accounts? #f
+ #:show-total? #f)
+ (if enable-dual-columns?
+ (add-to-table multicol-table-right (_ "Period") '()
+ #:get-col-header-fn get-col-header-fn
+ #:show-accounts? #f
+ #:show-total? #f)))
+
+ (unless (null? income-accounts)
+ (add-to-table multicol-table-left (_ "Income") income-accounts
+ #:negate-amounts? #t))
+
+ (unless (null? expense-accounts)
+ (add-to-table multicol-table-right (_ "Expense") expense-accounts))
+
+ (unless (or (null? income-accounts)
+ (null? expense-accounts))
+ (add-to-table multicol-table-left (_ "Net Income")
+ income-expense
+ #:show-accounts? #f
+ #:negate-amounts? #t
+ #:force-total? #t))
+
+ (if (and common-currency show-rates?)
+ (add-to-table multicol-table-left (_ "Exchange Rates")
+ income-expense
+ #:get-col-header-fn get-exchange-rates-fn
+ #:show-accounts? #f
+ #:show-total? #f))
+
+ (if include-chart?
+ (gnc:html-document-add-object!
+ doc
+ (gnc:make-html-text
+ (gnc:html-markup-anchor chart "Barchart")))))))
+
+ (let ((multicol-table (if enable-dual-columns?
+ (gnc:make-html-table)
+ multicol-table-left)))
+ (when enable-dual-columns?
+ (gnc:html-table-append-row! multicol-table
+ (list multicol-table-left multicol-table-right)))
+ (gnc:html-document-add-object!
+ doc multicol-table))
+
+ (gnc:html-document-add-object!
+ doc FOOTER-TEXT)
+
+ (gnc:report-finished)
+ ;; (gnc:html-document-set-style-text!
+ ;; doc " table, td{ border-width: 1px; border-style:solid; border-color: lightgray; border-collapse: collapse}")
+ doc))
+
+(define balsheet-reportname (_ "Balance Sheet (Multicolumn)"))
+(define pnl-reportname (_ "Income Statement (Multicolumn)"))
+
+(gnc:define-report
+ 'version 1
+ 'name balsheet-reportname
+ 'report-guid "065d5d5a77ba11e8b31e83ada73c5eea"
+ 'menu-path (list gnc:menuname-experimental)
+ 'options-generator (lambda () (multicol-report-options-generator 'balsheet))
+ 'renderer (lambda (rpt) (multicol-report-renderer rpt 'balsheet)))
+
+(gnc:define-report
+ 'version 1
+ 'name pnl-reportname
+ 'report-guid "0e94fd0277ba11e8825d43e27232c9d4"
+ 'menu-path (list gnc:menuname-experimental)
+ 'options-generator (lambda () (multicol-report-options-generator 'pnl))
+ 'renderer (lambda (rpt) (multicol-report-renderer rpt 'pnl)))
+
+;; END
diff --cc gnucash/report/reports/standard/register.scm
index 534b4a996,000000000..52a61f34f
mode 100644,000000..100644
--- a/gnucash/report/reports/standard/register.scm
+++ b/gnucash/report/reports/standard/register.scm
@@@ -1,715 -1,0 +1,717 @@@
+;; -*-scheme-*-
+;; register.scm
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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 at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(define-module (gnucash reports standard register))
+
+(use-modules (gnucash engine))
+(use-modules (gnucash utilities))
+(use-modules (gnucash core-utils))
+(use-modules (gnucash app-utils))
+(use-modules (gnucash report))
+(use-modules (srfi srfi-1))
+
+(define (date-col columns-used)
+ (vector-ref columns-used 0))
+(define (num-col columns-used)
+ (vector-ref columns-used 1))
+(define (description-col columns-used)
+ (vector-ref columns-used 2))
+(define (memo-col columns-used)
+ (vector-ref columns-used 3))
+(define (account-col columns-used)
+ (vector-ref columns-used 4))
+(define (shares-col columns-used)
+ (vector-ref columns-used 5))
+(define (price-col columns-used)
+ (vector-ref columns-used 6))
+(define (amount-single-col columns-used)
+ (vector-ref columns-used 7))
+(define (debit-col columns-used)
+ (vector-ref columns-used 8))
+(define (credit-col columns-used)
+ (vector-ref columns-used 9))
+(define (balance-col columns-used)
+ (vector-ref columns-used 10))
+(define (value-single-col columns-used)
+ (vector-ref columns-used 11))
+(define (value-debit-col columns-used)
+ (vector-ref columns-used 12))
+(define (value-credit-col columns-used)
+ (vector-ref columns-used 13))
+(define (lot-col columns-used)
+ (vector-ref columns-used 14))
+
+(define columns-used-size 15)
+
+(define (num-columns-required columns-used)
+ (do ((i 0 (+ i 1))
+ (col-req 0 col-req))
+ ((>= i columns-used-size) col-req)
+ (if (vector-ref columns-used i)
+ (set! col-req (+ col-req 1)))))
+
+(define (build-column-used options)
+ (define (opt-val section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name)))
+ (define (make-set-col col-vector)
+ (let ((col 0))
+ (lambda (used? index)
+ (if used?
+ (begin
+ (vector-set! col-vector index col)
+ (set! col (+ col 1)))
+ (vector-set! col-vector index #f)))))
+
+ (let* ((col-vector (make-vector columns-used-size #f))
+ (set-col (make-set-col col-vector)))
+ (set-col (opt-val "Display" "Date") 0)
+ (set-col (if (gnc:lookup-option options "Display" "Num")
+ (opt-val "Display" "Num")
+ (opt-val "Display" "Num/Action")) 1)
+ (set-col
+ (if (opt-val "__reg" "journal")
+ (or (opt-val "Display" "Memo")
+ (opt-val "Display" "Description")
+ (opt-val "__reg" "double") )
+ (opt-val "Display" "Description"))
+ 2)
+ (set-col
+ (if (opt-val "__reg" "journal")
+ #f
+ (opt-val "Display" "Memo"))
+ 3)
+ (set-col (opt-val "Display" "Account") 4)
+ (set-col (opt-val "Display" "Shares") 5)
+ (set-col (opt-val "Display" "Lot") 14)
+ (set-col (opt-val "Display" "Price") 6)
+ (let ((amount-setting (opt-val "Display" "Amount")))
+ (if (eq? amount-setting 'single)
+ (set-col #t 7)
+ (begin
+ (set-col #t 8)
+ (set-col #t 9))))
+ (if (opt-val "Display" "Value")
+ (if (amount-single-col col-vector)
+ (set-col #t 11)
+ (begin
+ (set-col #t 12)
+ (set-col #t 13))))
+ (set-col (opt-val "Display" "Running Balance") 10)
+
+ col-vector))
+
+(define (make-heading-list column-vector
+ debit-string credit-string amount-string
+ multi-rows? action-for-num? ledger-type?)
+ (let ((heading-list '()))
+ (gnc:debug "Column-vector" column-vector)
+ (if (date-col column-vector)
+ (addto! heading-list (_ "Date")))
+ (if (num-col column-vector)
+ (addto! heading-list (if action-for-num?
+ (if ledger-type?
+ (_ "T-Num")
+ (_ "Num/Action"))
+ (_ "Num"))))
+ (if (description-col column-vector)
+ (addto! heading-list (_ "Description")))
+ (if (memo-col column-vector)
+ (addto! heading-list (_ "Memo")))
+ (if (account-col column-vector)
+ (addto! heading-list (if multi-rows?
+ (_ "Account")
+ (_ "Transfer"))))
+ (if (shares-col column-vector)
+ (addto! heading-list (_ "Shares")))
+ (if (lot-col column-vector)
+ (addto! heading-list (_ "Lot")))
+ (if (price-col column-vector)
+ (addto! heading-list (_ "Price")))
+ (if (amount-single-col column-vector)
+ (addto! heading-list amount-string))
+ (if (debit-col column-vector)
+ (addto! heading-list debit-string))
+ (if (credit-col column-vector)
+ (addto! heading-list credit-string))
+ (if (value-single-col column-vector)
+ (addto! heading-list (_ "Value")))
+ (if (value-debit-col column-vector)
+ (addto! heading-list (_ "Debit Value")))
+ (if (value-credit-col column-vector)
+ (addto! heading-list (_ "Credit Value")))
+ (if (balance-col column-vector)
+ (addto! heading-list (_ "Balance")))
+ (reverse heading-list)))
+
+(define (add-split-row table split column-vector row-style transaction-info?
+ split-info? action-for-num? ledger-type? double? memo?
+ description? total-collector)
+ (let* ((row-contents '())
+ (parent (xaccSplitGetParent split))
+ (account (xaccSplitGetAccount split))
+ (currency (xaccAccountGetCommodity account))
+ (trans-currency (xaccTransGetCurrency parent))
+ (damount (xaccSplitGetAmount split))
+ (split-value (gnc:make-gnc-monetary currency damount)))
+
+ (if (date-col column-vector)
+ (addto! row-contents
+ (if transaction-info?
+ (gnc:make-html-table-cell/markup
+ "date-cell"
+ (qof-print-date
+ (xaccTransGetDate parent)))
+ " ")))
+ (if (num-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if transaction-info?
+ (if (and action-for-num? ledger-type?)
+ (gnc-get-num-action parent #f)
+ (gnc-get-num-action parent split))
+ (if split-info?
+ (gnc-get-action-num #f split)
+ " ")))))
+ (if (description-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if transaction-info?
+ (if description?
+ (xaccTransGetDescription parent)
+ " " )
+ (if split-info?
+ (if memo?
+ (xaccSplitGetMemo split)
+ " ")
+ " ")))))
+ (if (memo-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if transaction-info?
+ (xaccSplitGetMemo split)
+ " "))))
+ (if (account-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (cond
+ ((not split-info?) #f)
+ ((not transaction-info?) (gnc-account-get-full-name account))
+ (else (case (xaccTransCountSplits (xaccSplitGetParent split))
+ ((2) (gnc-account-get-full-name
+ (xaccSplitGetAccount
+ (xaccSplitGetOtherSplit split))))
+ ((1) (_ "None"))
+ (else (_ "-- Split Transaction --"))))))))
+ (if (shares-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if split-info?
+ (xaccSplitGetAmount split)
+ " "))))
+ (if (lot-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if split-info?
+ (gnc-lot-get-title (xaccSplitGetLot split))
+ " "))))
+ (if (price-col column-vector)
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if split-info?
- (gnc:make-gnc-monetary
- currency (xaccSplitGetSharePrice split))
++ (gnc:default-price-renderer
++ (gnc-account-get-currency-or-parent
++ (xaccSplitGetAccount split))
++ (xaccSplitGetSharePrice split))
+ " "))))
+ (if (amount-single-col column-vector)
+ (addto! row-contents
+ (if split-info?
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:html-split-anchor split split-value))
+ " ")))
+ (if (debit-col column-vector)
+ (if (positive? (gnc:gnc-monetary-amount split-value))
+ (addto! row-contents
+ (if split-info?
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:html-split-anchor split split-value))
+ " "))
+ (addto! row-contents " ")))
+ (if (credit-col column-vector)
+ (if (negative? (gnc:gnc-monetary-amount split-value))
+ (addto! row-contents
+ (if split-info?
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:html-split-anchor
+ split (gnc:monetary-neg split-value)))
+ " "))
+ (addto! row-contents " ")))
+ (if (value-single-col column-vector)
+ (addto! row-contents
+ (if split-info?
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-gnc-monetary trans-currency
+ (xaccSplitGetValue split)))
+ " ")))
+ (if (value-debit-col column-vector)
+ (addto! row-contents
+ (if (and split-info? (positive? (xaccSplitGetValue split)))
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-gnc-monetary trans-currency
+ (xaccSplitGetValue split)))
+ " ")))
+ (if (value-credit-col column-vector)
+ (addto! row-contents
+ (if (and split-info? (negative? (xaccSplitGetValue split)))
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-gnc-monetary trans-currency
+ (- (xaccSplitGetValue split))))
+ " ")))
+ ;; For single account registers, use the split's cached balance to remain
+ ;; consistent with the balances shown in the register itself
+ ;; For others, use the cumulated balance from the totals-collector
+ (if (balance-col column-vector)
+ (addto! row-contents
+ (if transaction-info?
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:html-split-anchor
+ split
+ (gnc:make-gnc-monetary
+ currency
+ (if ledger-type?
+ (cadr (total-collector 'getpair currency #f))
+ (xaccSplitGetBalance split)))))
+ " ")))
+
+ (gnc:html-table-append-row/markup! table row-style
+ (reverse row-contents))
+ (if (and double? transaction-info?)
+ (if (or (num-col column-vector) (description-col column-vector))
+ (begin
+ (let ((count 0))
+ (set! row-contents '())
+ (if (date-col column-vector)
+ (begin
+ (set! count (+ count 1))
+ (addto! row-contents " ")))
+ (if (and (num-col column-vector) (description-col column-vector))
+ (begin
+ (set! count (+ count 1))
+ (addto! row-contents
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (if (and action-for-num? (not ledger-type?))
+ (gnc-get-num-action parent #f)
+ " ")))))
+ (if (description-col column-vector)
+ (addto! row-contents ;;
+ (gnc:make-html-table-cell/size
+ 1 (- (num-columns-required column-vector) count)
+ (xaccTransGetNotes parent)))
+ (gnc:make-html-table-cell/size
+ 1 (- (num-columns-required column-vector) (- count 1))
+ (if (and action-for-num? (not ledger-type?))
+ (gnc-get-num-action parent #f)
+ " ")))
+ (gnc:html-table-append-row/markup! table row-style
+ (reverse row-contents))))))
+ split-value))
+
+
+(define (options-generator)
+
+ (define gnc:*report-options* (gnc:new-options))
+
+ (define (gnc:register-reg-option new-option)
+ (gnc:register-option gnc:*report-options* new-option))
+
+ (gnc:register-reg-option
+ (gnc:make-query-option "__reg" "query" '()))
+ (gnc:register-reg-option
+ (gnc:make-internal-option "__reg" "journal" #f))
+ (gnc:register-reg-option
+ (gnc:make-internal-option "__reg" "ledger-type" #f))
+ (gnc:register-reg-option
+ (gnc:make-internal-option "__reg" "double" #f))
+ (gnc:register-reg-option
+ (gnc:make-internal-option "__reg" "debit-string" (_ "Debit")))
+ (gnc:register-reg-option
+ (gnc:make-internal-option "__reg" "credit-string" (_ "Credit")))
+
+ (gnc:register-reg-option
+ (gnc:make-string-option
+ (N_ "General") (N_ "Title")
+ "a" (N_ "The title of the report.")
+ (N_ "Register Report")))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Date")
+ "b" (N_ "Display the date?") #t))
+
+ (if (qof-book-use-split-action-for-num-field (gnc-get-current-book))
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Num/Action")
+ "c" (N_ "Display the check number/action?") #t))
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Num")
+ "c" (N_ "Display the check number?") #t)))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Description")
+ "d" (N_ "Display the description?") #t))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Memo")
+ "e" (N_ "Display the memo?") #t))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Account")
+ "g" (N_ "Display the account?") #t))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Shares")
+ "ha" (N_ "Display the number of shares?") #f))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Lot")
+ "hb" (N_ "Display the name of lot the shares are in?") #f))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Price")
+ "hc" (N_ "Display the shares price?") #f))
+
+ (gnc:register-reg-option
+ (gnc:make-multichoice-option
+ (N_ "Display") (N_ "Amount")
+ "ia" (N_ "Display the amount?")
+ 'double
+ (list
+ (vector 'single (N_ "Single") (N_ "Single Column Display."))
+ (vector 'double (N_ "Double") (N_ "Two Column Display.")))))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Value")
+ "ib" (N_ "Display the value in transaction currency?") #f))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Running Balance")
+ "k" (N_ "Display a running balance?") #t))
+
+ (gnc:register-reg-option
+ (gnc:make-simple-boolean-option
+ (N_ "Display") (N_ "Totals")
+ "l" (N_ "Display the totals?") #t))
+
+
+ (gnc:options-set-default-section gnc:*report-options* "General")
+
+ gnc:*report-options*)
+
+;; -----------------------------------------------------------------
+;; create the report result
+;; -----------------------------------------------------------------
+
+(define (make-split-table splits options
+ debit-string credit-string amount-string)
+ ;; ----------------------------------
+ ;; local helper
+ ;; ----------------------------------
+ (define (opt-val section name)
+ (gnc:option-value (gnc:lookup-option options section name)))
+ (define (reg-report-journal?)
+ (opt-val "__reg" "journal"))
+ (define (reg-report-ledger-type?)
+ (opt-val "__reg" "ledger-type"))
+ (define (reg-report-double?)
+ (opt-val "__reg" "double"))
+ (define (reg-report-show-totals?)
+ (opt-val "Display" "Totals"))
+
+ (define (add-subtotal-row label leader table used-columns
+ subtotal-collector subtotal-style
+ value?)
+ (let ((currency-totals (subtotal-collector
+ 'format gnc:make-gnc-monetary #f))
+ (single-col (if value?
+ (value-single-col used-columns)
+ (amount-single-col used-columns)))
+ (credit-col (if value?
+ (value-credit-col used-columns)
+ (credit-col used-columns)))
+ (debit-col (if value?
+ (value-debit-col used-columns)
+ (debit-col used-columns))))
+
+ (define (colspan monetary)
+ (cond
+ (single-col single-col)
+ ((negative? (gnc:gnc-monetary-amount monetary)) credit-col)
+ (else debit-col)))
+
+ (define (display-subtotal monetary)
+ (if single-col
+ (if (and leader (gnc-reverse-balance leader))
+ (gnc:monetary-neg monetary)
+ monetary)
+ (if (negative? (gnc:gnc-monetary-amount monetary))
+ (gnc:monetary-neg monetary)
+ monetary)))
+
+ (when (or single-col credit-col debit-col)
+ (gnc:html-table-append-row!
+ table
+ (list
+ (gnc:make-html-table-cell/size
+ 1 (num-columns-required used-columns)
+ (gnc:make-html-text (gnc:html-markup-hr)))))
+
+ (for-each
+ (lambda (monetary)
+ (gnc:html-table-append-row/markup!
+ table subtotal-style
+ (list (gnc:make-html-table-cell/markup "total-label-cell" label)
+ (gnc:make-html-table-cell/size/markup
+ 1 (colspan monetary) "total-number-cell"
+ (display-subtotal monetary)))))
+ currency-totals))))
+
+ (define (accumulate-totals split total-amount total-value
+ debit-amount debit-value
+ credit-amount credit-value)
+ (let* ((parent (xaccSplitGetParent split))
+ (account (xaccSplitGetAccount split))
+ (split-currency (xaccAccountGetCommodity account))
+ (split-amount (xaccSplitGetAmount split))
+ (trans-currency (xaccTransGetCurrency parent))
+ (split-value (xaccSplitGetValue split)))
+ (if (positive? split-amount)
+ (debit-amount 'add split-currency split-amount)
+ (credit-amount 'add split-currency split-amount))
+ (if (positive? split-value)
+ (debit-value 'add trans-currency split-value)
+ (credit-value 'add trans-currency split-value))
+ (total-amount 'add split-currency split-amount)
+ (total-value 'add trans-currency split-value)))
+
+ (define (splits-leader splits)
+ (let ((accounts (map xaccSplitGetAccount splits)))
+ (and (pair? accounts)
+ (apply equal? accounts)
+ (car accounts))))
+
+ ;; ----------------------------------
+ ;; make the split table
+ ;; ----------------------------------
+ (let* ((table (gnc:make-html-table))
+ (used-columns (build-column-used options))
+ (width (num-columns-required used-columns))
+ (multi-rows? (reg-report-journal?))
+ (ledger-type? (reg-report-ledger-type?))
+ (double? (reg-report-double?))
+ (leader (splits-leader splits))
+ (total-collector (gnc:make-commodity-collector))
+ (debit-collector (gnc:make-commodity-collector))
+ (credit-collector (gnc:make-commodity-collector))
+ (total-value (gnc:make-commodity-collector))
+ (debit-value (gnc:make-commodity-collector))
+ (credit-value (gnc:make-commodity-collector))
+ (action-for-num? (qof-book-use-split-action-for-num-field
+ (gnc-get-current-book))))
+
+ (gnc:html-table-set-col-headers!
+ table
+ (make-heading-list used-columns
+ debit-string credit-string amount-string
+ multi-rows? action-for-num? ledger-type?))
+
+ (let loop ((splits splits)
+ (odd-row? #t))
+
+ (cond
+
+ ;; ----------------------------------
+ ;; exit condition reached
+ ;; add debit/credit totals to the table
+ ;; ----------------------------------
+ ((null? splits)
+ (when reg-report-show-totals?
+ (add-subtotal-row (_ "Total Debits") leader table used-columns
+ debit-collector "grand-total" #f)
+ (add-subtotal-row (_ "Total Credits") leader table used-columns
+ credit-collector "grand-total" #f)
+ (add-subtotal-row (_ "Total Value Debits") leader table used-columns
+ debit-value "grand-total" #t)
+ (add-subtotal-row (_ "Total Value Credits") leader table used-columns
+ credit-value "grand-total" #t))
+ (when ledger-type?
+ (add-subtotal-row (_ "Net Change") leader table used-columns
+ total-collector "grand-total" #f))
+ (add-subtotal-row (_ "Value Change") leader table used-columns
+ total-value "grand-total" #t))
+
+ ;; The general journal has a split that doesn't have an account
+ ;; set yet (the new entry transaction).
+ ;; This split should be skipped or the report errors out. See
+ ;; bug #639082
+ ((null? (xaccSplitGetAccount (car splits)))
+ (loop (cdr splits) (not odd-row?)))
+
+ ;; ----------------------------------
+ ;; process the splits list
+ ;; ----------------------------------
+ (else
+ (let* ((current (car splits))
+ (current-row-style (if (or multi-rows? odd-row?)
+ "normal-row"
+ "alternate-row")))
+ ;; ----------------------------------------------
+ ;; update totals, but don't add them to the table
+ ;; ----------------------------------------------
+ (for-each
+ (lambda (split)
+ (accumulate-totals split
+ total-collector total-value
+ debit-collector debit-value
+ credit-collector credit-value))
+ (if multi-rows?
+ (xaccTransGetSplitList (xaccSplitGetParent current))
+ (list current)))
+ ;; ----------------------------------
+ ;; add the splits to the table
+ ;; ----------------------------------
+ (add-split-row table current used-columns
+ current-row-style #t (not multi-rows?)
+ action-for-num? ledger-type?
+ double? (opt-val "Display" "Memo")
+ (opt-val "Display" "Description")
+ total-collector)
+ (when multi-rows?
+ (for-each
+ (lambda (split)
+ (add-split-row table split used-columns "alternate-row"
+ #f #t action-for-num? ledger-type? #f
+ (opt-val "Display" "Memo")
+ (opt-val "Display" "Description") total-collector))
+ (xaccTransGetSplitList (xaccSplitGetParent current))))
+
+ (loop (cdr splits)
+ (not odd-row?))))))
+ table))
+
+(define (reg-renderer report-obj)
+ (define (opt-val section name)
+ (gnc:option-value
+ (gnc:lookup-option (gnc:report-options report-obj) section name)))
+
+ (let* ((document (gnc:make-html-document))
+ (query-scm (opt-val "__reg" "query"))
+ (journal? (opt-val "__reg" "journal"))
+ (debit-string (opt-val "__reg" "debit-string"))
+ (credit-string (opt-val "__reg" "credit-string"))
+ (title (opt-val "General" "Title"))
+ (query (gnc-scm2query query-scm)))
+
+ (qof-query-set-book query (gnc-get-current-book))
+
+ (let* ((splits (if journal?
+ (xaccQueryGetSplitsUniqueTrans query)
+ (qof-query-run query)))
+ (table (make-split-table splits
+ (gnc:report-options report-obj)
+ debit-string credit-string
+ (_ "Amount"))))
+ (gnc:html-document-set-title! document title)
+ (gnc:html-document-add-object! document table)
+ (qof-query-destroy query))
+
+ document))
+
+(define register-report-guid "22104e02654c4adba844ee75a3f8d173")
+
+;; we get called from elsewhere... but this doesn't work FIX-ME, find
+;; out how to get report-guid's exported from report into the report
+;; system at large. might have to define this at the report
+;; level to get them read by other reports. Look at the aging reports
+;; for suggestions, perhaps
+(export register-report-guid)
+
+(gnc:define-report
+ 'version 1
+ 'name (N_ "Register")
+ 'report-guid register-report-guid
+ 'options-generator options-generator
+ 'renderer reg-renderer
+ 'in-menu? #f)
+
+(define (gnc:register-report-create-internal invoice? query journal? ledger-type?
+ double? title debit-string credit-string)
+ (let* ((options (gnc:make-report-options register-report-guid))
+ (query-op (gnc:lookup-option options "__reg" "query"))
+ (journal-op (gnc:lookup-option options "__reg" "journal"))
+ (ledger-type-op (gnc:lookup-option options "__reg" "ledger-type"))
+ (double-op (gnc:lookup-option options "__reg" "double"))
+ (title-op (gnc:lookup-option options "General" "Title"))
+ (debit-op (gnc:lookup-option options "__reg" "debit-string"))
+ (credit-op (gnc:lookup-option options "__reg" "credit-string"))
+ (account-op (gnc:lookup-option options "Display" "Account")))
+
+ (if invoice?
+ (begin
+ (set! journal? #f)
+ (gnc:option-set-value account-op #f)))
+
+ (gnc:option-set-value query-op query)
+ (gnc:option-set-value journal-op journal?)
+ (gnc:option-set-value ledger-type-op ledger-type?)
+ (gnc:option-set-value double-op double?)
+ (gnc:option-set-value title-op title)
+ (gnc:option-set-value debit-op debit-string)
+ (gnc:option-set-value credit-op credit-string)
+ (gnc:make-report register-report-guid options)))
+
+(export gnc:register-report-create-internal)
diff --cc gnucash/report/reports/standard/test/test-balsheet-pnl.scm
index e865d2017,000000000..1fce2d92f
mode 100644,000000..100644
--- a/gnucash/report/reports/standard/test/test-balsheet-pnl.scm
+++ b/gnucash/report/reports/standard/test/test-balsheet-pnl.scm
@@@ -1,597 -1,0 +1,597 @@@
+(use-modules (gnucash engine))
+(use-modules (gnucash app-utils))
+(use-modules (tests test-engine-extras))
+(use-modules (gnucash reports standard balance-sheet))
+(use-modules (gnucash reports standard income-statement))
+(use-modules (gnucash reports standard balsheet-pnl))
+(use-modules (gnucash reports standard transaction))
+(use-modules (gnucash report stylesheets plain)) ; For the default stylesheet, required for rendering
+(use-modules (gnucash report))
+(use-modules (tests test-report-extras))
+(use-modules (srfi srfi-64))
+(use-modules (tests srfi64-extras))
+(use-modules (sxml simple))
+(use-modules (sxml xpath))
+
+;; This is implementation testing for Balance Sheet and Profit&Loss.
+
+(define balance-sheet-uuid "c4173ac99b2b448289bf4d11c731af13")
+(define pnl-uuid "0b81a3bdfd504aff849ec2e8630524bc")
+(define multicol-balsheet-uuid "065d5d5a77ba11e8b31e83ada73c5eea")
+(define multicol-pnl-uuid "0e94fd0277ba11e8825d43e27232c9d4")
+
+;; Explicitly set locale to make the report output predictable
+(setlocale LC_ALL "C")
+
+(define (run-test)
+ (test-runner-factory gnc:test-runner)
+ (test-begin "balsheet and profit&loss")
+ (null-test)
+ (create-test-data)
+ (balance-sheet-tests)
+ (pnl-tests)
+ (multicol-balsheet-tests)
+ (multicol-pnl-tests)
+ (test-end "balsheet and profit&loss"))
+
+(define (options->sxml uuid options test-title)
+ (gnc:options->sxml uuid options "test-balsheet-pnl" 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 (mnemonic->commodity sym)
+ (gnc-commodity-table-lookup
+ (gnc-commodity-table-get-table (gnc-get-current-book))
+ (gnc-commodity-get-namespace (gnc-default-report-currency))
+ sym))
+
+(define USD (gnc-default-report-currency)) ;default currency should be USD because LC_ALL="C"
+(define GBP (mnemonic->commodity "GBP"))
+(define FUNDS (gnc-commodity-new (gnc-get-current-book)
+ "Funds" ;fullname
+ "FUNDS" ;namespace
+ "FUNDS" ;mnemonic
+ "FUNDS" ;cusip
+ 1000 ;fraction
+ ))
+(gnc-commodity-set-user-symbol GBP "#")
+
+(define structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Asset"
+ (list "Bank1"
+ (list "Savings")
+ (list "Bonds")
+ (list "Empty")
+ (list "Current"))
+ (list "House")
+ (list "ForeignBank" (list (cons 'commodity GBP))
+ (list "ForeignSavings"))
+ (list "Broker"
+ (list "Funds" (list (cons 'type ACCT-TYPE-STOCK)
+ (cons 'commodity FUNDS)))))
+ (list "Liability" (list (cons 'type ACCT-TYPE-LIABILITY))
+ (list "Bank2"
+ (list "Loan")
+ (list "CreditCard")))
+ (list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
+ (list "Income" (list (cons 'type ACCT-TYPE-INCOME))
+ (list "Income-GBP" (list (cons 'commodity GBP))))))
+
+(define (null-test)
+ ;; This null-test tests for the presence of report.
+ (let ((balance-sheet-options (gnc:make-report-options balance-sheet-uuid)))
+ (test-assert "null-test" (options->sxml balance-sheet-uuid balance-sheet-options "null-test"))))
+
+(define (create-test-data)
+ ;; This function will perform implementation testing on the transaction report.
+ (let* ((env (create-test-env))
+ (account-alist (env-create-account-structure-alist env structure))
+ (bank1savings (cdr (assoc "Savings" account-alist)))
+ (bank1bonds (cdr (assoc "Bonds" account-alist)))
+ (bank1current (cdr (assoc "Current" account-alist)))
+ (house (cdr (assoc "House" account-alist)))
+ (foreignsavings (cdr (assoc "ForeignSavings" account-alist)))
+ (broker (cdr (assoc "Broker" account-alist)))
+ (brokerfunds (cdr (assoc "Funds" account-alist)))
+ (bank2loan (cdr (assoc "Loan" account-alist)))
+ (bank2creditcard (cdr (assoc "CreditCard" account-alist)))
+ (equity (cdr (assoc "Equity" account-alist)))
+ (income (cdr (assoc "Income" account-alist)))
+ (income-GBP (cdr (assoc "Income-GBP" account-alist))))
+
+ ;; $100 in Savings account
+ (env-transfer env 01 01 1970 equity bank1savings 100)
+ ;; $2000 in Bonds
+ (env-transfer env 01 01 1970 equity bank1bonds 2000)
+ ;; $500 in Current Acc
+ (env-transfer env 01 01 1970 equity bank1current 9000)
+ ;; $100,000 in house
+ (env-transfer env 01 01 1970 equity house 100000)
+
+ ;; pre-existing GBPs
+ (env-transfer-foreign env 01 01 1970 bank1current foreignsavings 130 100 #:description "buy 100GBP at $1.30")
+ (env-transfer-foreign env 01 02 1970 bank1current foreignsavings 140 100 #:description "buy 100GBP at $1.40")
+ (env-transfer-foreign env 15 02 1970 bank1current foreignsavings -142 -100 #:description "sell 100GBP at $1.42")
+ (env-transfer-foreign env 01 03 1970 bank1current foreignsavings 150 100 #:description "buy 100GBP at $1.50")
+ (env-transfer-foreign env 01 04 1970 bank1current foreignsavings 155 100 #:description "buy 100GBP at $1.55")
+ (env-transfer-foreign env 15 04 1970 bank1current foreignsavings -157 -100 #:description "sell 100GBP at $1.57")
+ (env-transfer-foreign env 01 05 1970 bank1current foreignsavings -160 -100 #:description "sell 100GBP at $1.60")
+ (env-transfer-foreign env 01 06 1970 bank1current foreignsavings 155 100 #:description "buy 100GBP at $1.55")
+ (env-transfer-foreign env 01 07 1970 bank1current foreignsavings -145 -100 #:description "sell 100GBP at $1.45")
+ (env-transfer-foreign env 01 08 1970 bank1current foreignsavings 165 100 #:description "buy 100GBP at $1.65")
+
+ ;; broker has $2000
+ (env-transfer env 01 01 1970 equity broker 2000)
+
+ ;; existing FUNDs = 200 USD on 01/01/1970
+ (env-transfer-foreign env 01 01 1970 bank1current brokerfunds 2000 10 #:description "buy 10FUND at $200")
+ (env-transfer-foreign env 01 02 1970 bank1current brokerfunds 2100 10 #:description "buy 10FUND at $210")
+ (env-transfer-foreign env 01 03 1970 bank1current brokerfunds 2250 10 #:description "buy 10FUND at $225")
+ (env-transfer-foreign env 01 04 1970 bank1current brokerfunds 2440 10 #:description "buy 10FUND at $244")
+ (env-transfer-foreign env 01 05 1970 bank1current brokerfunds -2640 -10 #:description "sell 10FUND at $264")
+ (env-transfer-foreign env 01 06 1970 bank1current brokerfunds -2550 -10 #:description "sell 10FUND at $255")
+ (env-transfer-foreign env 01 07 1970 bank1current brokerfunds 2500 10 #:description "buy 10FUND at $250")
+
+ ;; $9000 loan
+ (env-transfer env 01 01 1970 equity bank2loan -9000)
+
+ ;; $500 on creditcard debt
+ (env-transfer env 01 01 1970 equity bank2creditcard -500)
+
+ ;; further prices into pricedb
+ ;; GBP = 1.50 to 1.90 USD
+ (gnc-pricedb-create USD GBP (gnc-dmy2time64 1 1 1971) 15/10)
+ (gnc-pricedb-create USD GBP (gnc-dmy2time64 1 1 1972) 16/10)
+ (gnc-pricedb-create USD GBP (gnc-dmy2time64 1 1 1973) 17/10)
+ (gnc-pricedb-create USD GBP (gnc-dmy2time64 1 1 1974) 18/10)
+ (gnc-pricedb-create USD GBP (gnc-dmy2time64 1 1 1975) 19/10)
+ ;; FUND = 300 to 500 USD
+ (gnc-pricedb-create USD FUNDS (gnc-dmy2time64 1 1 1971) 300)
+ (gnc-pricedb-create USD FUNDS (gnc-dmy2time64 1 1 1972) 350)
+ (gnc-pricedb-create USD FUNDS (gnc-dmy2time64 1 1 1973) 400)
+ (gnc-pricedb-create USD FUNDS (gnc-dmy2time64 1 1 1974) 450)
+ (gnc-pricedb-create USD FUNDS (gnc-dmy2time64 1 1 1975) 500)
+
+ ;; a couple INCOME transactions, a decade later
+ (env-transfer env 01 01 1980 income bank1current 250)
+ (env-transfer env 01 01 1980 income-GBP foreignsavings 500)
+ (env-transfer-foreign env 01 02 1980 income-GBP bank1current 100 170 #:description "earn 100GBP into $170")))
+
+(define (balance-sheet-tests)
+ (define (default-balsheet-testing-options)
+ (let ((balance-sheet-options (gnc:make-report-options balance-sheet-uuid)))
+ (set-option! balance-sheet-options "General" "Balance Sheet Date" (cons 'absolute (gnc-dmy2time64 1 1 1971)))
+ (set-option! balance-sheet-options "Accounts" "Levels of Subaccounts" 'all)
+ (set-option! balance-sheet-options "Commodities" "Show Exchange Rates" #t)
+ balance-sheet-options))
+ (display "\n\n balsheet tests\n\n")
+ (let* ((balance-sheet-options (default-balsheet-testing-options))
+ (sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-default")))
+
+ (test-equal "total assets = $116,009"
+ (list "$116,009.00")
+ (sxml->table-row-col sxml 1 15 6))
+ (test-equal "total liabilities = $9,500.00"
+ (list "$9,500.00")
+ (sxml->table-row-col sxml 1 23 6))
+ (test-equal "total equity = $106,509.00"
+ (list "$106,509.00")
+ (sxml->table-row-col sxml 1 28 6))
+
+ (set-option! balance-sheet-options "Commodities" "Price Source" 'weighted-average)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-weighted-average")))
+ (test-equal "weighted average assets = $114,071.66"
+ (list "$114,071.66")
+ (sxml->table-row-col sxml 1 15 6)))
+
+ (set-option! balance-sheet-options "Commodities" "Price Source" 'average-cost)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-average-cost")))
+ (test-equal "average-cost assets = $113,100"
+ (list "$113,100.00")
+ (sxml->table-row-col sxml 1 15 6)))
+
+ (set-option! balance-sheet-options "Commodities" "Price Source" 'pricedb-nearest)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-pricedb-nearest")))
+ (test-equal "pricedb-nearest assets = $116,009"
+ (list "$116,009.00")
+ (sxml->table-row-col sxml 1 15 6)))
+
+ (set-option! balance-sheet-options "Commodities" "Price Source" 'pricedb-latest)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-pricedb-latest")))
+ (test-equal "pricedb-latest assets = $122,049"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 15 6)))
+
+ ;; set multilevel subtotal style
+ ;; verifies amount in EVERY line of the report.
+ (set-option! balance-sheet-options "Display" "Parent account balances" 'immediate-bal)
+ (set-option! balance-sheet-options "Display" "Parent account subtotals" 't)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-multilevel")))
+ (test-equal "multilevel. root = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "multilevel. assets = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 4 5))
+ (test-equal "multilevel. bank1 = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 5 4))
+ (test-equal "multilevel. bonds = $2,000.00"
+ (list "$2,000.00")
+ (sxml->table-row-col sxml 1 6 3))
+ (test-equal "multilevel. current = $2609.00"
+ (list "$2,609.00")
+ (sxml->table-row-col sxml 1 7 3))
+ (test-equal "multilevel. empty = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 8 3))
+ (test-equal "multilevel. savings = $100.00"
+ (list "$100.00")
+ (sxml->table-row-col sxml 1 9 3))
+ (test-equal "multilevel. total bank1 = $4709"
+ (list "$4,709.00")
+ (sxml->table-row-col sxml 1 10 4))
+ (test-equal "multilevel. broker = $2,000.00"
+ (list "$2,000.00")
+ (sxml->table-row-col sxml 1 11 4))
+ (test-equal "multilevel. funds = $15,000.00"
+ (list "30 FUNDS" "$15,000.00" "$15,000.00")
+ (sxml->table-row-col sxml 1 12 3))
+ (test-equal "multilevel. total broker = $17,000.00"
+ (list "$17,000.00")
+ (sxml->table-row-col sxml 1 13 4))
+ (test-equal "multilevel. foreign = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 14 4))
+ (test-equal "multilevel. foreignsavings = #200.00 = $340"
+ (list "#200.00" "$340.00" "$340.00")
+ (sxml->table-row-col sxml 1 15 3))
+ (test-equal "multilevel. total foreign = $340"
+ (list "$340.00")
+ (sxml->table-row-col sxml 1 16 4))
+ (test-equal "multilevel. house = $100,000"
+ (list "$100,000.00")
+ (sxml->table-row-col sxml 1 17 4))
+ (test-equal "multilevel. total asset = $122,049"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 18 5))
+ (test-equal "multilevel. total root = $122,049"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 19 6))
+ (test-equal "multilevel. total assets = $122,049"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 20 6)))
+
+ ;; set recursive-subtotal subtotal style
+ (set-option! balance-sheet-options "Display" "Parent account balances" 'recursive-bal)
+ (set-option! balance-sheet-options "Display" "Parent account subtotals" 'f)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-recursive")))
+ (test-equal "recursive. root = $760+15000+104600"
+ '("#200.00" "$340.00" "30 FUNDS" "$15,000.00" "$106,709.00" "$106,709.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "recursive. assets = $760+15000+104600"
+ '("#200.00" "$340.00" "30 FUNDS" "$15,000.00" "$106,709.00" "$106,709.00")
+ (sxml->table-row-col sxml 1 4 5))
+ (test-equal "recursive. bank1 = $4,709.00"
+ (list "$4,709.00")
+ (sxml->table-row-col sxml 1 5 4))
+ (test-equal "recursive. bonds = $2,000.00"
+ (list "$2,000.00")
+ (sxml->table-row-col sxml 1 6 3))
+ (test-equal "recursive. current = $2609.00"
+ (list "$2,609.00")
+ (sxml->table-row-col sxml 1 7 3))
+ (test-equal "recursive. empty = $0.00"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 8 3))
+ (test-equal "recursive. savings = $100.00"
+ (list "$100.00")
+ (sxml->table-row-col sxml 1 9 3))
+ (test-equal "recursive. broker = $15000+2000.00"
+ '("30 FUNDS" "$15,000.00" "$2,000.00" "$2,000.00")
+ (sxml->table-row-col sxml 1 10 4))
+ (test-equal "recursive. funds = $15,000.00"
+ (list "30 FUNDS" "$15,000.00" "$15,000.00")
+ (sxml->table-row-col sxml 1 11 3))
+ (test-equal "recursive. foreign = $340.00"
+ (list "#200.00" "$340.00")
+ (sxml->table-row-col sxml 1 12 4))
+ (test-equal "recursive. foreignsavings = #200.00 = $340"
+ (list "#200.00" "$340.00" "$340.00")
+ (sxml->table-row-col sxml 1 13 3))
+ (test-equal "recursive. house = $100,000"
+ (list "$100,000.00")
+ (sxml->table-row-col sxml 1 14 4))
+ (test-equal "recursive. total assets = $122,049.00"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 15 6)))
+
+ (set-option! balance-sheet-options "Commodities" "Show Foreign Currencies" #f)
+ (set-option! balance-sheet-options "Commodities" "Show Exchange Rates" #f)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-disable show-fcur show-rates")))
+ (test-equal "show-fcur disabled"
+ (list "$122,049.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "show-rates disabled"
+ '()
+ (sxml->table-row-col sxml 2 #f #f)))
+
+ (set-option! balance-sheet-options "Commodities" "Show Foreign Currencies" #t)
+ (set-option! balance-sheet-options "Commodities" "Show Exchange Rates" #t)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-enable show-fcur show-rates")))
+ (test-equal "show-fcur enabled"
+ '("#200.00" "$340.00" "30 FUNDS" "$15,000.00" "$106,709.00" "$106,709.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "show-rates enabled"
- '("#1.00" "$1.70" "1 FUNDS" "$500.00")
++ '("#1.00" "$1.7000" "1 FUNDS" "$500.0000")
+ (sxml->table-row-col sxml 2 #f #f)))
+
+ ;;make-multilevel
+ (set-option! balance-sheet-options "Display" "Parent account balances" 'immediate-bal)
+ (set-option! balance-sheet-options "Display" "Parent account subtotals" 't)
+
+ (set-option! balance-sheet-options "Display" "Omit zero balance figures" #t)
+ (set-option! balance-sheet-options "Display" "Include accounts with zero total balances" #f)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-incl-zb-accts=#f omit-zb-bals=#t")))
+ (test-equal "omit-zb-bals=#t"
+ '()
+ (sxml->table-row-col sxml 1 3 5))
+ (test-equal "incl-zb-accts=#f"
+ '("Savings" "$100.00") ;i.e.skips "Empty" account with $0.00
+ (sxml->table-row-col sxml 1 8 #f)))
+
+ (set-option! balance-sheet-options "Display" "Omit zero balance figures" #f)
+ (set-option! balance-sheet-options "Display" "Include accounts with zero total balances" #t)
+ (let ((sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-incl-zb-accts=#t omit-zb-bals=#f")))
+ (test-equal "omit-zb-bals=#f"
+ (list "$0.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "incl-zb-accts=#t"
+ '("Empty" "$0.00")
+ (sxml->table-row-col sxml 1 8 #f)))))
+
+(define (pnl-tests)
+ (define (default-pnl-testing-options)
+ (let ((pnl-options (gnc:make-report-options pnl-uuid)))
+ (set-option! pnl-options "General" "Start Date" (cons 'absolute (gnc-dmy2time64 1 1 1980)))
+ (set-option! pnl-options "General" "End Date" (cons 'absolute (gnc-dmy2time64 1 1 1981)))
+ (set-option! pnl-options "Accounts" "Levels of Subaccounts" 'all)
+ (set-option! pnl-options "Commodities" "Show Exchange Rates" #t)
+ pnl-options))
+ (display "\n\n pnl tests\n\n")
+ (let* ((pnl-options (default-pnl-testing-options))
+ (sxml (options->sxml pnl-uuid pnl-options "pnl-default")))
+ (test-equal "total revenue = $1,270.00"
+ (list "$1,270.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml))
+ (test-equal "total expenses = $0.00"
+ (list "$0.00")
+ ((sxpath '(// table // (tr 2) // table // (tr 3) // (td 6) // *text*))
+ sxml))
+
+ (set-option! pnl-options "Commodities" "Price Source" 'weighted-average)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-weighted-average")))
+ (test-equal "weighted average revenue = $1160.36"
+ (list "$1,160.36")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml)))
+
+ (set-option! pnl-options "Commodities" "Price Source" 'average-cost)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-average-cost")))
+ (test-equal "average-cost revenue = $976"
+ (list "$976.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml)))
+
+ (set-option! pnl-options "Commodities" "Price Source" 'pricedb-nearest)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-pricedb-nearest")))
+ (test-equal "pricedb-nearest revenue = $1270"
+ (list "$1,270.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml)))
+
+ (set-option! pnl-options "Commodities" "Price Source" 'pricedb-latest)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-pricedb-latest")))
+ (test-equal "pricedb-latest revenue = $1270"
+ (list "$1,270.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml)))
+
+ ;; set multilevel subtotal style
+ ;; verifies amount in EVERY line of the report.
+ (set-option! pnl-options "Display" "Parent account balances" 'immediate-bal)
+ (set-option! pnl-options "Display" "Parent account subtotals" 't)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-multilevel")))
+ (test-equal "multilevel. income = -$250.00"
+ (list "-$250.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 3) // (td 6) // *text*))
+ sxml))
+ (test-equal "multilevel. income-GBP = -#600"
+ (list "-#600.00" "-$1,020.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 4) // (td 5) // *text*))
+ sxml))
+ (test-equal "multilevel. total income = -$1,270.00"
+ (list "-$1,270.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 5) // (td 6) // *text*))
+ sxml))
+ (test-equal "multilevel. total revenue = $1,270.00"
+ (list "$1,270.00")
+ ((sxpath '(// table // (tr 1) // table // (tr 6) // (td 6) // *text*))
+ sxml))
+ (test-equal "multilevel. expenses = $0.00"
+ (list "$0.00")
+ ((sxpath '(// table // (tr 2) // table // (tr 3) // (td 6) // *text*))
+ sxml))
+ (test-equal "multilevel. net-income = $1,270"
+ (list "$1,270.00")
+ ((sxpath '(// table // (tr 2) // table // (tr 4) // (td 6) // *text*))
+ sxml)))
+
+ ;; set recursive-subtotal subtotal style
+ (set-option! pnl-options "Display" "Parent account balances" 'recursive-bal)
+ (set-option! pnl-options "Display" "Parent account subtotals" 'f)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-recursive")))
+ (test-equal "recursive. income = $1020+250"
+ (list "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00" "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "recursive. income-gbp = $1020"
+ (list "-#600.00" "-$1,020.00" "-#600.00" "-$1,020.00")
+ (sxml->table-row-col sxml 1 4 5))
+ (test-equal "recursive. total revenue = $1270"
+ (list "$1,270.00" "$1,270.00")
+ (sxml->table-row-col sxml 1 5 6)))
+
+ (set-option! pnl-options "Commodities" "Show Foreign Currencies" #f)
+ (set-option! pnl-options "Commodities" "Show Exchange Rates" #f)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-disable show-fcur show-rates")))
+ (test-equal "show-fcur disabled"
+ (list "-$1,270.00" "$0.00" "-$1,270.00" "$0.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "show-rates disabled"
+ '()
+ (sxml->table-row-col sxml 2 #f #f)))
+
+ (set-option! pnl-options "Commodities" "Show Foreign Currencies" #t)
+ (set-option! pnl-options "Commodities" "Show Exchange Rates" #t)
+ (let ((sxml (options->sxml pnl-uuid pnl-options "pnl-enable show-fcur show-rates")))
+ (test-equal "show-fcur enabled"
+ (list "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00" "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00")
+ (sxml->table-row-col sxml 1 3 6))
+ (test-equal "show-rates enabled"
- (list "#1.00" "$1.70")
++ (list "#1.00" "$1.7000")
+ (sxml->table-row-col sxml 2 #f #f)))
+
+ ;;make-multilevel
+ (set-option! pnl-options "Display" "Parent account balances" 'immediate-bal)
+ (set-option! pnl-options "Display" "Parent account subtotals" 't)))
+
+(define (multicol-balsheet-tests)
+ (define (default-testing-options)
+ (let ((options (gnc:make-report-options multicol-balsheet-uuid)))
+ (set-option! options "General" "Start Date"
+ (cons 'absolute (gnc-dmy2time64 1 1 1970)))
+ (set-option! options "General" "End Date"
+ (cons 'absolute (gnc-dmy2time64 1 1 1972)))
+ (set-option! options "General" "Enable dual columns" #f)
+ (set-option! options "General" "Disable amount indenting" #t)
+ (set-option! options "Display" "Account full name instead of indenting" #t)
+ (set-option! options "Accounts" "Levels of Subaccounts" 'all)
+ (set-option! options "Commodities" "Show Exchange Rates" #t)
+ options))
+ (display "\n\n multicol-balsheet tests\n\n")
+ (let* ((multi-bs-options (default-testing-options))
+ (sxml (options->sxml multicol-balsheet-uuid multi-bs-options
+ "multicol-balsheet-default")))
+ (test-equal "default row headers"
+ '("Asset" "Root" "Root.Asset" "Root.Asset.Bank1" "Root.Asset.Bank1.Bonds"
+ "Root.Asset.Bank1.Current" "Root.Asset.Bank1.Empty" "Root.Asset.Bank1.Savings"
+ "Root.Asset.Broker" "Root.Asset.Broker" "Root.Asset.Broker.Funds"
+ "Root.Asset.ForeignBank" "Root.Asset.ForeignBank.ForeignSavings"
+ "Root.Asset.House" "Total For Asset" "Liability" "Root.Liability"
+ "Root.Liability.Bank2" "Root.Liability.Bank2.CreditCard"
+ "Root.Liability.Bank2.Loan" "Total For Liability" "Equity" "Root.Equity"
+ "Retained Earnings" "Total For Equity")
+ (sxml->table-row-col sxml 1 #f 1))
+ (test-equal "default balances"
+ '("#200.00" "$106,709.00" "30 FUNDS" "#200.00" "$106,709.00" "30 FUNDS"
+ "$4,709.00" "$2,000.00" "$2,609.00" "$0.00" "$100.00" "$2,000.00"
+ "30 FUNDS" "$2,000.00" "30 FUNDS" "#200.00" "#200.00" "$100,000.00"
+ "30 FUNDS" "#200.00" "$106,709.00" "$9,500.00" "$9,500.00" "$500.00"
+ "$9,000.00" "$9,500.00" "$103,600.00" "$0.00" "#0.00" "$103,600.00"
+ "#0.00")
+ (sxml->table-row-col sxml 1 #f 2))
+
+ ;; the following tests many parts of multicolumn balance sheet:
+ ;; multiple-dates balances, unrealized-gain calculator, pricelists
+ (set-option! multi-bs-options "General" "Period duration" 'YearDelta)
+ (set-option! multi-bs-options "Commodities" "Common Currency" #t)
+ (set-option! multi-bs-options "Commodities" "Report's currency" USD)
+ (let ((sxml (options->sxml multicol-balsheet-uuid multi-bs-options
+ "multicol-balsheet-halfyear")))
+ (test-equal "bal-1/1/70"
+ '("01/01/70" "$113,100.00" "$113,100.00" "$8,970.00" "$2,000.00"
+ "$6,870.00" "$0.00" "$100.00" "$4,000.00" "$2,000.00" "$2,000.00"
+ "10 FUNDS " "$130.00" "$130.00" "#100.00 " "$100,000.00" "$113,100.00"
+ "$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$0.00" "$0.00" "$103,600.00" "#1.00 $1.30" "1 FUNDS $200.00")
++ "$0.00" "$0.00" "$103,600.00" "#1.00 $1.3000" "1 FUNDS $200.0000")
+ (sxml->table-row-col sxml 1 #f 2))
+ (test-equal "bal-1/1/71"
+ '("01/01/71" "$116,009.00" "$116,009.00" "$4,709.00" "$2,000.00"
+ "$2,609.00" "$0.00" "$100.00" "$11,000.00" "$2,000.00" "$9,000.00"
+ "30 FUNDS " "$300.00" "$300.00" "#200.00 " "$100,000.00" "$116,009.00"
+ "$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$2,909.00" "$0.00" "$106,509.00" "#1.00 $1.50" "1 FUNDS $300.00")
++ "$2,909.00" "$0.00" "$106,509.00" "#1.00 $1.5000" "1 FUNDS $300.0000")
+ (sxml->table-row-col sxml 1 #f 3))
+ (test-equal "bal-1/1/72"
+ '("01/01/72" "$117,529.00" "$117,529.00" "$4,709.00" "$2,000.00"
+ "$2,609.00" "$0.00" "$100.00" "$12,500.00" "$2,000.00" "$10,500.00"
+ "30 FUNDS " "$320.00" "$320.00" "#200.00 " "$100,000.00" "$117,529.00"
+ "$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$4,429.00" "$0.00" "$108,029.00" "#1.00 $1.60" "1 FUNDS $350.00")
++ "$4,429.00" "$0.00" "$108,029.00" "#1.00 $1.6000" "1 FUNDS $350.0000")
+ (sxml->table-row-col sxml 1 #f 4)))
+
+ ;; the following includes non-zero retained earnings of $1,270
+ (set-option! multi-bs-options "General" "End Date"
+ (cons 'absolute (gnc-dmy2time64 1 3 1980)))
+ (set-option! multi-bs-options "General" "Period duration" #f)
+ (let ((sxml (options->sxml multicol-balsheet-uuid multi-bs-options
+ "multicol-balsheet-retained")))
+ (test-equal "bal-1/3/80"
+ '("$123,319.00" "$123,319.00" "$5,129.00" "$2,000.00" "$3,029.00" "$0.00"
+ "$100.00" "$17,000.00" "$2,000.00" "$15,000.00" "30 FUNDS " "$1,190.00"
+ "$1,190.00" "#700.00 " "$100,000.00" "$123,319.00" "$9,500.00" "$9,500.00"
+ "$500.00" "$9,000.00" "$9,500.00" "$103,600.00" "$8,949.00" "$1,270.00"
- "$113,819.00" "#1.00 $1.70" "1 FUNDS $500.00")
++ "$113,819.00" "#1.00 $1.7000" "1 FUNDS $500.0000")
+ (sxml->table-row-col sxml 1 #f 2)))))
+
+(define (multicol-pnl-tests)
+ (define (default-testing-options)
+ (let ((options (gnc:make-report-options multicol-pnl-uuid)))
+ (set-option! options "General" "Start Date"
+ (cons 'absolute (gnc-dmy2time64 1 1 1980)))
+ (set-option! options "General" "End Date"
+ (cons 'absolute (gnc-dmy2time64 31 3 1980)))
+ (set-option! options "General" "Enable dual columns" #f)
+ (set-option! options "General" "Disable amount indenting" #t)
+ (set-option! options "Display" "Account full name instead of indenting" #t)
+ (set-option! options "Accounts" "Levels of Subaccounts" 'all)
+ (set-option! options "Commodities" "Show Exchange Rates" #t)
+ options))
+ (display "\n\n multicol-pnl tests\n\n")
+ (let* ((multi-bs-options (default-testing-options))
+ (sxml (options->sxml multicol-pnl-uuid multi-bs-options
+ "multicol-pnl-default")))
+ (test-equal "default row headers"
+ '("Income" "Root.Income" "Root.Income" "Root.Income.Income-GBP"
+ "Total For Income")
+ (sxml->table-row-col sxml 1 #f 1))
+ (test-equal "default pnl"
+ '("$250.00" "#600.00" "$250.00" "#600.00" "$250.00" "#600.00")
+ (sxml->table-row-col sxml 1 #f 2))
+
+ ;; the following tests many parts of multicolumn pnl:
+ ;; multiple-dates pnl
+ (set-option! multi-bs-options "General" "Period duration" 'MonthDelta)
+ (set-option! multi-bs-options "Commodities" "Common Currency" #t)
+ (set-option! multi-bs-options "Commodities" "Report's currency" USD)
+ (let ((sxml (options->sxml multicol-pnl-uuid multi-bs-options
+ "multicol-pnl-halfyear")))
+ (test-equal "pnl-1/80"
+ '("01/01/80" " to 01/31/80" "$1,100.00" "$250.00" "$850.00" "#500.00 "
- "$1,100.00" "#1.00 $1.70")
++ "$1,100.00" "#1.00 $1.7000")
+ (sxml->table-row-col sxml 1 #f 2))
+ (test-equal "pnl-2/80"
+ '("02/01/80" " to 02/29/80" "$170.00" "$0.00" "$170.00" "#100.00 "
- "$170.00" "#1.00 $1.70")
++ "$170.00" "#1.00 $1.7000")
+ (sxml->table-row-col sxml 1 #f 3))
+ (test-equal "pnl-3/80"
+ '("03/01/80" " to 03/31/80" "$0.00" "$0.00" "$0.00" "#0.00 "
- "$0.00" "#1.00 $1.70")
++ "$0.00" "#1.00 $1.7000")
+ (sxml->table-row-col sxml 1 #f 4)))))
diff --cc gnucash/report/reports/standard/test/test-portfolios.scm
index aa0c1f1d1,000000000..298d072e0
mode 100644,000000..100644
--- a/gnucash/report/reports/standard/test/test-portfolios.scm
+++ b/gnucash/report/reports/standard/test/test-portfolios.scm
@@@ -1,124 -1,0 +1,124 @@@
+(use-modules (gnucash engine))
+(use-modules (gnucash app-utils))
+(use-modules (tests test-engine-extras))
+(use-modules (gnucash reports standard portfolio))
+(use-modules (gnucash reports standard advanced-portfolio))
+(use-modules (gnucash report stylesheets plain))
+(use-modules (gnucash report))
+(use-modules (tests test-report-extras))
+(use-modules (srfi srfi-64))
+(use-modules (tests srfi64-extras))
+(use-modules (sxml simple))
+(use-modules (sxml xpath))
+(use-modules (system vm coverage))
+(use-modules (system vm vm))
+
+;; This is implementation testing for both the Portfolio and the
+;; Advanced Portfolio Report.
+
+(define portfolio-uuid "4a6b82e8678c4f3d9e85d9f09634ca89")
+(define advanced-uuid "21d7cfc59fc74f22887596ebde7e462d")
+
+;; Explicitly set locale to make the report output predictable
+(setlocale LC_ALL "C")
+
+(define (run-test)
+ (if #f
+ (coverage-test)
+ (run-test-proper)))
+
+(define (coverage-test)
+ (let ((currfile (dirname (current-filename))))
+ (add-to-load-path (string-take currfile (string-rindex currfile #\/))))
+ (call-with-values
+ (lambda () (with-code-coverage run-test-proper))
+ (lambda (data result)
+ (let ((port (open-output-file "/tmp/lcov.info")))
+ (coverage-data->lcov data port)
+ (close port)))))
+
+(define (run-test-proper)
+ (test-runner-factory gnc:test-runner)
+ (test-begin "test-portfolios.scm")
+ (null-test "portfolio" portfolio-uuid)
+ (null-test "advanced-portfolio" advanced-uuid)
+ (portfolio-tests)
+ (advanced-tests)
+ (test-end "test-portfolios.scm"))
+
+(define (options->sxml uuid options test-title)
+ (gnc:options->sxml uuid options "test-apr" 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 (teardown)
+ (gnc-clear-current-session))
+
+(define (null-test variant uuid)
+ ;; This null-test tests for the presence of report.
+ (let ((options (gnc:make-report-options uuid)))
+ (test-assert (format #f "null-test ~a" variant)
+ (options->sxml uuid options "null-test"))))
+
+(define (portfolio-tests)
+ (test-group-with-cleanup "portfolio-tests"
+ (let* ((account-alist (create-stock-test-data))
+ (options (gnc:make-report-options portfolio-uuid)))
+ (set-option! options "General" "Price Source" 'pricedb-latest)
+ (let ((sxml (options->sxml portfolio-uuid options "latest")))
+ (test-equal "portfolio: pricedb-latest"
+ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$252.00")
+ (sxml->table-row-col sxml 1 1 #f)))
+
+ (set-option! options "General" "Price Source" 'pricedb-nearest)
+ (set-option! options "General" "Date" (cons 'absolute (gnc-dmy2time64 1 3 1980)))
+ (let ((sxml (options->sxml portfolio-uuid options "nearest")))
+ (test-equal "portfolio: pricedb-nearest"
+ '("AAPL" "AAPL" "NASDAQ" "2.00" "$200.00" "$400.00")
+ (sxml->table-row-col sxml 1 1 #f)))
+
+ (set-option! options "General" "Price Source" 'average-cost)
+ (set-option! options "General" "Date" (cons 'absolute (gnc-dmy2time64 1 9 1980)))
+ (let ((sxml (options->sxml portfolio-uuid options "average-cost")))
+ (test-equal "portfolio: average-cost"
+ '("AAPL" "AAPL" "NASDAQ" "1.00" "$200.00" "$200.00")
+ (sxml->table-row-col sxml 1 1 #f)))
+
+ (set-option! options "General" "Price Source" 'weighted-average)
+ (let ((sxml (options->sxml portfolio-uuid options "'weighted-average")))
+ (test-equal "portfolio: weighted-average"
- '("AAPL" "AAPL" "NASDAQ" "1.00" "$233.33" "$233 + 1/3")
++ '("AAPL" "AAPL" "NASDAQ" "1.00" "$233.33" "$233.33")
+ (sxml->table-row-col sxml 1 1 #f))))
+ (teardown)))
+
+(define (advanced-tests)
+ (test-group-with-cleanup "advanced-portfolio-tests"
+ (let ((account-alist (create-stock-test-data))
+ (options (gnc:make-report-options advanced-uuid)))
+ (let ((sxml (options->sxml advanced-uuid options "basic average")))
+ (test-equal "advanced: average basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$484.88" "$252.00" "$800.00"
++ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$484.88" "$252.00" "$800.00"
+ "$553.00" "$227.88" "-$232.88" "-$5.00" "-0.63%" "$4.00"
+ "$10.00" "-$1.00" "-0.13%")
+ (sxml->table-row-col sxml 1 1 #f)))
+
+ (set-option! options "General" "Basis calculation method" 'fifo-basis)
+ (let ((sxml (options->sxml advanced-uuid options "basic fifo")))
+ (test-equal "advanced: fifo basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$543.94" "$252.00" "$800.00"
++ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$543.94" "$252.00" "$800.00"
+ "$553.00" "$286.94" "-$291.94" "-$5.00" "-0.63%" "$4.00" "$10.00"
+ "-$1.00" "-0.13%")
+ (sxml->table-row-col sxml 1 1 #f)))
+
+ (set-option! options "General" "Basis calculation method" 'filo-basis)
+ (let ((sxml (options->sxml advanced-uuid options "basic filo")))
+ (test-equal "advanced: filo basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$400.00" "$252.00" "$800.00"
++ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$400.00" "$252.00" "$800.00"
+ "$553.00" "$143.00" "-$148.00" "-$5.00" "-0.63%" "$4.00" "$10.00"
+ "-$1.00" "-0.13%")
+ (sxml->table-row-col sxml 1 1 #f))))
+ (teardown)))
diff --cc gnucash/report/trep-engine.scm
index 264c4cb7e,000000000..c317941b4
mode 100644,000000..100644
--- a/gnucash/report/trep-engine.scm
+++ b/gnucash/report/trep-engine.scm
@@@ -1,2274 -1,0 +1,2261 @@@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; trep-engine.scm : Transaction Report engine
+;;
+;; Original report by Robert Merkel <rgmerk at mira.net>
+;; Contributions by Bryan Larsen <blarsen at ada-works.com>
+;; More contributions for new report generation code by Robert Merkel
+;; More contributions by Christian Stimming <stimming at tuhh.de>
+;; Modified to support the intersection of two account lists by
+;; Michael T. Garrison Stuber
+;; Modified account names display by Tomas Pospisek
+;; <tpo_deb at sourcepole.ch> with a lot of help from "warlord"
+;; Refactored by Christopher Lam (2017)
+;; - introduced account/transaction substring/regex matcher
+;; - add custom sorter in scheme
+;; - common currency - optionally show original currency amount
+;; and enable multiple data columns
+;; - add support for indenting for better grouping
+;; - add subtotal summary grid
+;; - by default, exclude closing transactions from the report
+;; - converted to module in 2019
+;; - CSV export, exports the report headers and totals
+;;
+;; 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 at gnu.org
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (gnucash core-utils))
+(use-modules (srfi srfi-11))
+(use-modules (srfi srfi-1))
+(use-modules (ice-9 match))
+
+;; Define the strings here to avoid typos and make changes easier.
+
+;;Accounts
+(define optname-accounts (N_ "Accounts"))
+(define optname-filterby (N_ "Filter By..."))
+(define optname-filtertype (N_ "Filter Type"))
+
+;;Display
+(define optname-detail-level (N_ "Detail Level"))
+(define optname-grid (N_ "Subtotal Table"))
+
+;;Sorting
+(define pagename-sorting (N_ "Sorting"))
+(define optname-prime-sortkey (N_ "Primary Key"))
+(define optname-prime-subtotal (N_ "Primary Subtotal"))
+(define optname-prime-sortorder (N_ "Primary Sort Order"))
+(define optname-prime-date-subtotal (N_ "Primary Subtotal for Date Key"))
+(define optname-full-account-name (N_ "Show Full Account Name"))
+(define optname-show-account-code (N_ "Show Account Code"))
+(define optname-show-account-description (N_ "Show Account Description"))
+(define optname-show-informal-headers (N_ "Show Informal Debit/Credit Headers"))
+(define optname-show-subtotals-only
+ (N_ "Show subtotals only (hide transactional data)"))
+(define optname-indenting (N_ "Add indenting columns"))
+(define optname-sec-sortkey (N_ "Secondary Key"))
+(define optname-sec-subtotal (N_ "Secondary Subtotal"))
+(define optname-sec-sortorder (N_ "Secondary Sort Order"))
+(define optname-sec-date-subtotal (N_ "Secondary Subtotal for Date Key"))
+
+;;General
+(define optname-startdate (N_ "Start Date"))
+(define optname-enddate (N_ "End Date"))
+(define optname-table-export (N_ "Table for Exporting"))
+(define optname-common-currency (N_ "Common Currency"))
+(define optname-orig-currency (N_ "Show original currency amount"))
+(define optname-currency (N_ "Report's currency"))
+(define optname-infobox-display (N_ "Add options summary"))
+
+;;Filtering
+(define pagename-filter (N_ "Filter"))
+(define optname-account-matcher (N_ "Account Name Filter"))
+(define optname-account-matcher-regex
+ (N_ "Use regular expressions for account name filter"))
+(define optname-transaction-matcher (N_ "Transaction Filter"))
+(define optname-transaction-matcher-regex
+ (N_ "Use regular expressions for transaction filter"))
+(define optname-transaction-matcher-exclude
+ (N_ "Transaction Filter excludes matched strings"))
+(define optname-transaction-matcher-caseinsensitive
+ (N_ "Transaction Filter is case insensitive"))
+(define optname-reconcile-status (N_ "Reconcile Status"))
+(define optname-void-transactions (N_ "Void Transactions"))
+(define optname-closing-transactions (N_ "Closing transactions"))
+
+;;Styles
+(define def:grand-total-style "grand-total")
+(define def:normal-row-style "normal-row")
+(define def:alternate-row-style "alternate-row")
+(define def:primary-subtotal-style "primary-subheading")
+(define def:secondary-subtotal-style "secondary-subheading")
+
+(define NO-MATCHING-TRANS-HEADER (_ "No matching transactions found"))
+(define NO-MATCHING-TRANS-TEXT (_ "No transactions were found that \
+match the time interval and account selection specified \
+in the Options panel."))
+
+(define DATE-SORTING-TYPES
+ (list 'date 'reconciled-date))
+
+(define ACCOUNT-SORTING-TYPES
+ (list 'account-name 'corresponding-acc-name
+ 'account-code 'corresponding-acc-code))
+
+(define SORTKEY-INFORMAL-HEADERS
+ (list 'account-name 'account-code))
+
+(define reconcile-list
+ (list (cons #\n (_ "Unreconciled"))
+ (cons #\c (_ "Cleared"))
+ (cons #\y (_ "Reconciled"))
+ (cons #\f (_ "Frozen"))
+ (cons #\v (_ "Voided"))))
+
+(define (sortkey-list split-action?)
+ ;; Defines the different sorting keys, as an association-list
+ ;; together with the subtotal functions. Each entry:
+ ;; 'sortkey - sort parameter sent via qof-query
+ ;; 'split-sortvalue - function retrieves number/string for comparing splits
+ ;; 'text - text displayed in Display tab
+ ;; 'tip - tooltip displayed in Display tab
+ ;; 'renderer-fn - helper function to select subtotal/subheading renderer
+ ;; behaviour varies according to sortkey.
+ ;; account-types converts split->account
+ ;; #f means the sortkey cannot be subtotalled
+ ;; otherwise it converts split->string
+ ;;
+ (list (list 'account-name
+ (cons 'sortkey (list SPLIT-ACCT-FULLNAME))
+ (cons 'split-sortvalue
+ (compose gnc-account-get-full-name xaccSplitGetAccount))
+ (cons 'text (_ "Account Name"))
+ (cons 'tip (_ "Sort & subtotal by account name."))
+ (cons 'renderer-fn xaccSplitGetAccount))
+
+ (list 'account-code
+ (cons 'sortkey (list SPLIT-ACCOUNT ACCOUNT-CODE-))
+ (cons 'split-sortvalue (compose xaccAccountGetCode xaccSplitGetAccount))
+ (cons 'text (_ "Account Code"))
+ (cons 'tip (_ "Sort & subtotal by account code."))
+ (cons 'renderer-fn xaccSplitGetAccount))
+
+ (list 'date
+ (cons 'sortkey (list SPLIT-TRANS TRANS-DATE-POSTED))
+ (cons 'split-sortvalue (compose xaccTransGetDate xaccSplitGetParent))
+ (cons 'text (_ "Date"))
+ (cons 'tip (_ "Sort by date."))
+ (cons 'renderer-fn #f))
+
+ (list 'reconciled-date
+ (cons 'sortkey (list SPLIT-DATE-RECONCILED))
+ (cons 'split-sortvalue xaccSplitGetDateReconciled)
+ (cons 'text (_ "Reconciled Date"))
+ (cons 'tip (_ "Sort by the Reconciled Date."))
+ (cons 'renderer-fn #f))
+
+ (list 'reconciled-status
+ (cons 'sortkey #f)
+ (cons 'split-sortvalue (lambda (s)
+ (length (memv (xaccSplitGetReconcile s)
+ (map car reconcile-list)))))
+ (cons 'text (_ "Reconciled Status"))
+ (cons 'tip (_ "Sort by the Reconciled Status"))
+ (cons 'renderer-fn (lambda (s)
+ (assv-ref reconcile-list
+ (xaccSplitGetReconcile s)))))
+
+ (list 'register-order
+ (cons 'sortkey (list QUERY-DEFAULT-SORT))
+ (cons 'split-sortvalue #f)
+ (cons 'text (_ "Register Order"))
+ (cons 'tip (_ "Sort as in the register."))
+ (cons 'renderer-fn #f))
+
+ (list 'corresponding-acc-name
+ (cons 'sortkey (list SPLIT-CORR-ACCT-NAME))
+ (cons 'split-sortvalue xaccSplitGetCorrAccountFullName)
+ (cons 'text (_ "Other Account Name"))
+ (cons 'tip (_ "Sort by account transferred from/to's name."))
+ (cons 'renderer-fn (compose xaccSplitGetAccount xaccSplitGetOtherSplit)))
+
+ (list 'corresponding-acc-code
+ (cons 'sortkey (list SPLIT-CORR-ACCT-CODE))
+ (cons 'split-sortvalue xaccSplitGetCorrAccountCode)
+ (cons 'text (_ "Other Account Code"))
+ (cons 'tip (_ "Sort by account transferred from/to's code."))
+ (cons 'renderer-fn (compose xaccSplitGetAccount xaccSplitGetOtherSplit)))
+
+ (list 'amount
+ (cons 'sortkey (list SPLIT-VALUE))
+ (cons 'split-sortvalue xaccSplitGetValue)
+ (cons 'text (_ "Amount"))
+ (cons 'tip (_ "Sort by amount."))
+ (cons 'renderer-fn #f))
+
+ (list 'description
+ (cons 'sortkey (list SPLIT-TRANS TRANS-DESCRIPTION))
+ (cons 'split-sortvalue (compose xaccTransGetDescription
+ xaccSplitGetParent))
+ (cons 'text (_ "Description"))
+ (cons 'tip (_ "Sort by description."))
+ (cons 'renderer-fn (compose xaccTransGetDescription xaccSplitGetParent)))
+
+ (if split-action?
+ (list 'number
+ (cons 'sortkey (list SPLIT-ACTION))
+ (cons 'split-sortvalue xaccSplitGetAction)
+ (cons 'text (_ "Number/Action"))
+ (cons 'tip (_ "Sort by check number/action."))
+ (cons 'renderer-fn #f))
+
+ (list 'number
+ (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
+ (cons 'split-sortvalue (compose xaccTransGetNum xaccSplitGetParent))
+ (cons 'text (_ "Number"))
+ (cons 'tip (_ "Sort by check/transaction number."))
+ (cons 'renderer-fn #f)))
+
+ (list 't-number
+ (cons 'sortkey (list SPLIT-TRANS TRANS-NUM))
+ (cons 'split-sortvalue (compose xaccTransGetNum xaccSplitGetParent))
+ (cons 'text (_ "Transaction Number"))
+ (cons 'tip (_ "Sort by transaction number."))
+ (cons 'renderer-fn #f))
+
+ (list 'memo
+ (cons 'sortkey (list SPLIT-MEMO))
+ (cons 'split-sortvalue xaccSplitGetMemo)
+ (cons 'text (_ "Memo"))
+ (cons 'tip (_ "Sort by memo."))
+ (cons 'renderer-fn xaccSplitGetMemo))
+
+ (list 'notes
+ (cons 'sortkey #f)
+ (cons 'split-sortvalue (compose xaccTransGetNotes xaccSplitGetParent))
+ (cons 'text (_ "Notes"))
+ (cons 'tip (_ "Sort by transaction notes."))
+ (cons 'renderer-fn (compose xaccTransGetNotes xaccSplitGetParent)))
+
+ (list 'none
+ (cons 'sortkey '())
+ (cons 'split-sortvalue #f)
+ (cons 'text (_ "None"))
+ (cons 'tip (_ "Do not sort."))
+ (cons 'renderer-fn #f))))
+
+(define (time64-year t64)
+ (gnc:date-get-year (gnc-localtime t64)))
+(define (time64-quarter t64)
+ (+ (* 10 (gnc:date-get-year (gnc-localtime t64)))
+ (gnc:date-get-quarter (gnc-localtime t64))))
+(define (time64-month t64)
+ (+ (* 100 (gnc:date-get-year (gnc-localtime t64)))
+ (gnc:date-get-month (gnc-localtime t64))))
+(define (time64-week t64)
+ (gnc:date-get-week (gnc-localtime t64)))
+(define (time64-day t64)
+ (+ (* 500 (gnc:date-get-year (gnc-localtime t64)))
+ (gnc:date-get-year-day (gnc-localtime t64))))
+(define (split->time64 s)
+ (xaccTransGetDate (xaccSplitGetParent s)))
+
+(define date-subtotal-list
+ ;; List for date option.
+ ;; Defines the different date sorting keys, as an association-list. Each entry:
+ ;; 'split-sortvalue - func retrieves number/string used for comparing splits
+ ;; 'text - text displayed in Display tab
+ ;; 'tip - tooltip displayed in Display tab
+ ;; 'renderer-fn - func retrieves string for subtotal/subheading renderer
+ ;; #f means the date sortkey is not grouped
+ ;; otherwise it converts split->string
+ (list
+ (list 'none
+ (cons 'split-sortvalue #f)
+ (cons 'date-sortvalue #f)
+ (cons 'text (_ "None"))
+ (cons 'tip (_ "None."))
+ (cons 'renderer-fn #f))
+
+ (list 'daily
+ (cons 'split-sortvalue (lambda (s) (time64-day (split->time64 s))))
+ (cons 'date-sortvalue time64-day)
+ (cons 'text (_ "Daily"))
+ (cons 'tip (_ "Daily."))
+ (cons 'renderer-fn (lambda (s) (qof-print-date (split->time64 s)))))
+
+ (list 'weekly
+ (cons 'split-sortvalue (lambda (s) (time64-week (split->time64 s))))
+ (cons 'date-sortvalue time64-week)
+ (cons 'text (_ "Weekly"))
+ (cons 'tip (_ "Weekly."))
+ (cons 'renderer-fn (compose gnc:date-get-week-year-string
+ gnc-localtime
+ split->time64)))
+
+ (list 'monthly
+ (cons 'split-sortvalue (lambda (s) (time64-month (split->time64 s))))
+ (cons 'date-sortvalue time64-month)
+ (cons 'text (_ "Monthly"))
+ (cons 'tip (_ "Monthly."))
+ (cons 'renderer-fn (compose gnc:date-get-month-year-string
+ gnc-localtime
+ split->time64)))
+
+ (list 'quarterly
+ (cons 'split-sortvalue (lambda (s) (time64-quarter (split->time64 s))))
+ (cons 'date-sortvalue time64-quarter)
+ (cons 'text (_ "Quarterly"))
+ (cons 'tip (_ "Quarterly."))
+ (cons 'renderer-fn (compose gnc:date-get-quarter-year-string
+ gnc-localtime
+ split->time64)))
+
+ (list 'yearly
+ (cons 'split-sortvalue (lambda (s) (time64-year (split->time64 s))))
+ (cons 'date-sortvalue time64-year)
+ (cons 'text (_ "Yearly"))
+ (cons 'tip (_ "Yearly."))
+ (cons 'renderer-fn (compose gnc:date-get-year-string
+ gnc-localtime
+ split->time64)))))
+
+(define filter-list
+ (list
+ (list 'none
+ (cons 'text (_ "None"))
+ (cons 'tip (_ "Do not do any filtering.")))
+
+ (list 'include
+ (cons 'text (_ "Include Transactions to/from Filter Accounts"))
+ (cons 'tip (_ "Include transactions to/from filter accounts only.")))
+
+ (list 'exclude
+ (cons 'text (_ "Exclude Transactions to/from Filter Accounts"))
+ (cons 'tip (_ "Exclude transactions to/from all filter accounts.")))))
+
+(define show-void-list
+ (list
+ (list 'non-void-only
+ (cons 'text (_ "Non-void only"))
+ (cons 'tip (_ "Show only non-voided transactions.")))
+
+ (list 'void-only
+ (cons 'text (_ "Void only"))
+ (cons 'tip (_ "Show only voided transactions.")))
+
+ (list 'both
+ (cons 'text (_ "Both"))
+ (cons 'tip (_ "Show both (and include void transactions in totals).")))))
+
+(define show-closing-list
+ (list
+ (list 'exclude-closing
+ (cons 'text (_ "Exclude closing transactions"))
+ (cons 'tip (_ "Exclude closing transactions from report."))
+ (cons 'closing-match #f))
+
+ (list 'include-both
+ (cons 'text (_ "Show both closing and regular transactions"))
+ (cons 'tip (_ "Show both (and include closing transactions in totals)."))
+ (cons 'closing-match 'both))
+
+ (list 'closing-only
+ (cons 'text (_ "Show closing transactions only"))
+ (cons 'tip (_ "Show only closing transactions."))
+ (cons 'closing-match #t))))
+
+(define reconcile-status-list
+ ;; 'filter-types must be either #f (i.e. disable reconcile filter)
+ ;; or a value defined as defined in Query.c
+ ;; e.g. CLEARED-NO for unreconciled
+ ;; (logior CLEARED-NO CLEARED-CLEARED) for unreconciled & cleared
+ (list
+ (list 'all
+ (cons 'text (_ "All"))
+ (cons 'tip (_ "Show All Transactions"))
+ (cons 'filter-types #f))
+
+ (list 'unreconciled
+ (cons 'text (_ "Unreconciled"))
+ (cons 'tip (_ "Unreconciled only"))
+ (cons 'filter-types CLEARED-NO))
+
+ (list 'cleared
+ (cons 'text (_ "Cleared"))
+ (cons 'tip (_ "Cleared only"))
+ (cons 'filter-types CLEARED-CLEARED))
+
+ (list 'reconciled
+ (cons 'text (_ "Reconciled"))
+ (cons 'tip (_ "Reconciled only"))
+ (cons 'filter-types CLEARED-RECONCILED))))
+
+
+(define ascending-list
+ (list
+ (list 'ascend
+ (cons 'text (_ "Ascending"))
+ (cons 'tip (_ "Smallest to largest, earliest to latest.")))
+ (list 'descend
+ (cons 'text (_ "Descending"))
+ (cons 'tip (_ "Largest to smallest, latest to earliest.")))))
+
+(define sign-reverse-list
+ (list
+ (list 'global
+ (cons 'text (_ "Use Global Preference"))
+ (cons 'tip (_ "Use reversing option specified in global preference."))
+ (cons 'acct-types #f))
+ (list 'none
+ (cons 'text (_ "None"))
+ (cons 'tip (_ "Don't change any displayed amounts."))
+ (cons 'acct-types '()))
+ (list 'income-expense
+ (cons 'text (_ "Income and Expense"))
+ (cons 'tip (_ "Reverse amount display for Income and Expense Accounts."))
+ (cons 'acct-types (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE)))
+ (list 'credit-accounts
+ (cons 'text (_ "Credit Accounts"))
+ (cons 'tip (_ "Reverse amount display for Liability, Payable, Equity, \
+Credit Card, and Income accounts."))
+ (cons 'acct-types (list ACCT-TYPE-LIABILITY ACCT-TYPE-PAYABLE
+ ACCT-TYPE-EQUITY ACCT-TYPE-CREDIT
+ ACCT-TYPE-INCOME)))))
+
+(define (keylist-get-info keylist key info)
+ (assq-ref (assq-ref keylist key) info))
+
+(define (keylist->vectorlist keylist)
+ (map
+ (lambda (item)
+ (vector
+ (car item)
+ (keylist-get-info keylist (car item) 'text)
+ (keylist-get-info keylist (car item) 'tip)))
+ keylist))
+
+(define (SUBTOTAL-ENABLED? sortkey split-action?)
+ ;; this returns whether sortkey *can* be subtotalled/grouped.
+ ;; it checks whether a renderer-fn is defined.
+ (keylist-get-info (sortkey-list split-action?) sortkey 'renderer-fn))
+
+(define (CUSTOM-SORTING? sortkey split-action?)
+ ;; 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 split-action?) sortkey 'split-sortvalue)
+ (not (keylist-get-info (sortkey-list split-action?) sortkey 'sortkey))))
+
+(define (lists->csv lst)
+ ;; converts a list of lists into CSV
+ ;; this function aims to follow RFC4180, and will pad lists to
+ ;; ensure equal number of items per row.
+ ;; e.g. '(("from" "01/01/2010")
+ ;; ("to" "31/12/2010")
+ ;; ("total" 23500 30000 25/7 'sym))
+ ;; will output
+ ;; "from","01/01/2010",,,
+ ;; "to","31/12/2010",,,
+ ;; "total",23500.0,30000.0,3.5714285714285716,sym
+ (define (string-sanitize-csv str)
+ (call-with-output-string
+ (lambda (port)
+ (display #\" port)
+ (string-for-each
+ (lambda (c)
+ (if (char=? c #\") (display #\" port))
+ (display c port))
+ str)
+ (display #\" port))))
+
+ (define max-items (apply max (map length lst)))
+
+ (define (strify obj)
+ (cond
+ ((not obj) "")
+ ((string? obj) (string-sanitize-csv obj))
+ ((number? obj) (number->string (exact->inexact obj)))
+ ((list? obj) (string-join
+ (map strify
+ (append obj
+ (make-list (- max-items (length obj)) #f)))
+ ","))
+ ((gnc:gnc-monetary? obj) (strify (gnc:gnc-monetary-amount obj)))
+ (else (object->string obj))))
+
+ (string-join (map strify lst) "\n"))
+
+
+;;
+;; Default Transaction Report
+;;
+(define (gnc:trep-options-generator)
+ (define options (gnc:new-options))
+ (define BOOK-SPLIT-ACTION
+ (qof-book-use-split-action-for-num-field (gnc-get-current-book)))
+ (define (gnc:register-trep-option new-option)
+ (gnc:register-option options new-option))
+
+ ;; (Feb 2018) Note to future hackers - this gnc:trep-options-generator
+ ;; defines a long set of options to be assigned as an object in
+ ;; the report. This long list (52 at Feb 2018 count) of options
+ ;; may be modified in a derived report (see income-gst-statement.scm)
+ ;; via gnc:make-internal! and gnc-unregister-option to hide
+ ;; and remove options, respectively. If an option is unregistered,
+ ;; don't forget to re-register them via gnc:register-option, unless
+ ;; your derived report truly does not require them.
+
+ ;; General options
+
+ (gnc:options-add-date-interval!
+ options gnc:pagename-general optname-startdate optname-enddate "a")
+
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ gnc:pagename-general optname-common-currency
+ "e" (_ "Convert all transactions into a common currency.") #f
+ #f
+ (lambda (x)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-general optname-currency x)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-general optname-orig-currency x))))
+
+ (gnc:options-add-currency!
+ options gnc:pagename-general optname-currency "f")
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-orig-currency
+ "f1" (_ "Also show original currency amounts") #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-general optname-table-export
+ "g" (_ "Formats the table suitable for cut & paste exporting with extra cells.")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ gnc:pagename-general optname-infobox-display
+ "h" (_ "Add summary of options.")
+ 'no-match
+ ;; This is an alist of conditions for displaying the infobox
+ ;; 'no-match for empty-report
+ ;; 'match for generated report
+ (list (vector 'no-match
+ (_ "If no transactions matched")
+ (_ "Display summary if no transactions were matched."))
+ (vector 'always
+ (_ "Always")
+ (_ "Always display summary."))
+ (vector 'never
+ (_ "Never")
+ (_ "Disable report summary.")))))
+
+ ;; Filtering Options
+
+ (gnc:register-trep-option
+ (gnc:make-string-option
+ pagename-filter optname-account-matcher
+ "a5" (_ "Show only accounts whose full name matches this filter e.g. ':Travel' will match \
+Expenses:Travel:Holiday and Expenses:Business:Travel. It can be left blank, which will \
+disable the filter.")
+ ""))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-filter optname-account-matcher-regex
+ "a6"
+ (_ "By default the account filter will search substring only. Set this to true to \
+enable full POSIX regular expressions capabilities. 'Car|Flights' will match both \
+Expenses:Car and Expenses:Flights. Use a period (.) to match a single character e.g. \
+'20../.' will match 'Travel 2017/1 London'. ")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-string-option
+ pagename-filter optname-transaction-matcher
+ "i1" (_ "Show only transactions where description, notes, or memo matches this filter.
+e.g. '#gift' will find all transactions with #gift in description, notes or memo. It can be left \
+blank, which will disable the filter.")
+ ""))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-filter optname-transaction-matcher-regex
+ "i2"
+ (_ "By default the transaction filter will search substring only. Set this to true to \
+enable full POSIX regular expressions capabilities. '#work|#family' will match both \
+tags within description, notes or memo. ")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-filter optname-transaction-matcher-exclude
+ "i3"
+ (_ "If this option is selected, transactions matching filter are excluded.")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-filter optname-transaction-matcher-caseinsensitive
+ "i4"
+ (_ "If this option is selected, transactions matching filter is not case sensitive.")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-filter optname-reconcile-status
+ "j1" (_ "Filter by reconcile status.")
+ 'all
+ (keylist->vectorlist reconcile-status-list)))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-filter optname-void-transactions
+ "k" (N_ "How to handle void transactions.")
+ 'non-void-only
+ (keylist->vectorlist show-void-list)))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-filter optname-closing-transactions
+ "l" (_ "By default most users should not include closing \
+transactions in a transaction report. Closing transactions are \
+transfers from income and expense accounts to equity, and must usually \
+be excluded from periodic reporting.")
+ 'exclude-closing
+ (keylist->vectorlist show-closing-list)))
+
+ ;; Accounts options
+
+ ;; account to do report on
+ (gnc:register-trep-option
+ (gnc:make-account-list-option
+ gnc:pagename-accounts optname-accounts
+ "a" (_ "Report on these accounts.")
+ ;; select, by default, no accounts! Selecting all accounts will
+ ;; always imply an insanely long waiting time upon opening, and it
+ ;; is almost never useful. So we instead display the normal error
+ ;; message saying "Click here", and the user knows how to
+ ;; continue.
+ (lambda ()
+ '())
+ #f #t))
+
+ (gnc:register-trep-option
+ (gnc:make-account-list-option
+ gnc:pagename-accounts optname-filterby
+ "c1" (_ "Filter on these accounts.")
+ (lambda ()
+ '())
+ #f #t))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ gnc:pagename-accounts optname-filtertype
+ "c" (_ "Filter account.")
+ 'none
+ (keylist->vectorlist filter-list)
+ #f
+ (lambda (x)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-accounts optname-filterby
+ (not (eq? x 'none))))))
+
+ ;; Sorting options
+
+ (let ((ascending-choice-list (keylist->vectorlist ascending-list))
+ (key-choice-list (keylist->vectorlist (sortkey-list BOOK-SPLIT-ACTION)))
+ (date-subtotal-choice-list (keylist->vectorlist date-subtotal-list))
+ (prime-sortkey 'account-name)
+ (prime-sortkey-subtotal-true #t)
+ (prime-date-subtotal 'monthly)
+ (sec-sortkey 'register-order)
+ (sec-sortkey-subtotal-true #f)
+ (sec-date-subtotal 'monthly))
+
+ (define (apply-selectable-by-name-sorting-options)
+ (let* ((prime-sortkey-enabled (not (eq? prime-sortkey 'none)))
+ (prime-sortkey-subtotal-enabled
+ (SUBTOTAL-ENABLED? prime-sortkey BOOK-SPLIT-ACTION))
+ (prime-date-sortingtype-enabled (memq prime-sortkey DATE-SORTING-TYPES))
+ (sec-sortkey-enabled (not (eq? sec-sortkey 'none)))
+ (sec-sortkey-subtotal-enabled
+ (SUBTOTAL-ENABLED? sec-sortkey BOOK-SPLIT-ACTION))
+ (sec-date-sortingtype-enabled (memq sec-sortkey DATE-SORTING-TYPES)))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-prime-subtotal
+ prime-sortkey-subtotal-enabled)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-prime-sortorder
+ prime-sortkey-enabled)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-sec-subtotal
+ sec-sortkey-subtotal-enabled)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-sec-sortorder
+ sec-sortkey-enabled)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-full-account-name
+ (or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
+ (and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-show-account-code
+ (or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
+ (and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-show-account-description
+ (or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
+ (and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-indenting
+ (or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
+ (and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)
+ (and prime-date-sortingtype-enabled (not (eq? 'none prime-date-subtotal)))
+ (and sec-date-sortingtype-enabled (not (eq? 'none sec-date-subtotal)))))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-show-subtotals-only
+ (or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
+ (and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)
+ (and prime-date-sortingtype-enabled (not (eq? 'none prime-date-subtotal)))
+ (and sec-date-sortingtype-enabled (not (eq? 'none sec-date-subtotal)))))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-show-informal-headers
+ (or (memq prime-sortkey (list 'account-name 'account-code))
+ (memq sec-sortkey (list 'account-name 'account-code))))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-prime-date-subtotal
+ prime-date-sortingtype-enabled)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options pagename-sorting optname-sec-date-subtotal
+ sec-date-sortingtype-enabled)))
+
+ ;; primary sorting criterion
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-prime-sortkey
+ "a" (_ "Sort by this criterion first.")
+ prime-sortkey
+ key-choice-list #f
+ (lambda (x)
+ (set! prime-sortkey x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-full-account-name
+ "j1"
+ (_ "Show the full account name for subtotals and subheadings?")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-show-account-code
+ "j2"
+ (_ "Show the account code for subtotals and subheadings?")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-show-account-description
+ "j3"
+ (_ "Show the account description for subheadings?")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-show-informal-headers
+ "j4"
+ (_ "Show the informal headers for debit/credit accounts?")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-indenting
+ "j5"
+ (_ "Add indenting columns with grouping and subtotals?")
+ #t))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ pagename-sorting optname-show-subtotals-only
+ "j6"
+ (_ "Show subtotals only, hiding transactional detail?")
+ #f))
+
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ pagename-sorting optname-prime-subtotal
+ "e5"
+ (_ "Subtotal according to the primary key?")
+ prime-sortkey-subtotal-true #f
+ (lambda (x)
+ (set! prime-sortkey-subtotal-true x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-prime-date-subtotal
+ "e2" (_ "Do a date subtotal.")
+ prime-date-subtotal
+ date-subtotal-choice-list #f
+ (lambda (x)
+ (set! prime-date-subtotal x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting optname-prime-sortorder
+ "e" (_ "Order of primary sorting.")
+ 'ascend
+ ascending-choice-list))
+
+ ;; Secondary sorting criterion
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-sec-sortkey
+ "f"
+ (_ "Sort by this criterion second.")
+ sec-sortkey
+ key-choice-list #f
+ (lambda (x)
+ (set! sec-sortkey x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ pagename-sorting optname-sec-subtotal
+ "i5"
+ (_ "Subtotal according to the secondary key?")
+ sec-sortkey-subtotal-true #f
+ (lambda (x)
+ (set! sec-sortkey-subtotal-true x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ pagename-sorting optname-sec-date-subtotal
+ "i2" (_ "Do a date subtotal.")
+ sec-date-subtotal
+ date-subtotal-choice-list #f
+ (lambda (x)
+ (set! sec-date-subtotal x)
+ (apply-selectable-by-name-sorting-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ pagename-sorting optname-sec-sortorder
+ "i" (_ "Order of Secondary sorting.")
+ 'ascend
+ ascending-choice-list)))
+
+ ;; Display options
+
+ (let ((disp-memo? #t)
+ (disp-accname? #t)
+ (disp-other-accname? #f)
+ (detail-is-single? #t)
+ (amount-value 'single))
+
+ (define (apply-selectable-by-name-display-options)
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Use Full Account Name")
+ disp-accname?)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Other Account Name")
+ detail-is-single?)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Sign Reverses")
+ (eq? amount-value 'single))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display optname-grid
+ (eq? amount-value 'single))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display "Enable links"
+ (not (eq? amount-value 'none)))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Use Full Other Account Name")
+ (and disp-other-accname? detail-is-single?))
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Other Account Code")
+ detail-is-single?)
+
+ (gnc-option-db-set-option-selectable-by-name
+ options gnc:pagename-display (N_ "Notes")
+ disp-memo?))
+
+ (for-each
+ (lambda (l)
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display (car l) (cadr l) (caddr l) (cadddr l))))
+ ;; One list per option here with: option-name, sort-tag,
+ ;; help-string, default-value
+ (list
+ (list (N_ "Date") "a" (_ "Display the date?") #t)
+ (list (N_ "Reconciled Date") "a2" (_ "Display the reconciled date?") #f)
+ (if BOOK-SPLIT-ACTION
+ (list (N_ "Num/Action") "b" (_ "Display the check number?") #t)
+ (list (N_ "Num") "b" (_ "Display the check number?") #t))
+ (list (N_ "Description") "c" (_ "Display the description?") #t)
+ (list (N_ "Notes") "d2" (_ "Display the notes if the memo is unavailable?") #t)
+ ;; account name option appears here
+ (list (N_ "Use Full Account Name") "f" (_ "Display the full account name?") #t)
+ (list (N_ "Account Code") "g" (_ "Display the account code?") #f)
+ ;; other account name option appears here
+ (list (N_ "Use Full Other Account Name") "i" (_ "Display the full account name?") #f)
+ (list (N_ "Other Account Code") "j" (_ "Display the other account code?") #f)
+ (list (N_ "Shares") "k" (_ "Display the number of shares?") #f)
+ (list (N_ "Price") "l" (_ "Display the shares price?") #f)
+ ;; note the "Amount" multichoice option in between here
+ (list optname-grid "m5" (_ "Display a subtotal summary table. This requires Display/Amount being 'single") #f)
+ (list (N_ "Running Balance") "n" (_ "Display a running balance?") #f)
+ (list (N_ "Totals") "o" (_ "Display the totals?") #t)))
+
+ (when BOOK-SPLIT-ACTION
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display (N_ "Trans Number")
+ "b2" (_ "Display the trans number?") #f)))
+
+ ;; Add an option to display the memo, and disable the notes option
+ ;; when memos are not included.
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ gnc:pagename-display (N_ "Memo")
+ "d" (_ "Display the memo?") #t
+ disp-memo?
+ (lambda (x)
+ (set! disp-memo? x)
+ (apply-selectable-by-name-display-options))))
+
+ ;; Ditto for Account Name #t -> Use Full Account Name is selectable
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ gnc:pagename-display (N_ "Account Name")
+ "e" (_ "Display the account name?") #t
+ disp-accname?
+ (lambda (x)
+ (set! disp-accname? x)
+ (apply-selectable-by-name-display-options))))
+
+ ;; Ditto for Other Account Name #t -> Use Full Other Account Name is selectable
+ (gnc:register-trep-option
+ (gnc:make-complex-boolean-option
+ gnc:pagename-display (N_ "Other Account Name")
+ "h5" (_ "Display the other account name? (if this is a split transaction, this parameter is guessed).") #f
+ disp-other-accname?
+ (lambda (x)
+ (set! disp-other-accname? x)
+ (apply-selectable-by-name-display-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ gnc:pagename-display optname-detail-level
+ "h" (_ "Amount of detail to display per transaction.")
+ 'single
+ (list (vector 'multi-line
+ (_ "Multi-Line")
+ (_ "Display all splits in a transaction on a separate line."))
+ (vector 'single
+ (_ "Single")
+ (_ "Display one line per transaction, merging multiple splits where required.")))
+ #f
+ (lambda (x)
+ (set! detail-is-single? (eq? x 'single))
+ (apply-selectable-by-name-display-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-callback-option
+ gnc:pagename-display (N_ "Amount")
+ "m" (_ "Display the amount?")
+ amount-value
+ (list
+ (vector 'none (_ "None") (_ "No amount display."))
+ (vector 'single (_ "Single") (_ "Single Column Display."))
+ (vector 'double (_ "Double") (_ "Two Column Display.")))
+ #f
+ (lambda (x)
+ (set! amount-value x)
+ (apply-selectable-by-name-display-options))))
+
+ (gnc:register-trep-option
+ (gnc:make-simple-boolean-option
+ gnc:pagename-display (N_ "Enable links")
+ "m2" (_ "Enable hyperlinks in amounts.") #t))
+
+ (gnc:register-trep-option
+ (gnc:make-multichoice-option
+ gnc:pagename-display (N_ "Sign Reverses")
+ "m1" (_ "Reverse amount display for certain account types.")
+ 'global
+ (keylist->vectorlist sign-reverse-list))))
+
+ ;; this hidden option will toggle whether the default
+ ;; qof-query is run, or a different query which ensures
+ ;; no transaction is duplicated. It can be enabled in
+ ;; a derived report (eg income-gst-statement.scm)
+ (gnc:register-trep-option
+ (gnc:make-internal-option "__trep" "unique-transactions" #f))
+
+ (gnc:options-set-default-section options gnc:pagename-general)
+ options)
+
+;; ;;;;;;;;;;;;;;;;;;;;
+;; Here comes the big function that builds the whole table.
+
+(define (make-split-table splits options custom-calculated-cells
+ begindate)
+
+ (define (opt-val section name)
+ (let ((option (gnc:lookup-option options section name)))
+ (if option
+ (gnc:option-value option)
+ (gnc:error "gnc:lookup-option error: " section "/" name))))
+ (define BOOK-SPLIT-ACTION
+ (qof-book-use-split-action-for-num-field (gnc-get-current-book)))
+
+ (define (build-columns-used)
+ (define detail-is-single?
+ (eq? (opt-val gnc:pagename-display optname-detail-level) 'single))
+ (define amount-setting (opt-val gnc:pagename-display (N_ "Amount")))
+ (list (cons 'date (opt-val gnc:pagename-display (N_ "Date")))
+ (cons 'reconciled-date (opt-val gnc:pagename-display (N_ "Reconciled Date")))
+ (cons 'num (if BOOK-SPLIT-ACTION
+ (opt-val gnc:pagename-display (N_ "Num/Action"))
+ (opt-val gnc:pagename-display (N_ "Num"))))
+ (cons 'description (opt-val gnc:pagename-display (N_ "Description")))
+ (cons 'account-name (opt-val gnc:pagename-display (N_ "Account Name")))
+ (cons 'other-account-name
+ (and detail-is-single?
+ (opt-val gnc:pagename-display (N_ "Other Account Name"))))
+ (cons 'shares (opt-val gnc:pagename-display (N_ "Shares")))
+ (cons 'price (opt-val gnc:pagename-display (N_ "Price")))
+ (cons 'amount-single (eq? amount-setting 'single))
+ (cons 'amount-double (eq? amount-setting 'double))
+ (cons 'common-currency (opt-val gnc:pagename-general optname-common-currency))
+ (cons 'amount-original-currency
+ (and (opt-val gnc:pagename-general optname-common-currency)
+ (opt-val gnc:pagename-general optname-orig-currency)))
+ (cons 'indenting (opt-val pagename-sorting optname-indenting))
+ (cons 'subtotals-only
+ (and (opt-val pagename-sorting optname-show-subtotals-only)
+ (or (primary-get-info 'renderer-fn)
+ (secondary-get-info 'renderer-fn))))
+ (cons 'running-balance (opt-val gnc:pagename-display (N_ "Running Balance")))
+ (cons 'account-full-name
+ (opt-val gnc:pagename-display (N_ "Use Full Account Name")))
+ (cons 'memo (opt-val gnc:pagename-display (N_ "Memo")))
+ (cons 'account-code (opt-val gnc:pagename-display (N_ "Account Code")))
+ (cons 'other-account-code
+ (and detail-is-single?
+ (opt-val gnc:pagename-display (N_ "Other Account Code"))))
+ (cons 'other-account-full-name
+ (and detail-is-single?
+ (opt-val gnc:pagename-display (N_ "Use Full Other Account Name"))))
+ (cons 'sort-account-code (opt-val pagename-sorting (N_ "Show Account Code")))
+ (cons 'sort-account-full-name
+ (opt-val pagename-sorting (N_ "Show Full Account Name")))
+ (cons 'sort-account-description
+ (opt-val pagename-sorting (N_ "Show Account Description")))
+ (cons 'notes (opt-val gnc:pagename-display (N_ "Notes")))))
+
+ (define (primary-get-info info)
+ (let ((sortkey (opt-val pagename-sorting optname-prime-sortkey)))
+ (if (memq sortkey DATE-SORTING-TYPES)
+ (keylist-get-info
+ date-subtotal-list
+ (opt-val pagename-sorting optname-prime-date-subtotal) info)
+ (and (SUBTOTAL-ENABLED? sortkey BOOK-SPLIT-ACTION)
+ (opt-val pagename-sorting optname-prime-subtotal)
+ (keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) sortkey info)))))
+
+ (define (secondary-get-info info)
+ (let ((sortkey (opt-val pagename-sorting optname-sec-sortkey)))
+ (if (memq sortkey DATE-SORTING-TYPES)
+ (keylist-get-info
+ date-subtotal-list
+ (opt-val pagename-sorting optname-sec-date-subtotal) info)
+ (and (SUBTOTAL-ENABLED? sortkey BOOK-SPLIT-ACTION)
+ (opt-val pagename-sorting optname-sec-subtotal)
+ (keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) sortkey info)))))
+
+ (let* ((work-to-do (length splits))
+ (table (gnc:make-html-table))
+ (used-columns (build-columns-used))
+ (opt-use-links? (opt-val gnc:pagename-display "Enable links"))
+ (account-types-to-reverse
+ (keylist-get-info sign-reverse-list
+ (opt-val gnc:pagename-display (N_ "Sign Reverses"))
+ 'acct-types))
+ (is-multiline? (eq? (opt-val gnc:pagename-display optname-detail-level)
+ 'multi-line))
+ (export? (opt-val gnc:pagename-general optname-table-export)))
+
+ (define (acc-reverse? acc)
+ (if account-types-to-reverse
+ (memv (xaccAccountGetType acc) account-types-to-reverse)
+ (gnc-reverse-balance acc)))
+
+ (define (column-uses? param)
+ (cdr (assq param used-columns)))
+
+ (define left-columns
+ (let* ((add-if (lambda (pred? . items) (if pred? items '())))
+ (left-cols-list
+ (append
+ (add-if (column-uses? 'date)
+ (vector (_ "Date")
+ (lambda (split transaction-row?)
+ (and transaction-row?
+ (gnc:make-html-table-cell/markup
+ "date-cell"
+ (qof-print-date
+ (xaccTransGetDate
+ (xaccSplitGetParent split))))))))
+
+ (add-if (column-uses? 'reconciled-date)
+ (vector (_ "Reconciled Date")
+ (lambda (split transaction-row?)
+ (let ((reconcile-date
+ (and (char=? (xaccSplitGetReconcile split) #\y)
+ (xaccSplitGetDateReconciled split))))
+ (and reconcile-date
+ (gnc:make-html-table-cell/markup
+ "date-cell"
+ (qof-print-date reconcile-date)))))))
+
+ (add-if (column-uses? 'num)
+ (vector (if (and BOOK-SPLIT-ACTION
+ (opt-val gnc:pagename-display
+ (N_ "Trans Number")))
+ (_ "Num/T-Num")
+ (_ "Num"))
+ (lambda (split transaction-row?)
+ (let* ((trans (xaccSplitGetParent split))
+ (num (gnc-get-num-action trans split))
+ (t-num (if (and BOOK-SPLIT-ACTION
+ (opt-val
+ gnc:pagename-display
+ (N_ "Trans Number")))
+ (gnc-get-num-action trans #f)
+ ""))
+ (num-string (if (string-null? t-num)
+ num
+ (string-append num "/" t-num))))
+ (and transaction-row?
+ (gnc:make-html-table-cell/markup
+ "text-cell" num-string))))))
+
+ (add-if (column-uses? 'description)
+ (vector (_ "Description")
+ (lambda (split transaction-row?)
+ (define trans (xaccSplitGetParent split))
+ (and transaction-row?
+ (gnc:make-html-table-cell/markup
+ "text-cell"
+ (xaccTransGetDescription trans))))))
+
+ (add-if (column-uses? 'memo)
+ (vector (if (column-uses? 'notes)
+ (string-append (_ "Memo") "/" (_ "Notes"))
+ (_ "Memo"))
+ (lambda (split transaction-row?)
+ (define trans (xaccSplitGetParent split))
+ (define memo (xaccSplitGetMemo split))
+ (if (and (string-null? memo) (column-uses? 'notes))
+ (xaccTransGetNotes trans)
+ memo))))
+
+ (add-if (or (column-uses? 'account-name) (column-uses? 'account-code))
+ (vector (_ "Account")
+ (lambda (split transaction-row?)
+ (account-namestring
+ (xaccSplitGetAccount split)
+ (column-uses? 'account-code)
+ (column-uses? 'account-name)
+ (column-uses? 'account-full-name)))))
+
+ (add-if (or (column-uses? 'other-account-name)
+ (column-uses? 'other-account-code))
+ (vector (_ "Transfer from/to")
+ (lambda (split transaction-row?)
+ (and (< 1 (xaccTransCountSplits
+ (xaccSplitGetParent split)))
+ (account-namestring
+ (xaccSplitGetAccount
+ (xaccSplitGetOtherSplit split))
+ (column-uses? 'other-account-code)
+ (column-uses? 'other-account-name)
+ (column-uses? 'other-account-full-name))))))
+
+ (add-if (column-uses? 'shares)
+ (vector (_ "Shares")
+ (lambda (split transaction-row?)
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (xaccSplitGetAmount split)))))
+
+ (add-if (column-uses? 'price)
+ (vector (_ "Price")
+ (lambda (split transaction-row?)
- ;; share price is retrieved as an
- ;; exact rational; convert for
- ;; presentation to decimal, rounded
- ;; to the currency SCU, optionally
- ;; increasing precision by 2
- ;; significant digits.
- (let* ((currency (xaccTransGetCurrency
- (xaccSplitGetParent split)))
- (scu (gnc-commodity-get-fraction currency))
- (price (xaccSplitGetSharePrice split))
- (price-decimal
- (gnc-numeric-convert
- price (min 10000 (* 100 scu))
- GNC-HOW-RND-ROUND)))
- (gnc:make-html-table-cell/markup
- "number-cell"
- (gnc:make-gnc-monetary
- currency price-decimal)))))))))
++ (gnc:make-html-table-cell/markup
++ "number-cell"
++ (gnc:default-price-renderer
++ (xaccTransGetCurrency (xaccSplitGetParent split))
++ (xaccSplitGetSharePrice split)))))))))
+
+ (if (or (column-uses? 'subtotals-only)
+ (and (null? left-cols-list)
+ (or (opt-val gnc:pagename-display "Totals")
+ (primary-get-info 'renderer-fn)
+ (secondary-get-info 'renderer-fn))))
+ (list (vector "" (lambda (s t) #f)))
+ left-cols-list)))
+
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;
+ ;; calculated-cells
+ ;;
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define default-calculated-cells
+ (letrec
+ ((split-amount (lambda (s) (if (gnc:split-voided? s)
+ (xaccSplitVoidFormerAmount s)
+ (xaccSplitGetAmount s))))
+ (split-currency (compose xaccAccountGetCommodity xaccSplitGetAccount))
+ (row-currency (lambda (s) (if (column-uses? 'common-currency)
+ (opt-val gnc:pagename-general optname-currency)
+ (split-currency s))))
+ (friendly-debit (lambda (a) (gnc-account-get-debit-string (xaccAccountGetType a))))
+ (friendly-credit (lambda (a) (gnc-account-get-credit-string (xaccAccountGetType a))))
+ (header-commodity (lambda (str)
+ (string-append
+ str
+ (if (column-uses? 'common-currency)
+ (format #f " (~a)"
+ (gnc-commodity-get-mnemonic
+ (opt-val gnc:pagename-general
+ optname-currency)))
+ ""))))
+ ;; For conversion to row-currency. Use midday as the
+ ;; transaction time so it matches a price on the same day.
+ ;; Otherwise it uses midnight which will likely match a
+ ;; price on the previous day
+ (converted-amount (lambda (s)
+ (gnc:exchange-by-pricedb-nearest
+ (gnc:make-gnc-monetary (split-currency s)
+ (split-amount s))
+ (row-currency s)
+ (time64CanonicalDayTime
+ (xaccTransGetDate (xaccSplitGetParent s))))))
+ (converted-debit-amount (lambda (s) (and (positive? (split-amount s))
+ (converted-amount s))))
+ (converted-credit-amount (lambda (s)
+ (and (not (positive? (split-amount s)))
+ (gnc:monetary-neg (converted-amount s)))))
+ (original-amount (lambda (s)
+ (gnc:make-gnc-monetary
+ (split-currency s) (split-amount s))))
+ (original-debit-amount (lambda (s)
+ (and (positive? (split-amount s))
+ (original-amount s))))
+ (original-credit-amount (lambda (s)
+ (and (not (positive? (split-amount s)))
+ (gnc:monetary-neg (original-amount s)))))
+ (running-balance (lambda (s)
+ (gnc:make-gnc-monetary
+ (split-currency s) (xaccSplitGetBalance s)))))
+ (append
+ ;; each column will be a vector
+ ;; (vector heading
+ ;; calculator-function (calculator-function split) to obtain amount
+ ;; reverse-column? #t to allow reverse signs
+ ;; subtotal? #t to allow subtotals (ie must be #f for
+ ;; running balance)
+ ;; start-dual-column? #t for the debit side of a dual column
+ ;; (i.e. debit/credit) which means the next
+ ;; column must be the credit side
+ ;; friendly-heading-fn (friendly-heading-fn account) to retrieve
+ ;; friendly name for account debit/credit
+ ;; or 'bal-bf for balance-brought-forward
+
+ (if (column-uses? 'amount-single)
+ (list (vector (header-commodity (_ "Amount"))
+ converted-amount #t #t #f
+ (lambda (a) "")))
+ '())
+
+ (if (column-uses? 'amount-double)
+ (list (vector (header-commodity (_ "Debit"))
+ converted-debit-amount #f #t #t
+ friendly-debit)
+ (vector (header-commodity (_ "Credit"))
+ converted-credit-amount #f #t #f
+ friendly-credit))
+ '())
+
+ (if (and (column-uses? 'amount-original-currency)
+ (column-uses? 'amount-single))
+ (list (vector (_ "Amount")
+ original-amount #t #t #f
+ (lambda (a) "")))
+ '())
+
+ (if (and (column-uses? 'amount-original-currency)
+ (column-uses? 'amount-double))
+ (list (vector (_ "Debit")
+ original-debit-amount #f #t #t
+ friendly-debit)
+ (vector (_ "Credit")
+ original-credit-amount #f #t #f
+ friendly-credit))
+ '())
+
+ (if (column-uses? 'running-balance)
+ (list (vector (_ "Running Balance")
+ running-balance #t #f #f
+ 'bal-bf))
+ '()))))
+
+ (define calculated-cells
+ ;; this part will check whether custom-calculated-cells were specified. this
+ ;; describes a custom function which consumes an options list, and generates
+ ;; a vectorlist similar to default-calculated-cells as above.
+ (if custom-calculated-cells
+ (custom-calculated-cells options)
+ default-calculated-cells))
+
+ (define headings-left-columns
+ (map (lambda (column)
+ (vector-ref column 0))
+ left-columns))
+
+ (define headings-right-columns
+ (map (lambda (column)
+ (vector-ref column 0))
+ calculated-cells))
+
+ (define width-left-columns (length left-columns))
+ (define width-right-columns (length calculated-cells))
+
+ (define primary-indent
+ (if (and (column-uses? 'indenting)
+ (primary-get-info 'renderer-fn))
+ 1 0))
+
+ (define secondary-indent
+ (if (and (column-uses? 'indenting)
+ (secondary-get-info 'renderer-fn))
+ 1 0))
+
+ (define indent-level
+ (+ primary-indent secondary-indent))
+
+ (define (add-subheading data subheading-style split level)
+ (let* ((sortkey (opt-val pagename-sorting
+ (case level
+ ((primary) optname-prime-sortkey)
+ ((secondary) optname-sec-sortkey))))
+ (data (if (and (any (lambda (c) (eq? 'bal-bf (vector-ref c 5)))
+ calculated-cells)
+ (memq sortkey ACCOUNT-SORTING-TYPES))
+ ;; Translators: Balance b/f stands for "Balance
+ ;; brought forward".
+ (string-append data ": " (_ "Balance b/f"))
+ data))
+ (renderer-fn (keylist-get-info
+ (sortkey-list BOOK-SPLIT-ACTION)
+ sortkey 'renderer-fn))
+ (left-indent (case level
+ ((primary total) 0)
+ ((secondary) primary-indent)))
+ (right-indent (- indent-level left-indent)))
+
+ (unless (column-uses? 'subtotals-only)
+ (gnc:html-table-append-row/markup!
+ table subheading-style
+ (append
+ (gnc:html-make-empty-cells left-indent)
+ (if export?
+ (cons
+ (gnc:make-html-table-cell data)
+ (gnc:html-make-empty-cells
+ (+ right-indent width-left-columns -1)))
+ (list
+ (gnc:make-html-table-cell/size
+ 1 (+ right-indent width-left-columns) data)))
+ (map
+ (lambda (cell)
+ (match (vector-ref cell 5)
+ (#f #f)
+ ('bal-bf
+ (let* ((acc (xaccSplitGetAccount split))
+ (bal (xaccAccountGetBalanceAsOfDate acc begindate)))
+ (and (memq sortkey ACCOUNT-SORTING-TYPES)
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:make-gnc-monetary
+ (xaccAccountGetCommodity acc)
+ (if (acc-reverse? acc) (- bal) bal))))))
+ (fn
+ (and (opt-val pagename-sorting optname-show-informal-headers)
+ (column-uses? 'amount-double)
+ (memq sortkey SORTKEY-INFORMAL-HEADERS)
+ (gnc:make-html-text
+ (gnc:html-markup-b
+ (fn (xaccSplitGetAccount split))))))))
+ calculated-cells))))))
+
+ (define (add-subtotal-row subtotal-string subtotal-collectors
+ subtotal-style level row col)
+ (let* ((left-indent (case level
+ ((total) 0)
+ ((primary) primary-indent)
+ ((secondary) (+ primary-indent secondary-indent))))
+ (right-indent (- indent-level left-indent))
+ (merge-list (map (lambda (cell) (vector-ref cell 4)) calculated-cells))
+ (columns (map (lambda (coll)
+ (coll 'format gnc:make-gnc-monetary #f))
+ subtotal-collectors))
+ (list-of-commodities
+ (delete-duplicates
+ (map gnc:gnc-monetary-commodity (concatenate columns))
+ gnc-commodity-equal)))
+
+ (define (retrieve-commodity list-of-monetary commodity)
+ (find (lambda (mon)
+ (gnc-commodity-equal commodity (gnc:gnc-monetary-commodity mon)))
+ list-of-monetary))
+
+ (define (first-column string)
+ (if export?
+ (cons
+ (gnc:make-html-table-cell/markup "total-label-cell" string)
+ (gnc:html-make-empty-cells (+ right-indent width-left-columns -1)))
+ (list
+ (gnc:make-html-table-cell/size/markup
+ 1 (+ right-indent width-left-columns) "total-label-cell" string))))
+
+ (define (data-columns commodity)
+ (let loop ((merging? #f)
+ (last-column #f)
+ (columns columns)
+ (merge-list merge-list)
+ (result '()))
+ (if (null? columns)
+ ;; we've processed all columns. return the (reversed)
+ ;; list of html-table-cells.
+ (reverse result)
+ (let* ((mon (retrieve-commodity (car columns) commodity))
+ (this-column (and mon (gnc:gnc-monetary-amount mon))))
+ (cond
+
+ ;; We're merging. If a subtotal exists, send to next loop iteration.
+ ((car merge-list)
+ (loop #t
+ this-column
+ (cdr columns)
+ (cdr merge-list)
+ result))
+
+ ;; We're completing merge. Display debit-credit in correct column.
+ (merging?
+ (let* ((sum (and (or last-column this-column)
+ (- (or last-column 0) (or this-column 0))))
+ (sum-table-cell (and sum (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (gnc:make-gnc-monetary
+ commodity (abs sum)))))
+ (debit-col (and sum (positive? sum) sum-table-cell))
+ (credit-col (and sum (not (positive? sum)) sum-table-cell)))
+ (loop #f
+ #f
+ (cdr columns)
+ (cdr merge-list)
+ (cons* credit-col debit-col result))))
+
+ ;; Not merging nor completed merge. Just add amount to result.
+ (else
+ (loop #f
+ #f
+ (cdr columns)
+ (cdr merge-list)
+ (cons (gnc:make-html-table-cell/markup
+ "total-number-cell" mon)
+ result))))))))
+
+ ;; take the first column of each commodity, add onto the subtotal grid
+ (set! grid
+ (grid-add grid row col
+ (map (lambda (commodity)
+ (retrieve-commodity (car columns) commodity))
+ list-of-commodities)))
+
+ ;; each commodity subtotal gets a separate line in the html-table
+ ;; each line comprises: indenting, first-column, data-columns
+ (let loop ((first-column-string subtotal-string)
+ (list-of-commodities list-of-commodities))
+ (unless (null? list-of-commodities)
+ (gnc:html-table-append-row/markup!
+ table subtotal-style
+ (append
+ (gnc:html-make-empty-cells left-indent)
+ (first-column first-column-string)
+ (data-columns (car list-of-commodities))))
+ (loop "" (cdr list-of-commodities))))))
+
+ (define (total-string str) (string-append (_ "Total For ") str))
+
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; renderers
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; display an account name depending on the options the user has set
+ (define (account-namestring account show-account-code?
+ show-account-name? show-account-full-name?)
+ ;;# on multi-line splits we can get an empty ('()) account
+ (if (null? account)
+ (_ "Split Transaction")
+ (with-output-to-string
+ (lambda ()
+ (when show-account-code?
+ (display (xaccAccountGetCode account))
+ (display " "))
+ (when show-account-name?
+ (display
+ (if show-account-full-name?
+ (gnc-account-get-full-name account)
+ (xaccAccountGetName account))))))))
+
+ ;; retrieve date renderer from the date-subtotal-list
+ (define (render-date date-subtotal-key split)
+ ((keylist-get-info date-subtotal-list date-subtotal-key 'renderer-fn) split))
+
+ ;; generate account name, optionally with anchor to account register
+ (define (render-account sortkey split anchor?)
+ (let* ((account ((keylist-get-info (sortkey-list BOOK-SPLIT-ACTION)
+ sortkey 'renderer-fn) split))
+ (name (account-namestring account
+ (column-uses? 'sort-account-code)
+ #t
+ (column-uses? 'sort-account-full-name)))
+ (description (if (and (column-uses? 'sort-account-description)
+ (not (string-null?
+ (xaccAccountGetDescription account))))
+ (string-append ": " (xaccAccountGetDescription account))
+ "")))
+ (if (and anchor? opt-use-links?
+ (pair? account)) ;html anchor for 2-split transactions only
+ (gnc:make-html-text
+ (gnc:html-markup-anchor (gnc:account-anchor-text account) name)
+ description)
+ name)))
+
+ ;; generic renderer. retrieve renderer-fn which should return a str
+ (define (render-generic sortkey split)
+ ((keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) sortkey 'renderer-fn) split))
+
+ (define (render-summary split level anchor?)
+ (let ((sortkey (opt-val pagename-sorting
+ (case level
+ ((primary) optname-prime-sortkey)
+ ((secondary) optname-sec-sortkey))))
+ (date-subtotal-key (opt-val pagename-sorting
+ (case level
+ ((primary) optname-prime-date-subtotal)
+ ((secondary) optname-sec-date-subtotal)))))
+ (cond
+ ((memq sortkey DATE-SORTING-TYPES)
+ (render-date date-subtotal-key split))
+ ((memq sortkey ACCOUNT-SORTING-TYPES)
+ (render-account sortkey split anchor?))
+ (else
+ (render-generic sortkey split)))))
+
+ (define (render-grand-total)
+ (_ "Grand Total"))
+
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; add-split-row
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define (add-split-row split cell-calculators row-style transaction-row?)
+ (let* ((account (xaccSplitGetAccount split))
+ (reversible-account? (acc-reverse? account))
+ (cells (map (lambda (cell)
+ (let ((split->monetary (vector-ref cell 1)))
+ (vector (split->monetary split)
+ (vector-ref cell 2) ;reverse?
+ (vector-ref cell 3) ;subtotal?
+ )))
+ cell-calculators)))
+
+ (unless (column-uses? 'subtotals-only)
+ (gnc:html-table-append-row/markup!
+ table row-style
+ (append
+ (gnc:html-make-empty-cells indent-level)
+ (map (lambda (left-col)
+ ((vector-ref left-col 1)
+ split transaction-row?))
+ left-columns)
+ (map (lambda (cell)
+ (let* ((cell-monetary (vector-ref cell 0))
+ (reverse? (and (vector-ref cell 1)
+ reversible-account?))
+ (cell-content (and cell-monetary
+ (if reverse?
+ (gnc:monetary-neg cell-monetary)
+ cell-monetary))))
+ (and cell-content
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (if opt-use-links?
+ (gnc:html-split-anchor split cell-content)
+ cell-content)))))
+ cells))))
+
+ (map (lambda (cell)
+ (let ((cell-monetary (vector-ref cell 0))
+ (subtotal? (vector-ref cell 2)))
+ (and subtotal? cell-monetary)))
+ cells)))
+
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; do-rows-with-subtotals
+
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (define primary-subtotal-collectors
+ (map (lambda (x) (gnc:make-commodity-collector)) calculated-cells))
+
+ (define secondary-subtotal-collectors
+ (map (lambda (x) (gnc:make-commodity-collector)) calculated-cells))
+
+ (define total-collectors
+ (map (lambda (x) (gnc:make-commodity-collector)) calculated-cells))
+
+ (define grid (make-grid))
+ (define primary-subtotal-comparator (primary-get-info 'split-sortvalue))
+ (define secondary-subtotal-comparator (secondary-get-info 'split-sortvalue))
+
+ (gnc:html-table-set-col-headers!
+ table (concatenate (list
+ (gnc:html-make-empty-cells indent-level)
+ headings-left-columns
+ headings-right-columns)))
+
+ (when (primary-get-info 'renderer-fn)
+ (add-subheading (render-summary (car splits) 'primary #t)
+ def:primary-subtotal-style (car splits) 'primary))
+
+ (when (secondary-get-info 'renderer-fn)
+ (add-subheading (render-summary (car splits) 'secondary #t)
+ def:secondary-subtotal-style (car splits) 'secondary))
+
+ (let loop ((splits splits)
+ (odd-row? #t)
+ (work-done 0))
+
+ (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
+
+ (if (null? splits)
+
+ (when (opt-val gnc:pagename-display "Totals")
+ (gnc:html-table-append-row/markup!
+ table def:grand-total-style
+ (list
+ (gnc:make-html-table-cell/size
+ 1 (+ indent-level width-left-columns width-right-columns)
+ (gnc:make-html-text (gnc:html-markup-hr)))))
+
+ (add-subtotal-row
+ (render-grand-total) total-collectors
+ def:grand-total-style 'total 'row-total 'col-total))
+
+ (let* ((current (car splits))
+ (rest (cdr splits))
+ (next (and (pair? rest) (car rest)))
+ (split-values (add-split-row
+ current
+ calculated-cells
+ (if (or odd-row? is-multiline?)
+ def:normal-row-style
+ def:alternate-row-style)
+ #t)))
+
+ (when is-multiline?
+ (for-each
+ (lambda (othersplit)
+ (add-split-row othersplit calculated-cells
+ def:alternate-row-style #f))
+ (delete current (xaccTransGetSplitList
+ (xaccSplitGetParent current)))))
+
+ (for-each
+ (lambda (prime-collector sec-collector tot-collector value)
+ (when (gnc:gnc-monetary? value)
+ (let ((comm (gnc:gnc-monetary-commodity value))
+ (val (gnc:gnc-monetary-amount value)))
+ (prime-collector 'add comm val)
+ (sec-collector 'add comm val)
+ (tot-collector 'add comm val))))
+ primary-subtotal-collectors
+ secondary-subtotal-collectors
+ total-collectors
+ split-values)
+
+ (cond
+ ((and primary-subtotal-comparator
+ (or (not next)
+ (not (equal? (primary-subtotal-comparator current)
+ (primary-subtotal-comparator next)))))
+ (when secondary-subtotal-comparator
+ (add-subtotal-row (total-string
+ (render-summary current 'secondary #f))
+ secondary-subtotal-collectors
+ def:secondary-subtotal-style
+ 'secondary
+ (cons (primary-subtotal-comparator current)
+ (render-summary current 'primary #f))
+ (cons (secondary-subtotal-comparator current)
+ (render-summary current 'secondary #f)))
+ (for-each
+ (lambda (coll)
+ (coll 'reset #f #f))
+ secondary-subtotal-collectors))
+ (add-subtotal-row (total-string
+ (render-summary current 'primary #f))
+ primary-subtotal-collectors
+ def:primary-subtotal-style
+ 'primary
+ (cons (primary-subtotal-comparator current)
+ (render-summary current 'primary #f))
+ 'col-total)
+ (for-each
+ (lambda (coll)
+ (coll 'reset #f #f))
+ primary-subtotal-collectors)
+ (when next
+ (add-subheading (render-summary next 'primary #t)
+ def:primary-subtotal-style next 'primary)
+ (when secondary-subtotal-comparator
+ (add-subheading (render-summary next 'secondary #t)
+ def:secondary-subtotal-style next
+ 'secondary))))
+
+ (else
+ (when (and secondary-subtotal-comparator
+ (or (not next)
+ (not (equal? (secondary-subtotal-comparator current)
+ (secondary-subtotal-comparator next)))))
+ (add-subtotal-row (total-string
+ (render-summary current 'secondary #f))
+ secondary-subtotal-collectors
+ def:secondary-subtotal-style
+ 'secondary
+ (if primary-subtotal-comparator
+ (cons (primary-subtotal-comparator current)
+ (render-summary current 'primary #f))
+ (cons #f ""))
+ (cons (secondary-subtotal-comparator current)
+ (render-summary current 'secondary #f)))
+ (for-each
+ (lambda (coll)
+ (coll 'reset #f #f))
+ secondary-subtotal-collectors)
+ (when next
+ (add-subheading (render-summary next 'secondary #t)
+ def:secondary-subtotal-style next 'secondary)))))
+
+ (loop rest (not odd-row?) (1+ work-done)))))
+
+ (let ((csvlist (cond
+ ((any (lambda (cell) (vector-ref cell 4)) calculated-cells)
+ ;; there are mergeable cells. don't return a list.
+ (N_ "CSV disabled for double column amounts"))
+
+ (else
+ (map
+ (lambda (cell coll)
+ (cons (vector-ref cell 0)
+ (coll 'format gnc:make-gnc-monetary #f)))
+ calculated-cells total-collectors)))))
+ (values table grid csvlist))))
+
+;; grid data structure
+(define (make-grid)
+ '())
+(define (cell-match? cell row col)
+ (and (or (not row) (equal? row (vector-ref cell 0)))
+ (or (not col) (equal? col (vector-ref cell 1)))))
+(define (grid-get grid row col)
+ ;; grid filter - get all row/col - if #f then retrieve whole row/col
+ (filter
+ (lambda (cell)
+ (cell-match? cell row col))
+ grid))
+(define (grid-del grid row col)
+ ;; grid filter - del all row/col - if #f then delete whole row/col
+ (filter
+ (lambda (cell)
+ (not (cell-match? cell row col)))
+ grid))
+(define (grid-rows grid)
+ (delete-duplicates (map (lambda (cell) (vector-ref cell 0)) grid)))
+(define (grid-cols grid)
+ (delete-duplicates (map (lambda (cell) (vector-ref cell 1)) grid)))
+(define (grid-add grid row col data)
+ ;;misonomer - we don't 'add' to existing data, we delete old data
+ ;;stored at row/col and add again. this is fine because the grid
+ ;;should never have duplicate data in the trep.
+ (set! grid (grid-del grid row col))
+ (set! grid (cons (vector row col data) grid))
+ grid)
+(define (grid->html-table grid list-of-rows list-of-cols)
+ (define row-average-enabled? (> (length list-of-cols) 1))
+ (define (monetary-div monetary divisor)
+ (and monetary
+ (let* ((amount (gnc:gnc-monetary-amount monetary))
+ (currency (gnc:gnc-monetary-commodity monetary))
+ (scu (gnc-commodity-get-fraction currency)))
+ (gnc:make-gnc-monetary
+ currency (gnc-numeric-convert
+ (/ amount divisor) scu GNC-HOW-RND-ROUND)))))
+ (define (row->num-of-commodities row)
+ ;; for a row, find the maximum number of commodities being stored
+ (apply max
+ (map (lambda (col)
+ (let ((cell (grid-get grid row col)))
+ (if (null? cell) 0
+ (length (vector-ref (car cell) 2)))))
+ (cons 'col-total list-of-cols))))
+ (define (make-table-cell row col commodity-idx divisor)
+ (let ((cell (grid-get grid row col)))
+ (if (null? cell) ""
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (monetary-div
+ (list-ref-safe (vector-ref (car cell) 2) commodity-idx)
+ divisor)))))
+ (define (make-row row commodity-idx)
+ (append
+ (list (cond
+ ((positive? commodity-idx) "")
+ ((eq? row 'row-total) (_ "Grand Total"))
+ (else (cdr row))))
+ (map (lambda (col) (make-table-cell row col commodity-idx 1))
+ list-of-cols)
+ (list (make-table-cell row 'col-total commodity-idx 1))
+ (if row-average-enabled?
+ (list (make-table-cell
+ row 'col-total commodity-idx (length list-of-cols)))
+ '())))
+ (let ((table (gnc:make-html-table)))
+ (gnc:html-table-set-caption! table optname-grid)
+ (gnc:html-table-set-col-headers!
+ table (append (list "")
+ (map cdr list-of-cols)
+ (list (_ "Total"))
+ (if row-average-enabled? (list (_ "Average")) '())))
+ (gnc:html-table-set-style!
+ table "th"
+ 'attribute (list "class" "column-heading-right"))
+ (for-each
+ (lambda (row)
+ (for-each
+ (lambda (commodity-idx)
+ (gnc:html-table-append-row!
+ table (make-row row commodity-idx)))
+ (iota (row->num-of-commodities row))))
+ (if (memq 'row-total (grid-rows grid))
+ (append list-of-rows '(row-total))
+ list-of-rows))
+ table))
+
+(define* (gnc:trep-renderer
+ report-obj #:key custom-calculated-cells empty-report-message
+ custom-split-filter split->date split->date-include-false?
+ custom-source-accounts
+ export-type filename)
+ ;; the trep-renderer is a define* function which, at minimum, takes
+ ;; the report object
+ ;;
+ ;; the optional arguments are:
+ ;; #:custom-calculated-cells - a list of vectors to define customized data columns
+ ;; #:empty-report-message - a str or html-object displayed at the initial run
+ ;; #:custom-split-filter - a split->bool function to add to the split filter
+ ;; #:split->date - a split->time64 which overrides the default posted date filter
+ ;; (see reconcile report)
+ ;; #:split->date-include-false? - addendum to above, specifies filter behaviour if
+ ;; split->date returns #f. useful to include unreconciled splits in reconcile
+ ;; report. it can be useful for alternative date filtering, e.g. filter by
+ ;; transaction->invoice->payment date.
+ ;; #:export-type and #:filename - are provided for CSV export
+ ;; #:custom-source-accounts - alternate list-of-accounts to retrieve splits from
+
+ (define options (gnc:report-options report-obj))
+ (define (opt-val section name)
+ (gnc:option-value (gnc:lookup-option options section name)))
+ (define BOOK-SPLIT-ACTION
+ (qof-book-use-split-action-for-num-field (gnc-get-current-book)))
+ (define (is-filter-member split account-list)
+ (define (same-split? s) (equal? s split))
+ (define (from-account? s) (member (xaccSplitGetAccount s) account-list))
+ (let lp ((splits (xaccTransGetSplitList (xaccSplitGetParent split))))
+ (match splits
+ (() #f)
+ (((? same-split?) . rest) (lp rest))
+ (((? from-account?) . _) #t)
+ ((_ . rest) (lp rest)))))
+
+ (gnc:report-starting (opt-val gnc:pagename-general gnc:optname-reportname))
+
+ (let* ((document (gnc:make-html-document))
+ (account-matcher (opt-val pagename-filter optname-account-matcher))
+ (account-matcher-regexp
+ (and (opt-val pagename-filter optname-account-matcher-regex)
+ (if (defined? 'make-regexp)
+ (catch 'regular-expression-syntax
+ (lambda () (make-regexp account-matcher))
+ (const 'invalid-account-regex))
+ 'no-guile-regex-support)))
+ (c_account_0 (or custom-source-accounts
+ (opt-val gnc:pagename-accounts optname-accounts)))
+ (c_account_1 (filter
+ (lambda (acc)
+ (if (regexp? account-matcher-regexp)
+ (regexp-exec account-matcher-regexp
+ (gnc-account-get-full-name acc))
+ (string-contains (gnc-account-get-full-name acc)
+ account-matcher)))
+ c_account_0))
+ (c_account_2 (opt-val gnc:pagename-accounts optname-filterby))
+ (filter-mode (opt-val gnc:pagename-accounts optname-filtertype))
+ (begindate (gnc:time64-start-day-time
+ (gnc:date-option-absolute-time
+ (opt-val gnc:pagename-general optname-startdate))))
+ (enddate (gnc:time64-end-day-time
+ (gnc:date-option-absolute-time
+ (opt-val gnc:pagename-general optname-enddate))))
+ (transaction-matcher (opt-val pagename-filter optname-transaction-matcher))
+ (transaction-filter-case-insensitive?
+ (opt-val pagename-filter optname-transaction-matcher-caseinsensitive))
+ (transaction-matcher-regexp
+ (and (opt-val pagename-filter optname-transaction-matcher-regex)
+ (if (defined? 'make-regexp)
+ (catch 'regular-expression-syntax
+ (lambda ()
+ (if transaction-filter-case-insensitive?
+ (make-regexp transaction-matcher regexp/icase)
+ (make-regexp transaction-matcher)))
+ (const 'invalid-transaction-regex))
+ 'no-guile-regex-support)))
+ (transaction-filter-exclude?
+ (opt-val pagename-filter optname-transaction-matcher-exclude))
+ (reconcile-status-filter
+ (keylist-get-info reconcile-status-list
+ (opt-val pagename-filter optname-reconcile-status)
+ 'filter-types))
+ (report-title (opt-val gnc:pagename-general gnc:optname-reportname))
+ (primary-key (opt-val pagename-sorting optname-prime-sortkey))
+ (primary-order (opt-val pagename-sorting optname-prime-sortorder))
+ (primary-date-subtotal (opt-val pagename-sorting optname-prime-date-subtotal))
+ (secondary-key (opt-val pagename-sorting optname-sec-sortkey))
+ (secondary-order (opt-val pagename-sorting optname-sec-sortorder))
+ (secondary-date-subtotal (opt-val pagename-sorting optname-sec-date-subtotal))
+ (void-status (opt-val pagename-filter optname-void-transactions))
+ (closing-match (keylist-get-info
+ show-closing-list
+ (opt-val pagename-filter optname-closing-transactions)
+ 'closing-match))
+ (splits '())
+ (custom-sort? (or (and (memq primary-key DATE-SORTING-TYPES)
+ (not (eq? primary-date-subtotal 'none)))
+ (and (memq secondary-key DATE-SORTING-TYPES)
+ (not (eq? secondary-date-subtotal 'none)))
+ (or (CUSTOM-SORTING? primary-key BOOK-SPLIT-ACTION)
+ (CUSTOM-SORTING? secondary-key BOOK-SPLIT-ACTION))))
+ (subtotal-table? (and (opt-val gnc:pagename-display optname-grid)
+ (if (memq primary-key DATE-SORTING-TYPES)
+ (keylist-get-info date-subtotal-list
+ primary-date-subtotal 'renderer-fn)
+ (opt-val pagename-sorting optname-prime-subtotal))
+ (eq? (opt-val gnc:pagename-display (N_ "Amount"))
+ 'single)))
+ (infobox-display (opt-val gnc:pagename-general optname-infobox-display))
+ (query (qof-query-create-for-splits)))
+
+ (define (match? str)
+ (cond
+ (transaction-matcher-regexp
+ (regexp-exec transaction-matcher-regexp str))
+ (transaction-filter-case-insensitive?
+ (string-contains-ci str transaction-matcher))
+ (else
+ (string-contains str transaction-matcher))))
+
+ (define (generic-less? split-X split-Y sortkey date-subtotal-key ascend?)
+ ;; compare splits X and Y, whereby
+ ;; sortkey and date-subtotal-key specify the options used
+ ;; ascend? specifies whether ascending or descending
+ (let* ((comparator-function
+ (if (memq sortkey DATE-SORTING-TYPES)
+ (let ((date (keylist-get-info
+ (sortkey-list BOOK-SPLIT-ACTION)
+ sortkey 'split-sortvalue))
+ (date-comparator
+ (keylist-get-info date-subtotal-list
+ date-subtotal-key 'date-sortvalue)))
+ (lambda (s)
+ (and date-comparator (date-comparator (date s)))))
+ (or (keylist-get-info (sortkey-list BOOK-SPLIT-ACTION)
+ sortkey 'split-sortvalue)
+ (lambda (s) #f))))
+ (value-of-X (comparator-function split-X))
+ (value-of-Y (comparator-function split-Y))
+ (op (if (string? value-of-X)
+ (if ascend? string<? string>?)
+ (if ascend? < >))))
+ (and value-of-X (op value-of-X value-of-Y))))
+
+ (define (primary-comparator? X Y)
+ (generic-less? X Y primary-key
+ primary-date-subtotal
+ (eq? primary-order 'ascend)))
+
+ (define (secondary-comparator? X Y)
+ (generic-less? X Y secondary-key
+ secondary-date-subtotal
+ (eq? secondary-order 'ascend)))
+
+ ;; This will, by default, sort the split list by ascending posted-date.
+ (define (date-comparator? X Y)
+ (generic-less? X Y 'date 'none #t))
+
+ (define (transaction-filter-match split)
+ (or (match? (xaccTransGetDescription (xaccSplitGetParent split)))
+ (match? (xaccTransGetNotes (xaccSplitGetParent split)))
+ (match? (xaccSplitGetMemo split))))
+
+ (cond
+ ((or (null? c_account_1)
+ (symbol? account-matcher-regexp)
+ (symbol? transaction-matcher-regexp))
+
+ (gnc:html-document-add-object!
+ document
+ (cond
+ ((null? c_account_1)
+ (gnc:html-make-no-account-warning report-title (gnc:report-id report-obj)))
+
+ ((symbol? account-matcher-regexp)
+ (gnc:html-make-generic-warning
+ report-title (gnc:report-id report-obj)
+ (string-append (_ "Error") " " (symbol->string account-matcher-regexp))
+ ""))
+
+ ((symbol? transaction-matcher-regexp)
+ (gnc:html-make-generic-warning
+ report-title (gnc:report-id report-obj)
+ (string-append (_ "Error") " " (symbol->string transaction-matcher-regexp))
+ ""))))
+
+ ;; if an empty-report-message is passed by a derived report to
+ ;; the renderer, display it here.
+ (when empty-report-message
+ (gnc:html-document-add-object!
+ document
+ empty-report-message))
+
+ (when (memq infobox-display '(always no-match))
+ (gnc:html-document-add-object!
+ document
+ (gnc:html-render-options-changed options))))
+
+ (else
+ (qof-query-set-book query (gnc-get-current-book))
+ (xaccQueryAddAccountMatch query c_account_1 QOF-GUID-MATCH-ANY QOF-QUERY-AND)
+ (unless split->date
+ (xaccQueryAddDateMatchTT query #t begindate #t enddate QOF-QUERY-AND))
+ (case void-status
+ ((non-void-only)
+ (gnc:query-set-match-non-voids-only! query (gnc-get-current-book)))
+ ((void-only)
+ (gnc:query-set-match-voids-only! query (gnc-get-current-book)))
+ (else #f))
+ (when reconcile-status-filter
+ (xaccQueryAddClearedMatch query reconcile-status-filter QOF-QUERY-AND))
+ (when (boolean? closing-match)
+ (xaccQueryAddClosingTransMatch query closing-match QOF-QUERY-AND))
+ (unless custom-sort?
+ (qof-query-set-sort-order
+ query
+ (keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) primary-key 'sortkey)
+ (keylist-get-info (sortkey-list BOOK-SPLIT-ACTION) secondary-key 'sortkey)
+ '())
+ (qof-query-set-sort-increasing
+ query (eq? primary-order 'ascend) (eq? secondary-order 'ascend)
+ #t))
+
+ (if (opt-val "__trep" "unique-transactions")
+ (set! splits (xaccQueryGetSplitsUniqueTrans query))
+ (set! splits (qof-query-run query)))
+
+ (qof-query-destroy query)
+
+ ;; Combined Filter:
+ ;; - include/exclude using split->date according to date options
+ ;; - include/exclude splits to/from selected accounts
+ ;; - substring/regex matcher for Transaction Description/Notes/Memo
+ ;; - custom-split-filter, a split->bool function for derived reports
+ (set! splits
+ (filter
+ (lambda (split)
+ (let* ((trans (xaccSplitGetParent split)))
+ (and (or (not split->date)
+ (let ((date (split->date split)))
+ (if date
+ (<= begindate date enddate)
+ split->date-include-false?)))
+ (case filter-mode
+ ((none) #t)
+ ((include) (is-filter-member split c_account_2))
+ ((exclude) (not (is-filter-member split c_account_2))))
+ (or (string-null? transaction-matcher)
+ (if transaction-filter-exclude?
+ (not (transaction-filter-match split))
+ (transaction-filter-match split)))
+ (or (not custom-split-filter)
+ (custom-split-filter split)))))
+ splits))
+
+ (when custom-sort?
+ (set! splits (stable-sort! splits date-comparator?))
+ (set! splits (stable-sort! splits secondary-comparator?))
+ (set! splits (stable-sort! splits primary-comparator?)))
+
+ (cond
+ ((null? splits)
+ ;; error condition: no splits found
+ (gnc:html-document-add-object!
+ document
+ (gnc:html-make-generic-warning
+ report-title (gnc:report-id report-obj)
+ NO-MATCHING-TRANS-HEADER NO-MATCHING-TRANS-TEXT))
+
+ (when (memq infobox-display '(always no-match))
+ (gnc:html-document-add-object!
+ document
+ (gnc:html-render-options-changed options))))
+
+ (else
+ (let-values (((table grid csvlist)
+ (make-split-table splits options custom-calculated-cells
+ begindate)))
+
+ (gnc:html-document-set-title! document report-title)
+
+ (gnc:html-document-add-object!
+ document
+ (gnc:make-html-text
+ (gnc:html-markup-h3
+ (format #f
+ ;; Translators: Both ~a's are dates
+ (_ "From ~a to ~a")
+ (qof-print-date begindate)
+ (qof-print-date enddate)))))
+
+ (when (eq? infobox-display 'always)
+ (gnc:html-document-add-object!
+ document
+ (gnc:html-render-options-changed options)))
+
+ (when subtotal-table?
+ (let* ((generic<?
+ (lambda (a b)
+ (cond ((string? (car a)) (string<? (car a) (car b)))
+ ((number? (car a)) (< (car a) (car b)))
+ (else (gnc:error "unknown sortvalue")))))
+ (list-of-rows
+ (stable-sort! (delete 'row-total (grid-rows grid))
+ generic<?))
+ (list-of-cols
+ (stable-sort! (delete 'col-total (grid-cols grid))
+ generic<?)))
+ (gnc:html-document-add-object!
+ document (grid->html-table grid list-of-rows list-of-cols))))
+
+ (cond
+ ((and (eq? export-type 'csv)
+ (string? filename)
+ (not (string-null? filename)))
+ (let ((old-date-fmt (qof-date-format-get))
+ (dummy (qof-date-format-set QOF-DATE-FORMAT-ISO))
+ (infolist
+ (list
+ (list "from" (qof-print-date begindate))
+ (list "to" (qof-print-date enddate)))))
+ (qof-date-format-set old-date-fmt)
+ (if (list? csvlist)
+ (catch #t
+ (lambda ()
+ (call-with-output-file filename
+ (lambda (p)
+ (display (lists->csv (append infolist csvlist)) p))))
+ (lambda (key . args)
+ ;; Translators: ~a error type, ~a filename, ~s error details
+ (let ((fmt (N_ "error ~a during csv output to ~a: ~s")))
+ (gnc:gui-error (format #f fmt key filename args)
+ (format #f (_ fmt) key filename args)))))
+ (gnc:gui-error csvlist (_ csvlist))))))
+
+ (unless (and subtotal-table?
+ (opt-val pagename-sorting optname-show-subtotals-only))
+ (gnc:html-document-add-object! document table)))))))
+
+ (gnc:report-finished)
+
+ document))
diff --cc libgnucash/app-utils/gnc-ui-util.c
index 5cc8d65b4,2b5733f09..1091478d5
--- a/libgnucash/app-utils/gnc-ui-util.c
+++ b/libgnucash/app-utils/gnc-ui-util.c
@@@ -1447,10 -1504,10 +1447,10 @@@ gnc_price_print_info (const gnc_commodi
}
info.use_separators = 1;
- info.use_symbol = 0;
+ info.use_symbol = use_symbol ? 1 : 0;
info.use_locale = 1;
info.monetary = 1;
-
+
info.force_fit = force;
info.round = force;
return info;
commit 710b559cc4a4a130afcbe0e88c50a972955e0e62
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 12:25:58 2020 +0800
[register] [bugfix] use new price renderer
also bugfix: show price in account parent currency, instead of the
original currency.
diff --git a/gnucash/report/standard-reports/register.scm b/gnucash/report/standard-reports/register.scm
index ec0d6bdb2..537d65ad1 100644
--- a/gnucash/report/standard-reports/register.scm
+++ b/gnucash/report/standard-reports/register.scm
@@ -245,8 +245,10 @@
(gnc:make-html-table-cell/markup
"text-cell"
(if split-info?
- (gnc:make-gnc-monetary
- currency (xaccSplitGetSharePrice split))
+ (gnc:default-price-renderer
+ (gnc-account-get-currency-or-parent
+ (xaccSplitGetAccount split))
+ (xaccSplitGetSharePrice split))
" "))))
(if (amount-single-col column-vector)
(addto! row-contents
commit f9fce766c3c1cc50f2f97606386f27a60dbfcd63
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 12:20:01 2020 +0800
[trep-engine] use new price renderer
diff --git a/gnucash/report/report-system/trep-engine.scm b/gnucash/report/report-system/trep-engine.scm
index c9af1757c..8c4f01078 100644
--- a/gnucash/report/report-system/trep-engine.scm
+++ b/gnucash/report/report-system/trep-engine.scm
@@ -1229,24 +1229,11 @@ be excluded from periodic reporting.")
(add-if (column-uses? 'price)
(vector (_ "Price")
(lambda (split transaction-row?)
- ;; share price is retrieved as an
- ;; exact rational; convert for
- ;; presentation to decimal, rounded
- ;; to the currency SCU, optionally
- ;; increasing precision by 2
- ;; significant digits.
- (let* ((currency (xaccTransGetCurrency
- (xaccSplitGetParent split)))
- (scu (gnc-commodity-get-fraction currency))
- (price (xaccSplitGetSharePrice split))
- (price-decimal
- (gnc-numeric-convert
- price (min 10000 (* 100 scu))
- GNC-HOW-RND-ROUND)))
- (gnc:make-html-table-cell/markup
- "number-cell"
- (gnc:make-gnc-monetary
- currency price-decimal)))))))))
+ (gnc:make-html-table-cell/markup
+ "number-cell"
+ (gnc:default-price-renderer
+ (xaccTransGetCurrency (xaccSplitGetParent split))
+ (xaccSplitGetSharePrice split)))))))))
(if (or (column-uses? 'subtotals-only)
(and (null? left-cols-list)
commit 7557c5b54e85111d4285c0018aa34495bf1954ca
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 11:48:13 2020 +0800
[advanced-portfolio] use new price renderer
diff --git a/gnucash/report/standard-reports/advanced-portfolio.scm b/gnucash/report/standard-reports/advanced-portfolio.scm
index 8e7bfc01e..876d11507 100644
--- a/gnucash/report/standard-reports/advanced-portfolio.scm
+++ b/gnucash/report/standard-reports/advanced-portfolio.scm
@@ -925,18 +925,12 @@ by preventing negative stock balances.<br/>")
"number-cell"
(if use-txn
(if pricing-txn
- (gnc:html-transaction-anchor
- pricing-txn
- price
- )
- price
- )
+ (gnc:html-transaction-anchor pricing-txn price)
+ price)
(gnc:html-price-anchor
- price
- (gnc:make-gnc-monetary
- (gnc-price-get-currency price)
- (gnc-price-get-value price)))
- )))))
+ price (gnc:default-price-renderer
+ (gnc-price-get-currency price)
+ (gnc-price-get-value price))))))))
(append! activecols (list (if use-txn (if pricing-txn "*" "**") " ")
(gnc:make-html-table-header-cell/markup
"number-cell" (gnc:make-gnc-monetary currency (sum-basis basis-list
diff --git a/gnucash/report/standard-reports/test/test-portfolios.scm b/gnucash/report/standard-reports/test/test-portfolios.scm
index 390a8d645..fcaf01002 100644
--- a/gnucash/report/standard-reports/test/test-portfolios.scm
+++ b/gnucash/report/standard-reports/test/test-portfolios.scm
@@ -101,7 +101,7 @@
(options (gnc:make-report-options advanced-uuid)))
(let ((sxml (options->sxml advanced-uuid options "basic average")))
(test-equal "advanced: average basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$484.88" "$252.00" "$800.00"
+ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$484.88" "$252.00" "$800.00"
"$553.00" "$227.88" "-$232.88" "-$5.00" "-0.63%" "$4.00"
"$10.00" "-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f)))
@@ -109,7 +109,7 @@
(set-option! options "General" "Basis calculation method" 'fifo-basis)
(let ((sxml (options->sxml advanced-uuid options "basic fifo")))
(test-equal "advanced: fifo basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$543.94" "$252.00" "$800.00"
+ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$543.94" "$252.00" "$800.00"
"$553.00" "$286.94" "-$291.94" "-$5.00" "-0.63%" "$4.00" "$10.00"
"-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f)))
@@ -117,7 +117,7 @@
(set-option! options "General" "Basis calculation method" 'filo-basis)
(let ((sxml (options->sxml advanced-uuid options "basic filo")))
(test-equal "advanced: filo basis"
- '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$400.00" "$252.00" "$800.00"
+ '("AAPL" "AAPL" "NASDAQ" "42.00" "$6.0000" "$400.00" "$252.00" "$800.00"
"$553.00" "$143.00" "-$148.00" "-$5.00" "-0.63%" "$4.00" "$10.00"
"-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f))))
commit 8b3841b4b5d11af1ee1c52698ad47797efedeb29
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 11:36:04 2020 +0800
[balsheet-eg.eguile] use new price renderer
diff --git a/gnucash/report/business-reports/balsheet-eg.eguile.scm b/gnucash/report/business-reports/balsheet-eg.eguile.scm
index 23cd32e3c..17a62a56f 100644
--- a/gnucash/report/business-reports/balsheet-eg.eguile.scm
+++ b/gnucash/report/business-reports/balsheet-eg.eguile.scm
@@ -281,25 +281,23 @@
<p><?scm:d (_ "<strong>Exchange Rates</strong> used for this report") ?>
<table border="0">
<?scm
- (for xpair in xlist do
- (let* ((comm (car xpair))
- (one-num 10000/1)
- (one-foreign-mny (gnc:make-gnc-monetary comm one-num))
- (one-local-mny (exchange-fn one-foreign-mny opt-report-commodity)))
+ (for-each
+ (lambda (xpair)
+ (let* ((comm (car xpair))
+ (one-foreign-mny (gnc:make-gnc-monetary comm 1))
+ (one-local-mny (exchange-fn one-foreign-mny opt-report-commodity))
+ (conv-amount (gnc:gnc-monetary-amount one-local-mny))
+ (price-str (gnc:default-price-renderer
+ opt-report-commodity conv-amount)))
?>
<tr>
- <td align="right">1 <?scm:d (gnc-commodity-get-mnemonic comm) ?></td>
+ <td align="right"><?scm:d (gnc:monetary->string one-foreign-mny) ?></td>
<td>=</td>
- <td align="left"><?scm:d (fmtnumeric
- (gnc-numeric-div
- (gnc:gnc-monetary-amount one-local-mny)
- (gnc:gnc-monetary-amount one-foreign-mny)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))) ?>
- <?scm:d (gnc-commodity-get-mnemonic opt-report-commodity) ?></td>
+ <td align="right"><?scm:d price-str ?></td>
</tr>
<?scm
- ))
+ ))
+ xlist)
?>
</table>
<?scm
commit d8c21c4625ee3a20becb9db021c4ad2bd62684a1
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 00:51:45 2020 +0800
[balsheet-pnl] use new price renderer
diff --git a/gnucash/report/standard-reports/balsheet-pnl.scm b/gnucash/report/standard-reports/balsheet-pnl.scm
index c0dfb125f..3dc019dbd 100644
--- a/gnucash/report/standard-reports/balsheet-pnl.scm
+++ b/gnucash/report/standard-reports/balsheet-pnl.scm
@@ -833,12 +833,14 @@ also show overall period profit & loss."))
(lambda (commodity)
(let ((orig-monetary (gnc:make-gnc-monetary commodity 1)))
(if (has-price? commodity)
- (let ((conv-monetary (convert-curr-fn orig-monetary col-idx)))
+ (let* ((conv-monetary (convert-curr-fn orig-monetary col-idx))
+ (conv-amount (gnc:gnc-monetary-amount conv-monetary)))
(gnc:html-text-append!
cell
(format #f "~a ~a"
(gnc:monetary->string orig-monetary)
- (gnc:monetary->string conv-monetary))))
+ (gnc:default-price-renderer common-currency
+ conv-amount))))
(gnc:html-text-append!
cell
(string-append
diff --git a/gnucash/report/standard-reports/test/test-balsheet-pnl.scm b/gnucash/report/standard-reports/test/test-balsheet-pnl.scm
index 65bb70967..ac9f48404 100644
--- a/gnucash/report/standard-reports/test/test-balsheet-pnl.scm
+++ b/gnucash/report/standard-reports/test/test-balsheet-pnl.scm
@@ -329,7 +329,7 @@
'("#200.00" "$340.00" "30 FUNDS" "$15,000.00" "$106,709.00" "$106,709.00")
(sxml->table-row-col sxml 1 3 6))
(test-equal "show-rates enabled"
- '("#1.00" "$1.70" "1 FUNDS" "$500.00")
+ '("#1.00" "$1.7000" "1 FUNDS" "$500.0000")
(sxml->table-row-col sxml 2 #f #f)))
;;make-multilevel
@@ -465,7 +465,7 @@
(list "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00" "-#600.00" "-$1,020.00" "-$250.00" "-$250.00" "$0.00")
(sxml->table-row-col sxml 1 3 6))
(test-equal "show-rates enabled"
- (list "#1.00" "$1.70")
+ (list "#1.00" "$1.7000")
(sxml->table-row-col sxml 2 #f #f)))
;;make-multilevel
@@ -520,21 +520,21 @@
"$6,870.00" "$0.00" "$100.00" "$4,000.00" "$2,000.00" "$2,000.00"
"10 FUNDS " "$130.00" "$130.00" "#100.00 " "$100,000.00" "$113,100.00"
"$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$0.00" "$0.00" "$103,600.00" "#1.00 $1.30" "1 FUNDS $200.00")
+ "$0.00" "$0.00" "$103,600.00" "#1.00 $1.3000" "1 FUNDS $200.0000")
(sxml->table-row-col sxml 1 #f 2))
(test-equal "bal-1/1/71"
'("01/01/71" "$116,009.00" "$116,009.00" "$4,709.00" "$2,000.00"
"$2,609.00" "$0.00" "$100.00" "$11,000.00" "$2,000.00" "$9,000.00"
"30 FUNDS " "$300.00" "$300.00" "#200.00 " "$100,000.00" "$116,009.00"
"$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$2,909.00" "$0.00" "$106,509.00" "#1.00 $1.50" "1 FUNDS $300.00")
+ "$2,909.00" "$0.00" "$106,509.00" "#1.00 $1.5000" "1 FUNDS $300.0000")
(sxml->table-row-col sxml 1 #f 3))
(test-equal "bal-1/1/72"
'("01/01/72" "$117,529.00" "$117,529.00" "$4,709.00" "$2,000.00"
"$2,609.00" "$0.00" "$100.00" "$12,500.00" "$2,000.00" "$10,500.00"
"30 FUNDS " "$320.00" "$320.00" "#200.00 " "$100,000.00" "$117,529.00"
"$9,500.00" "$9,500.00" "$500.00" "$9,000.00" "$9,500.00" "$103,600.00"
- "$4,429.00" "$0.00" "$108,029.00" "#1.00 $1.60" "1 FUNDS $350.00")
+ "$4,429.00" "$0.00" "$108,029.00" "#1.00 $1.6000" "1 FUNDS $350.0000")
(sxml->table-row-col sxml 1 #f 4)))
;; the following includes non-zero retained earnings of $1,270
@@ -548,7 +548,7 @@
"$100.00" "$17,000.00" "$2,000.00" "$15,000.00" "30 FUNDS " "$1,190.00"
"$1,190.00" "#700.00 " "$100,000.00" "$123,319.00" "$9,500.00" "$9,500.00"
"$500.00" "$9,000.00" "$9,500.00" "$103,600.00" "$8,949.00" "$1,270.00"
- "$113,819.00" "#1.00 $1.70" "1 FUNDS $500.00")
+ "$113,819.00" "#1.00 $1.7000" "1 FUNDS $500.0000")
(sxml->table-row-col sxml 1 #f 2)))))
(define (multicol-pnl-tests)
@@ -585,13 +585,13 @@
"multicol-pnl-halfyear")))
(test-equal "pnl-1/80"
'("01/01/80" " to 01/31/80" "$1,100.00" "$250.00" "$850.00" "#500.00 "
- "$1,100.00" "#1.00 $1.70")
+ "$1,100.00" "#1.00 $1.7000")
(sxml->table-row-col sxml 1 #f 2))
(test-equal "pnl-2/80"
'("02/01/80" " to 02/29/80" "$170.00" "$0.00" "$170.00" "#100.00 "
- "$170.00" "#1.00 $1.70")
+ "$170.00" "#1.00 $1.7000")
(sxml->table-row-col sxml 1 #f 3))
(test-equal "pnl-3/80"
'("03/01/80" " to 03/31/80" "$0.00" "$0.00" "$0.00" "#0.00 "
- "$0.00" "#1.00 $1.70")
+ "$0.00" "#1.00 $1.7000")
(sxml->table-row-col sxml 1 #f 4)))))
commit 61afe53f0fb33c790cf0e630de78df285c184263
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 11:35:57 2020 +0800
[html-utilities] use new price renderer for exchange-rate table
diff --git a/gnucash/report/report-system/html-utilities.scm b/gnucash/report/report-system/html-utilities.scm
index 805cfeca6..0c2f48247 100644
--- a/gnucash/report/report-system/html-utilities.scm
+++ b/gnucash/report/report-system/html-utilities.scm
@@ -734,9 +734,12 @@
(for-each
(lambda (commodity)
(let* ((orig-amt (gnc:make-gnc-monetary commodity 1))
- (exchanged (exchange-fn orig-amt common-commodity)))
+ (exchanged (exchange-fn orig-amt common-commodity))
+ (conv-amount (gnc:gnc-monetary-amount exchanged)))
(gnc:html-table-append-row!
- table (map markup (list orig-amt exchanged)))))
+ table (list (markup orig-amt)
+ (markup (gnc:default-price-renderer common-commodity
+ conv-amount))))))
comm-list)
(gnc:html-table-set-col-headers!
table (list (gnc:make-html-table-header-cell/size
commit 9020c967c7fd15e36b014bac2bff0a3a3f44adbf
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 00:51:00 2020 +0800
[html-style-info] export gnc:default-price-renderer
converts gnc:monetary containing a price to string
diff --git a/gnucash/report/report-system/html-style-info.scm b/gnucash/report/report-system/html-style-info.scm
index 6e9cb3041..7c0adc065 100644
--- a/gnucash/report/report-system/html-style-info.scm
+++ b/gnucash/report/report-system/html-style-info.scm
@@ -266,6 +266,10 @@
(define (gnc:default-html-gnc-numeric-renderer datum params)
(xaccPrintAmount datum (gnc-default-print-info #f)))
+;; renders a price to target currency
+(define (gnc:default-price-renderer currency amount)
+ (xaccPrintAmount amount (gnc-price-print-info currency #t)))
+
(define (gnc:default-html-gnc-monetary-renderer datum params)
(let* ((comm (gnc:gnc-monetary-commodity datum))
(scu (gnc-commodity-get-fraction comm))
diff --git a/gnucash/report/report-system/report-system.scm b/gnucash/report/report-system/report-system.scm
index 1fdcdf92c..02bf7b61e 100644
--- a/gnucash/report/report-system/report-system.scm
+++ b/gnucash/report/report-system/report-system.scm
@@ -748,6 +748,7 @@
(export gnc:select-assoc-account-balance)
(export gnc:get-assoc-account-balances-total)
(export gnc:multiline-to-html-text)
+(export gnc:default-price-renderer)
(export make-file-url)
(export gnc:strify)
(export gnc:pk)
commit 3d25a40d1f12b57b5e551f6c24c58d8d69b85990
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed May 13 00:49:35 2020 +0800
[gnc-ui-util] add gnc_price_print_info
similar to gnc_default_price_print_info but also accepts a use_symbol
specifier. for generating print_info for prices, either exact e.g.
$1 + 2/3, or inexact e.g. $1.3333
diff --git a/libgnucash/app-utils/app-utils.i b/libgnucash/app-utils/app-utils.i
index d46aae893..ea120ff54 100644
--- a/libgnucash/app-utils/app-utils.i
+++ b/libgnucash/app-utils/app-utils.i
@@ -111,6 +111,8 @@ GNCPrintAmountInfo gnc_account_print_info (const Account *account,
gboolean use_symbol);
GNCPrintAmountInfo gnc_commodity_print_info (const gnc_commodity *commodity,
gboolean use_symbol);
+GNCPrintAmountInfo gnc_price_print_info (const gnc_commodity *curr,
+ gboolean use_symbol);
GNCPrintAmountInfo gnc_share_print_info_places (int decplaces);
const char * xaccPrintAmount (gnc_numeric val, GNCPrintAmountInfo info);
diff --git a/libgnucash/app-utils/gnc-ui-util.c b/libgnucash/app-utils/gnc-ui-util.c
index 682437809..2b5733f09 100644
--- a/libgnucash/app-utils/gnc-ui-util.c
+++ b/libgnucash/app-utils/gnc-ui-util.c
@@ -1482,7 +1482,7 @@ gnc_share_print_info_places (int decplaces)
}
GNCPrintAmountInfo
-gnc_default_price_print_info (const gnc_commodity *curr)
+gnc_price_print_info (const gnc_commodity *curr, gboolean use_symbol)
{
GNCPrintAmountInfo info;
gboolean force = gnc_prefs_get_bool (GNC_PREFS_GROUP_GENERAL,
@@ -1504,7 +1504,7 @@ gnc_default_price_print_info (const gnc_commodity *curr)
}
info.use_separators = 1;
- info.use_symbol = 0;
+ info.use_symbol = use_symbol ? 1 : 0;
info.use_locale = 1;
info.monetary = 1;
@@ -1513,6 +1513,13 @@ gnc_default_price_print_info (const gnc_commodity *curr)
return info;
}
+GNCPrintAmountInfo
+gnc_default_price_print_info (const gnc_commodity *curr)
+{
+ return gnc_price_print_info (curr, FALSE);
+}
+
+
GNCPrintAmountInfo
gnc_integral_print_info (void)
{
diff --git a/libgnucash/app-utils/gnc-ui-util.h b/libgnucash/app-utils/gnc-ui-util.h
index 472ee4dbc..53ea76a71 100644
--- a/libgnucash/app-utils/gnc-ui-util.h
+++ b/libgnucash/app-utils/gnc-ui-util.h
@@ -303,6 +303,9 @@ GNCPrintAmountInfo gnc_account_print_info (const Account *account,
GNCPrintAmountInfo gnc_split_amount_print_info (Split *split,
gboolean use_symbol);
+GNCPrintAmountInfo gnc_price_print_info (const gnc_commodity *curr,
+ gboolean use_symbol);
+
GNCPrintAmountInfo gnc_share_print_info_places (int decplaces);
GNCPrintAmountInfo gnc_default_share_print_info (void);
GNCPrintAmountInfo gnc_default_price_print_info (const gnc_commodity *curr);
commit 182d4d9de7b0dd06b08381bbc0f861a9fd596ba1
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon May 11 21:22:59 2020 +0800
Bug 797743 - Monetary amounts are occasionally rendered in fractions
If monetary is already in decimal, don't convert. If monetary is
exact (x/y) then convert to its SCU.
As a result, monetary amounts in an arbitrary precision will be
displayed unchanged, e.g. US$0.1442, whereas exact monetary amounts
will be displayed using the currency's SCU e.g. US$1/3 -> $0.33
diff --git a/gnucash/report/report-system/html-style-info.scm b/gnucash/report/report-system/html-style-info.scm
index f57653c40..6e9cb3041 100644
--- a/gnucash/report/report-system/html-style-info.scm
+++ b/gnucash/report/report-system/html-style-info.scm
@@ -267,9 +267,13 @@
(xaccPrintAmount datum (gnc-default-print-info #f)))
(define (gnc:default-html-gnc-monetary-renderer datum params)
- (xaccPrintAmount
- (gnc:gnc-monetary-amount datum)
- (gnc-commodity-print-info (gnc:gnc-monetary-commodity datum) #t)))
+ (let* ((comm (gnc:gnc-monetary-commodity datum))
+ (scu (gnc-commodity-get-fraction comm))
+ (amount (gnc:gnc-monetary-amount datum))
+ (amt-display (if (exact? amount)
+ (gnc-numeric-convert amount scu GNC-HOW-RND-ROUND)
+ amount)))
+ (xaccPrintAmount amt-display (gnc-commodity-print-info comm #t))))
(define (gnc:default-html-number-renderer datum params)
(xaccPrintAmount
diff --git a/gnucash/report/standard-reports/test/test-portfolios.scm b/gnucash/report/standard-reports/test/test-portfolios.scm
index c72ac8261..390a8d645 100644
--- a/gnucash/report/standard-reports/test/test-portfolios.scm
+++ b/gnucash/report/standard-reports/test/test-portfolios.scm
@@ -91,7 +91,7 @@
(set-option! options "General" "Price Source" 'weighted-average)
(let ((sxml (options->sxml portfolio-uuid options "'weighted-average")))
(test-equal "portfolio: weighted-average"
- '("AAPL" "AAPL" "NASDAQ" "1.00" "$233.33" "$233 + 1/3")
+ '("AAPL" "AAPL" "NASDAQ" "1.00" "$233.33" "$233.33")
(sxml->table-row-col sxml 1 1 #f))))
(teardown)))
Summary of changes:
gnucash/report/html-style-info.scm | 14 +++++++++---
gnucash/report/html-utilities.scm | 7 ++++--
gnucash/report/report.scm | 1 +
.../report/reports/standard/advanced-portfolio.scm | 16 +++++--------
gnucash/report/reports/standard/balsheet-pnl.scm | 6 +++--
gnucash/report/reports/standard/register.scm | 10 +++++----
.../reports/standard/test/test-balsheet-pnl.scm | 18 +++++++--------
.../reports/standard/test/test-portfolios.scm | 8 +++----
.../report/reports/support/balsheet-eg.eguile.scm | 26 ++++++++++------------
gnucash/report/trep-engine.scm | 23 +++++--------------
libgnucash/app-utils/app-utils.i | 2 ++
libgnucash/app-utils/gnc-ui-util.c | 11 +++++++--
libgnucash/app-utils/gnc-ui-util.h | 3 +++
13 files changed, 76 insertions(+), 69 deletions(-)
More information about the gnucash-changes
mailing list