gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Sat Sep 14 04:20:16 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/ec5b1109 (commit)
via https://github.com/Gnucash/gnucash/commit/268e9670 (commit)
via https://github.com/Gnucash/gnucash/commit/0ec82872 (commit)
via https://github.com/Gnucash/gnucash/commit/6e12bf81 (commit)
from https://github.com/Gnucash/gnucash/commit/525bcd39 (commit)
commit ec5b110936620809c27649df31728e382e498a10
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Sep 14 11:46:15 2019 +0800
[trial-balance] compact function
use functional instead of accumulator style to handle
adjusting/closing debit/credit amounts.
diff --git a/gnucash/report/standard-reports/trial-balance.scm b/gnucash/report/standard-reports/trial-balance.scm
index a5d2ad733..8b8aed9d5 100644
--- a/gnucash/report/standard-reports/trial-balance.scm
+++ b/gnucash/report/standard-reports/trial-balance.scm
@@ -667,6 +667,12 @@
splits)
total))
+ (define (coll-minus . collectors)
+ (let ((res (gnc:make-commodity-collector)))
+ (res 'merge (car collectors) #f)
+ (for-each (lambda (mon) (res 'minusmerge mon #f)) (cdr collectors))
+ res))
+
(while (< row rows)
(let* ((env (gnc:html-acct-table-get-row-env acct-table row))
(acct (get-val env 'account))
@@ -676,46 +682,33 @@
(is? (member acct all-is-accounts))
(ga-or-is? (or (member acct all-ga-accounts) is?))
(pos-adjusting
- (and ga-or-is?
- adjusting
- (sum-account-splits acct adjusting-splits #t)))
+ (and ga-or-is? (sum-account-splits acct adjusting-splits #t)))
(neg-adjusting
- (and pos-adjusting (gnc:make-commodity-collector)))
- (pre-closing-bal (gnc:make-commodity-collector))
- (pre-adjusting-bal (gnc:make-commodity-collector))
- (atb #f))
-
- ;; +P_ADJ + -N_ADJ = xADJ. xADJ - +P_ADJ = -N_ADJ.
- ;; That is, credit values are stored as such (negative).
- (when neg-adjusting
- (neg-adjusting 'merge adjusting #f)
- (neg-adjusting 'minusmerge pos-adjusting #f))
-
- (pre-closing-bal 'merge curr-bal #f)
- ;; remove closing entries
- (pre-closing-bal 'minusmerge closing #f)
- (pre-adjusting-bal 'merge pre-closing-bal #f)
- ;; remove closing entries
- (pre-adjusting-bal 'minusmerge adjusting #f)
- ;; we now have a pre-adjusting-bal,
- ;; pre-closing-bal, and curr-bal
-
- (set! atb
- ;; calculate the adjusted trial balance to use
- ;; this depends on whether or not we are netting
- ;; the atb value... so we check is?.
- (if is?
- (let* ((debit (gnc:make-commodity-collector))
- (credit (gnc:make-commodity-collector)))
- (debit 'merge pos-adjusting #f)
- (credit 'merge neg-adjusting #f)
- (if (double-col
- 'credit-q pre-adjusting-bal
- report-commodity exchange-fn show-fcur?)
- (credit 'merge pre-adjusting-bal #f)
- (debit 'merge pre-adjusting-bal #f))
- (list debit credit))
- pre-closing-bal))
+ (and ga-or-is? (coll-minus adjusting pos-adjusting)))
+ (pre-closing-bal (coll-minus curr-bal closing))
+ (pre-adjusting-bal (coll-minus pre-closing-bal adjusting))
+ (atb (if is?
+ (let* ((debit (gnc:make-commodity-collector))
+ (credit (gnc:make-commodity-collector)))
+ (debit 'merge pos-adjusting #f)
+ (credit 'merge neg-adjusting #f)
+ (if (double-col
+ 'credit-q pre-adjusting-bal
+ report-commodity exchange-fn show-fcur?)
+ (credit 'merge pre-adjusting-bal #f)
+ (debit 'merge pre-adjusting-bal #f))
+ (list debit credit))
+ pre-closing-bal)))
+
+ ;; curr-bal = account-bal with closing & adj entries
+ ;; pre-closing-bal = account-bal with adj entries only
+ ;; pre-adjusting-bal = account-bal without both
+
+ ;; pos- and neg-adjusting are adjusting's +ve and -ve amounts
+
+ ;; atb is account-bal with adjusting entries separated
+ ;; into +ve and -ve columns, or pre-closing-bal. no
+ ;; explanation was offered in bug #150008.
(gnc:html-acct-table-set-cell!
acct-table row pa-col pre-adjusting-bal)
commit 268e9670e2b984759f622c987fe4c7116884f2cc
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Sep 14 09:40:10 2019 +0800
[trial-balance] rewrite to omit account-get-pos-trans-total-interval
Reuse adjusting-splits and filter for positive values.
This function was buggy... see total-query is defined as the
output of qof-query-merge-in-place, or qof-query-destroy, both
returning #unspecified; this fails when passed to qof-query-run.
diff --git a/gnucash/report/standard-reports/trial-balance.scm b/gnucash/report/standard-reports/trial-balance.scm
index f5d8d711b..a5d2ad733 100644
--- a/gnucash/report/standard-reports/trial-balance.scm
+++ b/gnucash/report/standard-reports/trial-balance.scm
@@ -318,57 +318,6 @@
options))
-(define (account-get-pos-trans-total-interval
- account-list type start-date end-date)
- (let* ((str-query (qof-query-create-for-splits))
- (sign-query (qof-query-create-for-splits))
- (total-query #f)
- (get-val (lambda (alist key)
- (let ((lst (assoc-ref alist key)))
- (and lst (car lst)))))
- (matchstr (get-val type 'str))
- (case-sens (and (get-val type 'cased) #t))
- (regexp (and (get-val type 'regexp) #t))
- (pos? (and (get-val type 'positive) #t))
- (total (gnc:make-commodity-collector)))
- (qof-query-set-book str-query (gnc-get-current-book))
- (qof-query-set-book sign-query (gnc-get-current-book))
- (gnc:query-set-match-non-voids-only! str-query (gnc-get-current-book))
- (gnc:query-set-match-non-voids-only! sign-query (gnc-get-current-book))
- (xaccQueryAddAccountMatch str-query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
- (xaccQueryAddAccountMatch sign-query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
- (xaccQueryAddDateMatchTT str-query
- (and start-date #t) (or start-date 0)
- (and end-date #t) (or end-date 0)
- QOF-QUERY-AND)
- (xaccQueryAddDateMatchTT sign-query
- (and start-date #t) (or start-date 0)
- (and end-date #t) (or end-date 0)
- QOF-QUERY-AND)
- (xaccQueryAddDescriptionMatch
- str-query matchstr case-sens regexp QOF-COMPARE-CONTAINS QOF-QUERY-AND)
- (set! total-query
- ;; this is a tad inefficient, but its a simple way to accomplish
- ;; description match inversion...
- (if pos?
- (qof-query-merge-in-place sign-query str-query QOF-QUERY-AND)
- (let ((inv-query (qof-query-invert str-query)))
- (qof-query-merge-in-place
- sign-query inv-query QOF-QUERY-AND)
- (qof-query-destroy inv-query))))
- (qof-query-destroy str-query)
-
- (for-each
- (lambda (split)
- (let* ((shares (xaccSplitGetAmount split))
- (acct-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount split))))
- (unless (negative? shares)
- (total 'add acct-comm shares))))
- (qof-query-run total-query))
- (qof-query-destroy total-query)
- total))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; trial-balance-renderer
;; set up the document and add the table
@@ -706,35 +655,30 @@
(list 'regexp adjusting-regexp))
start-date end-date)))
- (define (sum-account-splits account splits)
+ (define (sum-account-splits account splits pos-filter?)
(let ((total (gnc:make-commodity-collector))
(comm (xaccAccountGetCommodity account)))
(for-each
(lambda (s)
- (when (equal? (xaccSplitGetAccount s) account)
- (total 'add comm (xaccSplitGetAmount s))))
+ (let ((amt (xaccSplitGetAmount s)))
+ (when (and (equal? (xaccSplitGetAccount s) account)
+ (or (not pos-filter?) (positive? amt)))
+ (total 'add comm amt))))
splits)
total))
(while (< row rows)
(let* ((env (gnc:html-acct-table-get-row-env acct-table row))
(acct (get-val env 'account))
- (group (list acct))
(curr-bal (get-val env 'account-bal))
- (closing (sum-account-splits acct closing-splits))
- (adjusting (sum-account-splits acct adjusting-splits))
+ (closing (sum-account-splits acct closing-splits #f))
+ (adjusting (sum-account-splits acct adjusting-splits #f))
(is? (member acct all-is-accounts))
(ga-or-is? (or (member acct all-ga-accounts) is?))
(pos-adjusting
(and ga-or-is?
adjusting
- (account-get-pos-trans-total-interval
- group
- (list (list 'str adjusting-str)
- (list 'cased adjusting-cased)
- (list 'regexp adjusting-regexp)
- (list 'positive #t))
- start-date end-date)))
+ (sum-account-splits acct adjusting-splits #t)))
(neg-adjusting
(and pos-adjusting (gnc:make-commodity-collector)))
(pre-closing-bal (gnc:make-commodity-collector))
commit 0ec82872b0b3542a996f129d25ff1383021ac9b9
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Sep 14 01:13:24 2019 +0800
[trial-balance] speedup: retrieve closing/adjusting splits once
only 2 qof-query at the start, instead of 2 qof-query per account
diff --git a/gnucash/report/standard-reports/trial-balance.scm b/gnucash/report/standard-reports/trial-balance.scm
index 07c9c5630..f5d8d711b 100644
--- a/gnucash/report/standard-reports/trial-balance.scm
+++ b/gnucash/report/standard-reports/trial-balance.scm
@@ -691,32 +691,38 @@
;; it stores a two-element list of commodity collectors:
;; (list debit-collector credit-collector)
(let* ((row 0)
- (rows (gnc:html-acct-table-num-rows acct-table)))
+ (rows (gnc:html-acct-table-num-rows acct-table))
+ (closing-splits
+ (gnc:account-get-trans-type-splits-interval
+ all-accounts (list (list 'str closing-str)
+ (list 'cased closing-cased)
+ (list 'regexp closing-regexp)
+ (list 'closing #t))
+ start-date end-date))
+ (adjusting-splits
+ (gnc:account-get-trans-type-splits-interval
+ all-accounts (list (list 'str adjusting-str)
+ (list 'cased adjusting-cased)
+ (list 'regexp adjusting-regexp))
+ start-date end-date)))
+
+ (define (sum-account-splits account splits)
+ (let ((total (gnc:make-commodity-collector))
+ (comm (xaccAccountGetCommodity account)))
+ (for-each
+ (lambda (s)
+ (when (equal? (xaccSplitGetAccount s) account)
+ (total 'add comm (xaccSplitGetAmount s))))
+ splits)
+ total))
(while (< row rows)
(let* ((env (gnc:html-acct-table-get-row-env acct-table row))
(acct (get-val env 'account))
(group (list acct))
(curr-bal (get-val env 'account-bal))
- (closing
- (gnc:account-get-trans-type-balance-interval-with-closing
- group
- (list (list 'str closing-str)
- (list 'cased closing-cased)
- (list 'regexp closing-regexp)
- (list 'closing #t)
- )
- start-date end-date
- ))
- (adjusting
- (gnc:account-get-trans-type-balance-interval-with-closing
- group
- (list (list 'str adjusting-str)
- (list 'cased adjusting-cased)
- (list 'regexp adjusting-regexp)
- )
- start-date end-date
- ))
+ (closing (sum-account-splits acct closing-splits))
+ (adjusting (sum-account-splits acct adjusting-splits))
(is? (member acct all-is-accounts))
(ga-or-is? (or (member acct all-ga-accounts) is?))
(pos-adjusting
commit 6e12bf81a924c3d797a9597adbc89b869249b8d5
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Sep 14 00:58:51 2019 +0800
[trial-balance] *untabify/delete-trailing-whitespace/reindent*
global reindent
diff --git a/gnucash/report/standard-reports/trial-balance.scm b/gnucash/report/standard-reports/trial-balance.scm
index fd4088e99..07c9c5630 100644
--- a/gnucash/report/standard-reports/trial-balance.scm
+++ b/gnucash/report/standard-reports/trial-balance.scm
@@ -51,7 +51,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report standard-reports trial-balance))
-(use-modules (gnucash utilities))
+(use-modules (srfi srfi-1))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
@@ -115,7 +116,7 @@
;; FIXME: this option doesn't produce a correct work sheet when
;; selected after closing... it omits adjusted temporary accounts
-;;
+;;
;; the fix for this really should involve passing thunks to
;; gnc:make-html-acct-table
(define optname-show-zb-accts (N_ "Include accounts with zero total balances"))
@@ -142,29 +143,29 @@
;; 'side returns 'debit or 'credit, the column in which to display
;; 'debt|'credit return the entry, if appropriate, or #f
(define (double-col
- req signed-balance report-commodity exchange-fn show-comm?)
+ req signed-balance report-commodity exchange-fn show-comm?)
(let* ((sum (and signed-balance
- (gnc:sum-collector-commodity
- signed-balance
- report-commodity
- exchange-fn)))
- (amt (and sum (gnc:gnc-monetary-amount sum)))
- (neg? (and amt (negative? amt)))
- (bal (if neg?
- (let ((bal (gnc:make-commodity-collector)))
- (bal 'minusmerge signed-balance #f)
- bal)
- signed-balance))
- (bal-sum (gnc:sum-collector-commodity
- bal
- report-commodity
- exchange-fn))
- (balance
- (if (gnc:uniform-commodity? bal report-commodity)
- (if (zero? amt) #f bal-sum)
- (if show-comm?
- (gnc-commodity-table bal report-commodity exchange-fn)
- bal-sum))))
+ (gnc:sum-collector-commodity
+ signed-balance
+ report-commodity
+ exchange-fn)))
+ (amt (and sum (gnc:gnc-monetary-amount sum)))
+ (neg? (and amt (negative? amt)))
+ (bal (if neg?
+ (let ((bal (gnc:make-commodity-collector)))
+ (bal 'minusmerge signed-balance #f)
+ bal)
+ signed-balance))
+ (bal-sum (gnc:sum-collector-commodity
+ bal
+ report-commodity
+ exchange-fn))
+ (balance
+ (if (gnc:uniform-commodity? bal report-commodity)
+ (if (zero? amt) #f bal-sum)
+ (if show-comm?
+ (gnc-commodity-table bal report-commodity exchange-fn)
+ bal-sum))))
(assq-ref (list
(cons 'entry balance)
(cons 'debit (if neg? #f balance))
@@ -177,41 +178,41 @@
;; options generator
(define (trial-balance-options-generator)
(let* ((options (gnc:new-options))
- (book (gnc-get-current-book)) ; XXX Find a way to get the book that opened the report
- (add-option
+ (book (gnc-get-current-book))
+ (add-option
(lambda (new-option)
(gnc:register-option options new-option))))
-
+
(add-option
- (gnc:make-string-option
+ (gnc:make-string-option
(N_ "General") optname-report-title
"a" opthelp-report-title (_ reportname)))
(add-option
- (gnc:make-string-option
+ (gnc:make-string-option
(N_ "General") optname-party-name
"b" opthelp-party-name (or (gnc:company-info book gnc:*company-name*) "")))
-
+
;; the period over which to collect adjusting/closing entries and
;; date at which to report the balance
(gnc:options-add-date-interval!
- options gnc:pagename-general
+ options gnc:pagename-general
optname-start-date optname-end-date "c")
-
+
(add-option
(gnc:make-multichoice-option
gnc:pagename-general optname-report-variant
"d" opthelp-report-variant
'current
(list (vector 'current
- (N_ "Current Trial Balance")
- (N_ "Uses the exact balances in the general journal"))
- (vector 'pre-adj
- (N_ "Pre-adjustment Trial Balance")
- (N_ "Ignores Adjusting/Closing entries"))
- (vector 'work-sheet
- (N_ "Work Sheet")
- (N_ "Creates a complete end-of-period work sheet")))))
-
+ (N_ "Current Trial Balance")
+ (N_ "Uses the exact balances in the general journal"))
+ (vector 'pre-adj
+ (N_ "Pre-adjustment Trial Balance")
+ (N_ "Ignores Adjusting/Closing entries"))
+ (vector 'work-sheet
+ (N_ "Work Sheet")
+ (N_ "Creates a complete end-of-period work sheet")))))
+
;; accounts to work on
(add-option
(gnc:make-account-list-option
@@ -219,7 +220,7 @@
"a"
opthelp-accounts
(lambda ()
- (gnc:filter-accountlist-type
+ (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
@@ -239,10 +240,9 @@
"c"
opthelp-gross-adjustment-accounts
(lambda ()
- ;; Here, it would be useful to have an inventory account type.
- ;; Lacking that, just select no accounts by default.
- '()
- )
+ ;; Here, it would be useful to have an inventory account type.
+ ;; Lacking that, just select no accounts by default.
+ '())
#f #t))
(add-option
(gnc:make-account-list-option
@@ -250,35 +250,34 @@
"d"
opthelp-income-summary-accounts
(lambda ()
- '()
- )
+ '())
#f #t))
-
+
;; all about currencies
(gnc:options-add-currency!
options pagename-commodities
optname-report-commodity "a")
-
- (gnc:options-add-price-source!
+
+ (gnc:options-add-price-source!
options pagename-commodities
optname-price-source "b" 'pricedb-nearest)
-
- (add-option
+
+ (add-option
(gnc:make-simple-boolean-option
- pagename-commodities optname-show-foreign
+ pagename-commodities optname-show-foreign
"c" opthelp-show-foreign #f))
-
- (add-option
+
+ (add-option
(gnc:make-simple-boolean-option
pagename-commodities optname-show-rates
"d" opthelp-show-rates #f))
-
+
;; adjusting/closing entry match criteria
- ;;
+ ;;
;; N.B.: transactions really should have a field where we can put
;; transaction types like "Adjusting/Closing/Correcting Entries"
(add-option
- (gnc:make-string-option
+ (gnc:make-string-option
pagename-entries optname-adjusting-pattern
"a" opthelp-adjusting-pattern (_ "Adjusting Entries")))
(add-option
@@ -290,7 +289,7 @@
pagename-entries optname-adjusting-regexp
"c" opthelp-adjusting-regexp #f))
(add-option
- (gnc:make-string-option
+ (gnc:make-string-option
pagename-entries optname-closing-pattern
"d" opthelp-closing-pattern (_ "Closing Entries")))
(add-option
@@ -301,36 +300,36 @@
(gnc:make-simple-boolean-option
pagename-entries optname-closing-regexp
"f" opthelp-closing-regexp #f))
-
+
;; what to show for zero-balance accounts
- ;;(add-option
+ ;;(add-option
;; (gnc:make-simple-boolean-option
;; gnc:pagename-display optname-show-zb-accts
;; "a" opthelp-show-zb-accts #t))
-
+
;; some detailed formatting options
- (add-option
+ (add-option
(gnc:make-simple-boolean-option
gnc:pagename-display optname-account-links
"e" opthelp-account-links #t))
-
+
;; Set the accounts page as default option tab
(gnc:options-set-default-section options gnc:pagename-display)
-
+
options))
(define (account-get-pos-trans-total-interval
- account-list type start-date end-date)
+ account-list type start-date end-date)
(let* ((str-query (qof-query-create-for-splits))
- (sign-query (qof-query-create-for-splits))
- (total-query #f)
- (get-val (lambda (alist key)
- (let ((lst (assoc-ref alist key)))
- (and lst (car lst)))))
- (matchstr (get-val type 'str))
- (case-sens (and (get-val type 'cased) #t))
- (regexp (and (get-val type 'regexp) #t))
- (pos? (and (get-val type 'positive) #t))
+ (sign-query (qof-query-create-for-splits))
+ (total-query #f)
+ (get-val (lambda (alist key)
+ (let ((lst (assoc-ref alist key)))
+ (and lst (car lst)))))
+ (matchstr (get-val type 'str))
+ (case-sens (and (get-val type 'cased) #t))
+ (regexp (and (get-val type 'regexp) #t))
+ (pos? (and (get-val type 'positive) #t))
(total (gnc:make-commodity-collector)))
(qof-query-set-book str-query (gnc-get-current-book))
(qof-query-set-book sign-query (gnc-get-current-book))
@@ -361,12 +360,12 @@
(for-each
(lambda (split)
- (let* ((shares (xaccSplitGetAmount split))
- (acct-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount split))))
- (unless (negative? shares)
- (total 'add acct-comm shares))))
- (qof-query-run total-query))
+ (let* ((shares (xaccSplitGetAmount split))
+ (acct-comm (xaccAccountGetCommodity
+ (xaccSplitGetAccount split))))
+ (unless (negative? shares)
+ (total 'add acct-comm shares))))
+ (qof-query-run total-query))
(qof-query-destroy total-query)
total))
@@ -377,64 +376,46 @@
;; requested, export it to a file
;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define (trial-balance-renderer report-obj choice filename)
+(define (trial-balance-renderer report-obj)
(define (get-option pagename optname)
(gnc:option-value
- (gnc:lookup-option
+ (gnc:lookup-option
(gnc:report-options report-obj) pagename optname)))
-
+
(gnc:report-starting reportname)
-
+
;; get all option's values
- (let* (
- (report-title (get-option gnc:pagename-general optname-report-title))
- (company-name (get-option gnc:pagename-general optname-party-name))
- (start-date-printable (gnc:date-option-absolute-time
- (get-option gnc:pagename-general
- optname-start-date)))
+ (let* ((report-title (get-option gnc:pagename-general optname-report-title))
+ (company-name (get-option gnc:pagename-general optname-party-name))
+ (start-date-printable
+ (gnc:date-option-absolute-time
+ (get-option gnc:pagename-general optname-start-date)))
(start-date (gnc:time64-end-day-time
- (gnc:time64-previous-day start-date-printable)))
- (end-date (gnc:time64-end-day-time
- (gnc:date-option-absolute-time
- (get-option gnc:pagename-general
- optname-end-date))))
- (report-variant (get-option gnc:pagename-general
- optname-report-variant))
- (accounts (get-option gnc:pagename-accounts
- optname-accounts))
+ (gnc:time64-previous-day start-date-printable)))
+ (end-date (gnc:time64-end-day-time
+ (gnc:date-option-absolute-time
+ (get-option gnc:pagename-general optname-end-date))))
+ (report-variant (get-option gnc:pagename-general optname-report-variant))
+ (accounts (get-option gnc:pagename-accounts optname-accounts))
(ga-accounts (get-option pagename-merchandising
- optname-gross-adjustment-accounts))
+ optname-gross-adjustment-accounts))
(is-accounts (get-option pagename-merchandising
- optname-income-summary-accounts))
- (depth-limit (get-option gnc:pagename-accounts
- optname-depth-limit))
- (adjusting-str (get-option pagename-entries
- optname-adjusting-pattern))
- (adjusting-cased (get-option pagename-entries
- optname-adjusting-casing))
- (adjusting-regexp (get-option pagename-entries
- optname-adjusting-regexp))
- (closing-str (get-option pagename-entries
- optname-closing-pattern))
- (closing-cased (get-option pagename-entries
- optname-closing-casing))
- (closing-regexp (get-option pagename-entries
- optname-closing-regexp))
- (report-commodity (get-option pagename-commodities
- optname-report-commodity))
- (price-source (get-option pagename-commodities
- optname-price-source))
- (show-fcur? (get-option pagename-commodities
- optname-show-foreign))
- (show-rates? (get-option pagename-commodities
- optname-show-rates))
- ;;(show-zb-accts? (get-option gnc:pagename-display
- ;; optname-show-zb-accts))
- (show-zb-accts? #t) ;; see FIXME above
- (use-links? (get-option gnc:pagename-display
- optname-account-links))
- (indent 0)
-
+ optname-income-summary-accounts))
+ (depth-limit (get-option gnc:pagename-accounts optname-depth-limit))
+ (adjusting-str (get-option pagename-entries optname-adjusting-pattern))
+ (adjusting-cased (get-option pagename-entries optname-adjusting-casing))
+ (adjusting-regexp (get-option pagename-entries optname-adjusting-regexp))
+ (closing-str (get-option pagename-entries optname-closing-pattern))
+ (closing-cased (get-option pagename-entries optname-closing-casing))
+ (closing-regexp (get-option pagename-entries optname-closing-regexp))
+ (report-commodity (get-option pagename-commodities optname-report-commodity))
+ (price-source (get-option pagename-commodities optname-price-source))
+ (show-fcur? (get-option pagename-commodities optname-show-foreign))
+ (show-rates? (get-option pagename-commodities optname-show-rates))
+ (show-zb-accts? #t)
+ (use-links? (get-option gnc:pagename-display optname-account-links))
+ (indent 0)
+
;; decompose the account list
(split-up-accounts (gnc:decompose-accountlist accounts))
(asset-accounts
@@ -442,775 +423,583 @@
(liability-accounts
(assoc-ref split-up-accounts ACCT-TYPE-LIABILITY))
(income-expense-accounts
- (append (assoc-ref split-up-accounts ACCT-TYPE-INCOME)
- (assoc-ref split-up-accounts ACCT-TYPE-EXPENSE)))
+ (append-reverse (assoc-ref split-up-accounts ACCT-TYPE-INCOME)
+ (assoc-ref split-up-accounts ACCT-TYPE-EXPENSE)))
(equity-accounts
(assoc-ref split-up-accounts ACCT-TYPE-EQUITY))
- ;; (all-accounts (map (lambda (X) (cadr X)) split-up-accounts))
- ;; ^ will not do what we want
- (all-accounts
- (append asset-accounts liability-accounts
- equity-accounts income-expense-accounts))
-
- ;; same for gross adjustment accounts...
- (split-up-ga-accounts (gnc:decompose-accountlist ga-accounts))
- (all-ga-accounts
+ ;; (all-accounts (map (lambda (X) (cadr X)) split-up-accounts))
+ ;; ^ will not do what we want
+ (all-accounts
+ (append asset-accounts liability-accounts
+ equity-accounts income-expense-accounts))
+
+ ;; same for gross adjustment accounts...
+ (split-up-ga-accounts (gnc:decompose-accountlist ga-accounts))
+ (all-ga-accounts
(append (assoc-ref split-up-ga-accounts ACCT-TYPE-ASSET)
(assoc-ref split-up-ga-accounts ACCT-TYPE-LIABILITY)
(assoc-ref split-up-ga-accounts ACCT-TYPE-EQUITY)
(assoc-ref split-up-ga-accounts ACCT-TYPE-INCOME)
(assoc-ref split-up-ga-accounts ACCT-TYPE-EXPENSE)))
- (split-up-is-accounts (gnc:decompose-accountlist is-accounts))
-
- ;; same for income statement accounts...
- (all-is-accounts
+ (split-up-is-accounts (gnc:decompose-accountlist is-accounts))
+
+ ;; same for income statement accounts...
+ (all-is-accounts
(append (assoc-ref split-up-is-accounts ACCT-TYPE-ASSET)
(assoc-ref split-up-is-accounts ACCT-TYPE-LIABILITY)
(assoc-ref split-up-is-accounts ACCT-TYPE-EQUITY)
(assoc-ref split-up-is-accounts ACCT-TYPE-INCOME)
(assoc-ref split-up-is-accounts ACCT-TYPE-EXPENSE)))
-
- (doc (gnc:make-html-document))
+
+ (doc (gnc:make-html-document))
;; exchange rates calculation parameters
- (exchange-fn
- (gnc:case-exchange-fn price-source report-commodity end-date))
- (period-for (string-append " " (_ "for Period"))))
-
- (gnc:html-document-set-title!
- doc (if (equal? report-variant 'current)
- (format #f (string-append "~a ~a ~a")
- company-name report-title
- (qof-print-date end-date))
- (format #f (string-append "~a ~a "
- (_ "For Period Covering ~a to ~a"))
- company-name report-title
- (qof-print-date start-date-printable)
- (qof-print-date end-date))
- )
- )
-
+ (exchange-fn
+ (gnc:case-exchange-fn price-source report-commodity end-date))
+ (period-for (string-append " " (_ "for Period"))))
+
+ (gnc:html-document-set-title!
+ doc (if (eq? report-variant 'current)
+ (format #f "~a ~a ~a"
+ company-name report-title
+ (qof-print-date end-date))
+ (format #f (string-append "~a ~a "
+ (_ "For Period Covering ~a to ~a"))
+ company-name report-title
+ (qof-print-date start-date-printable)
+ (qof-print-date end-date))))
+
(if (null? accounts)
-
+
;; error condition: no accounts specified
- ;; is this *really* necessary??
- ;; i'd be fine with an all-zero trial balance
- ;; that would, technically, be correct....
- (gnc:html-document-add-object!
- doc
- (gnc:html-make-no-account-warning
- reportname (gnc:report-id report-obj)))
-
+ ;; is this *really* necessary??
+ ;; i'd be fine with an all-zero trial balance
+ ;; that would, technically, be correct....
+ (gnc:html-document-add-object!
+ doc
+ (gnc:html-make-no-account-warning
+ reportname (gnc:report-id report-obj)))
+
;; Get all the balances for each account group.
(let* ((build-table (gnc:make-html-table))
- (acct-table #f)
- (debit-tot (gnc:make-commodity-collector))
- (credit-tot (gnc:make-commodity-collector))
+ (acct-table #f)
+ (debit-tot (gnc:make-commodity-collector))
+ (credit-tot (gnc:make-commodity-collector))
(neg-unrealized-gain-collector (gnc:make-commodity-collector))
- (table-env #f) ;; parameters for :make-
- (account-cols #f)
- (indented-depth #f)
- (header-rows 0)
- (adj-debits (gnc:make-commodity-collector))
- (adj-credits (gnc:make-commodity-collector))
- (atb-debits (gnc:make-commodity-collector))
- (atb-credits (gnc:make-commodity-collector))
- (is-debits (gnc:make-commodity-collector))
- (is-credits (gnc:make-commodity-collector))
- (bs-debits (gnc:make-commodity-collector))
- (bs-credits (gnc:make-commodity-collector))
- )
-
- ;; Wrapper to call gnc:html-table-add-labeled-amount-line!
- ;; with the proper arguments.
- ;; (This is used to fill in the Trial Balance columns.)
- (define (add-line table label signed-balance)
- (let* ((entry (double-col
- 'entry signed-balance
- report-commodity exchange-fn show-fcur?))
- (credit? (double-col
- 'credit-q signed-balance
- report-commodity exchange-fn show-fcur?))
- )
- (gnc:html-table-add-labeled-amount-line!
- table
- (+ account-cols 2)
- "primary-subheading"
- #f
- label indented-depth 1 "text-cell"
- entry
- (+ account-cols (if credit? 1 0)) 1 "number-cell"
- )
- ;; update the running totals
- (if credit?
- (credit-tot 'minusmerge signed-balance #f)
- (debit-tot 'merge signed-balance #f)
- )
- )
- )
-
- (define (get-val alist key)
- (let ((lst (assoc-ref alist key)))
- (if lst (car lst) lst)))
-
- (define pa-col 0) ;; pre-adjustments column
- (define adj-col 1) ;; adjustments column
- (define atb-col 2) ;; adjusted trial balance column
- (define is-col 3) ;; income statement column
- (define bs-col 4) ;; balance sheet column
- (define bal-col 5) ;; for the current (general journal) balance
-
- (define (report-val amt)
- (gnc:sum-collector-commodity
- amt report-commodity exchange-fn)
- )
-
- ;; Returns a gnc:html-table-cell containing the absolute value
- ;; of the given amount in the report commodity.
- (define (tot-abs-amt-cell amt)
- (let* ((neg-amt (gnc:make-commodity-collector))
- (rv (report-val amt))
- (neg? (gnc-numeric-negative-p
- (gnc:gnc-monetary-amount rv)))
- (cell #f)
- )
- (neg-amt 'minusmerge amt #f)
- (set! cell
- (gnc:make-html-table-cell/markup
- "total-number-cell" (if neg? (report-val neg-amt) rv)))
- (gnc:html-table-cell-set-style!
- cell "total-number-cell"
- 'attribute '("align" "right")
- 'attribute '("valign" "top")
- )
- cell)
- )
-
- ;; sum any unrealized gains
- ;;
- ;; Hm... unrealized gains.... This is when you purchase
- ;; something and its value increases/decreases (prior to
- ;; your selling it) and you have to reflect that on your
- ;; balance sheet.
- ;;
- ;; I *think* a decrease in the value of a liability or
- ;; equity constitutes an unrealized loss. I'm unsure about
- ;; that though....
+ (table-env #f) ;; parameters for :make-
+ (account-cols #f)
+ (indented-depth #f)
+ (header-rows 0)
+ (adj-debits (gnc:make-commodity-collector))
+ (adj-credits (gnc:make-commodity-collector))
+ (atb-debits (gnc:make-commodity-collector))
+ (atb-credits (gnc:make-commodity-collector))
+ (is-debits (gnc:make-commodity-collector))
+ (is-credits (gnc:make-commodity-collector))
+ (bs-debits (gnc:make-commodity-collector))
+ (bs-credits (gnc:make-commodity-collector)))
+
+ ;; Wrapper to call gnc:html-table-add-labeled-amount-line!
+ ;; with the proper arguments.
+ ;; (This is used to fill in the Trial Balance columns.)
+ (define (add-line table label signed-balance)
+ (let* ((entry (double-col
+ 'entry signed-balance
+ report-commodity exchange-fn show-fcur?))
+ (credit? (double-col
+ 'credit-q signed-balance
+ report-commodity exchange-fn show-fcur?)))
+ (gnc:html-table-add-labeled-amount-line!
+ table (+ account-cols 2) "primary-subheading"
+ #f label indented-depth 1 "text-cell"
+ entry (+ account-cols (if credit? 1 0)) 1 "number-cell")
+ ;; update the running totals
+ (if credit?
+ (credit-tot 'minusmerge signed-balance #f)
+ (debit-tot 'merge signed-balance #f))))
+
+ (define (get-val alist key)
+ (let ((lst (assq-ref alist key)))
+ (and lst (car lst))))
+
+ (define pa-col 0) ;; pre-adjustments column
+ (define adj-col 1) ;; adjustments column
+ (define atb-col 2) ;; adjusted trial balance column
+ (define is-col 3) ;; income statement column
+ (define bs-col 4) ;; balance sheet column
+ (define bal-col 5) ;; for the current (general journal) balance
+
+ (define (report-val amt)
+ (gnc:sum-collector-commodity
+ amt report-commodity exchange-fn))
+
+ ;; Returns a gnc:html-table-cell containing the absolute value
+ ;; of the given amount in the report commodity.
+ (define (tot-abs-amt-cell amt)
+ (let* ((neg-amt (gnc:make-commodity-collector))
+ (rv (report-val amt)))
+ (neg-amt 'minusmerge amt #f)
+ (let ((cell (gnc:make-html-table-cell/markup
+ "total-number-cell"
+ (if (negative? (gnc:gnc-monetary-amount rv))
+ (report-val neg-amt)
+ rv))))
+ (gnc:html-table-cell-set-style!
+ cell "total-number-cell"
+ 'attribute '("align" "right")
+ 'attribute '("valign" "top"))
+ cell)))
+
+ ;; sum any unrealized gains
+ ;;
+ ;; Hm... unrealized gains.... This is when you purchase
+ ;; something and its value increases/decreases (prior to
+ ;; your selling it) and you have to reflect that on your
+ ;; balance sheet.
+ ;;
+ ;; I *think* a decrease in the value of a liability or
+ ;; equity constitutes an unrealized loss. I'm unsure about
+ ;; that though....
;;
;; This procedure returns a commodity collector.
(define (collect-unrealized-gains)
- (if (equal? price-source 'average-cost)
+ (if (eq? price-source 'average-cost)
;; No need to calculate if doing valuation at cost.
(gnc:make-commodity-collector)
(let ((book-balance (gnc:make-commodity-collector))
(unrealized-gain-collector (gnc:make-commodity-collector))
- (cost-fn (gnc:case-exchange-fn 'average-cost
- report-commodity
- end-date))
- (value #f)
- (cost #f))
+ (cost-fn (gnc:case-exchange-fn
+ 'average-cost report-commodity end-date)))
;; Calculate book balance.
;; assets - liabilities - equity; normally 0
- (map
+ (for-each
(lambda (acct)
- (book-balance 'merge
- (gnc:account-get-comm-balance-at-date
- acct end-date #f)
- #f))
+ (book-balance
+ 'merge
+ (gnc:account-get-comm-balance-at-date acct end-date #f)
+ #f))
all-accounts)
- ;; Get the value of all holdings.
- (set! value (gnc:gnc-monetary-amount
- (gnc:sum-collector-commodity book-balance
- report-commodity
- exchange-fn)))
-
- ;; Get the cost of all holdings.
- (set! cost (gnc:gnc-monetary-amount
- (gnc:sum-collector-commodity book-balance
- report-commodity
- cost-fn)))
-
- ;; Get the unrealized gain or loss (value minus cost).
- (unrealized-gain-collector 'add
- report-commodity
- (gnc-numeric-sub-fixed value cost))
- unrealized-gain-collector)))
-
-
- ;; set default cell alignment
- (gnc:html-table-set-style!
- build-table "td"
- 'attribute '("align" "right")
- 'attribute '("valign" "top")
- )
-
- (gnc:report-percent-done 4)
+ (let ((value (gnc:gnc-monetary-amount
+ (gnc:sum-collector-commodity
+ book-balance report-commodity exchange-fn)))
+ (cost (gnc:gnc-monetary-amount
+ (gnc:sum-collector-commodity
+ book-balance report-commodity cost-fn))))
+
+ ;; Get the unrealized gain or loss (value minus cost).
+ (unrealized-gain-collector
+ 'add report-commodity (- value cost))
+ unrealized-gain-collector))))
+
+
+ ;; set default cell alignment
+ (gnc:html-table-set-style!
+ build-table "td"
+ 'attribute '("align" "right")
+ 'attribute '("valign" "top"))
+
+ (gnc:report-percent-done 4)
;; Get any unrealized gains/losses.
- (neg-unrealized-gain-collector 'minusmerge
- (collect-unrealized-gains)
- #f)
-
- (set! table-env
- (list
- (list 'start-date #f)
- (list 'end-date end-date)
- (list 'display-tree-depth
- (if (integer? depth-limit) depth-limit #f))
- (list 'depth-limit-behavior 'flatten)
- (list 'report-commodity report-commodity)
- (list 'exchange-fn exchange-fn)
- (list 'parent-account-subtotal-mode #f)
- (list 'zero-balance-mode (if show-zb-accts?
- 'show-leaf-acct
- 'omit-leaf-acct))
- (list 'account-label-mode (if use-links?
- 'anchor
- 'name))
- )
- )
-
- (set! acct-table
- (gnc:make-html-acct-table/env/accts table-env all-accounts))
-
- (gnc:report-percent-done 80)
- (let* ((env (gnc:html-acct-table-get-row-env acct-table 0)))
- (set! account-cols (get-val env 'account-cols))
- )
-
- ;; Workaround to force gtkhtml into displaying wide
- ;; enough columns.
- (let ((space
- (make-list
- (+ account-cols
- (if (equal? report-variant 'work-sheet) 10 2))
- " ")
- ))
- (gnc:html-table-append-row! build-table space)
- (set! header-rows (+ header-rows 1))
- )
- ;; add the double-column headers if required
- (if (equal? report-variant 'work-sheet)
- (let* ((headings
- (list
- (_ "Trial Balance")
- (_ "Adjustments")
- (_ "Adjusted Trial Balance")
- (_ "Income Statement")
- (_ "Balance Sheet")
- ))
- (parent-headings #f)
- )
- (set! parent-headings
- (apply append
- (map
- (lambda (heading)
- (list
- (gnc:make-html-table-cell/size/markup 1 1 "th" heading)
- (gnc:html-make-empty-cell)))
- headings)
- )
- )
- (gnc:html-table-append-row!
- build-table
- (append
+ (neg-unrealized-gain-collector
+ 'minusmerge (collect-unrealized-gains) #f)
+
+ (set! table-env
+ (list
+ (list 'start-date #f)
+ (list 'end-date end-date)
+ (list 'display-tree-depth
+ (and (integer? depth-limit) depth-limit))
+ (list 'depth-limit-behavior 'flatten)
+ (list 'report-commodity report-commodity)
+ (list 'exchange-fn exchange-fn)
+ (list 'parent-account-subtotal-mode #f)
+ (list 'zero-balance-mode (if show-zb-accts? 'show-leaf-acct
+ 'omit-leaf-acct))
+ (list 'account-label-mode (if use-links? 'anchor 'name))))
+
+ (set! acct-table
+ (gnc:make-html-acct-table/env/accts table-env all-accounts))
+
+ (gnc:report-percent-done 80)
+ (let* ((env (gnc:html-acct-table-get-row-env acct-table 0)))
+ (set! account-cols (get-val env 'account-cols)))
+
+ ;; Workaround to force gtkhtml into displaying wide
+ ;; enough columns.
+ (let ((space
+ (make-list
+ (+ account-cols
+ (if (eq? report-variant 'work-sheet) 10 2))
+ " ")))
+ (gnc:html-table-append-row! build-table space)
+ (set! header-rows (+ header-rows 1)))
+ ;; add the double-column headers if required
+ (if (eq? report-variant 'work-sheet)
+ (let* ((headings
+ (list
+ (_ "Trial Balance")
+ (_ "Adjustments")
+ (_ "Adjusted Trial Balance")
+ (_ "Income Statement")
+ (_ "Balance Sheet")))
+ (parent-headings #f))
+ (set! parent-headings
+ (apply append
+ (map
+ (lambda (heading)
+ (list
+ (gnc:make-html-table-cell/size/markup 1 1 "th" heading)
+ (gnc:html-make-empty-cell)))
+ headings)))
+ (gnc:html-table-append-row!
+ build-table
+ (append
(gnc:html-make-empty-cells account-cols)
- parent-headings)
- )
- (set! header-rows (+ header-rows 1))
- )
- )
- ;; add the DEBIT/CREDIT headers
- (let* ((debit-cell
- (gnc:make-html-table-cell/markup
- "th" (_ "Debit")))
- (credit-cell
- (gnc:make-html-table-cell/markup
- "th" (_ "Credit")))
- (row (append
- (list (gnc:make-html-table-cell/markup
- "th" (_ "Account Name")))
- (gnc:html-make-empty-cells (- account-cols 1))
- (list debit-cell)
- (list credit-cell))
- )
- (ws-col 0)
- )
- (if (equal? report-variant 'work-sheet)
- (let ((rownum 0)
- (ws-cols 4)
- )
- (while (< rownum ws-cols)
- (set! row (append row (list debit-cell credit-cell)))
- (set! rownum (+ rownum 1))
- )
- )
- )
- (gnc:html-table-append-row!
- build-table
- row
- )
- (set! header-rows (+ header-rows 1))
- )
-
- ;; now, for each account, calculate all the column values
- ;; and store them in the utility object...
- ;;
- ;; this handles merchandising (inventory and income summary)
- ;; accounts specially. instead of storing a commodity collector,
- ;; it stores a two-element list of commodity collectors:
- ;; (list debit-collector credit-collector)
- (let ((row 0)
- (rows (gnc:html-acct-table-num-rows acct-table))
- )
- (while (< row rows)
- (let* ((env
- (gnc:html-acct-table-get-row-env acct-table row))
- (acct (get-val env 'account))
- (group (list acct))
- (curr-bal (get-val env 'account-bal))
- (closing
- (gnc:account-get-trans-type-balance-interval-with-closing
- group
- (list (list 'str closing-str)
- (list 'cased closing-cased)
- (list 'regexp closing-regexp)
- (list 'closing #t)
- )
- start-date end-date
- ))
- (adjusting
- (gnc:account-get-trans-type-balance-interval-with-closing
- group
- (list (list 'str adjusting-str)
- (list 'cased adjusting-cased)
- (list 'regexp adjusting-regexp)
- )
- start-date end-date
- ))
- (is? (member acct all-is-accounts))
- (ga-or-is? (or (member acct all-ga-accounts) is?))
- (pos-adjusting
- (and ga-or-is?
- adjusting
- (account-get-pos-trans-total-interval
- group
- (list (list 'str adjusting-str)
- (list 'cased adjusting-cased)
- (list 'regexp adjusting-regexp)
- (list 'positive #t)
- )
- start-date end-date
- )
- ))
- (neg-adjusting
- (and pos-adjusting (gnc:make-commodity-collector)))
- (pre-closing-bal (gnc:make-commodity-collector))
- (pre-adjusting-bal (gnc:make-commodity-collector))
- (atb #f) ;; adjusted trial balance
- )
-
- ;; +P_ADJ + -N_ADJ = xADJ. xADJ - +P_ADJ = -N_ADJ.
- ;; That is, credit values are stored as such (negative).
- (if neg-adjusting
- (begin
- (neg-adjusting 'merge adjusting #f)
- (neg-adjusting 'minusmerge pos-adjusting #f)
- ))
-
- (pre-closing-bal 'merge curr-bal #f)
- ;; remove closing entries
- (pre-closing-bal 'minusmerge closing #f)
- (pre-adjusting-bal 'merge pre-closing-bal #f)
- ;; remove closing entries
- (pre-adjusting-bal 'minusmerge adjusting #f)
- ;; we now have a pre-adjusting-bal,
- ;; pre-closing-bal, and curr-bal
-
- (set! atb
- ;; calculate the adjusted trial balance to use
- ;; this depends on whether or not we are netting
- ;; the atb value... so we check is?.
- (if is?
- (let* ((debit (gnc:make-commodity-collector))
- (credit (gnc:make-commodity-collector))
- )
- (debit 'merge pos-adjusting #f)
- (credit 'merge neg-adjusting #f)
- (if (double-col
- 'credit-q pre-adjusting-bal
- report-commodity exchange-fn show-fcur?)
- (credit 'merge pre-adjusting-bal #f)
- (debit 'merge pre-adjusting-bal #f)
- )
- (list debit credit)
- )
- pre-closing-bal)
- )
-
- (gnc:html-acct-table-set-cell!
- acct-table row pa-col pre-adjusting-bal)
- (gnc:html-acct-table-set-cell!
- acct-table row adj-col
- (if ga-or-is?
- (list pos-adjusting neg-adjusting)
- adjusting)
- )
- (gnc:html-acct-table-set-cell!
- acct-table row atb-col atb)
- (gnc:html-acct-table-set-cell!
- acct-table row
- (if (or (gnc:account-is-inc-exp? acct) is?)
- is-col bs-col)
- atb
- )
- (gnc:html-acct-table-set-cell!
- acct-table row bal-col curr-bal)
-
- (set! row (+ row 1))
- )
- )
- )
-
- ;; next, set up the account tree and pre-adjustment balances
- ;; (This fills in the Account Title and Trial Balance columns.)
- (let ((row 0)
- (rows (gnc:html-acct-table-num-rows acct-table)))
- (while (< row rows)
- (let* ((env
- (gnc:html-acct-table-get-row-env acct-table row))
- (account-bal
- (gnc:html-acct-table-get-cell
- acct-table
- row
- (get-val (list (list 'pre-adj pa-col)
- (list 'work-sheet pa-col)
- (list 'current bal-col)
- )
- report-variant)
- ))
- (label (get-val env 'account-label))
- )
- ;; yeah, i know, global vars are devil... so deal with it
- (set! indented-depth (get-val env 'indented-depth))
- (add-line build-table label account-bal)
- )
- (set! row (+ row 1))
- )
- )
-
- ;; handle any unrealized gains
- ;;
- ;; we omit unrealized gains from the balance report, if
- ;; zero, since they are not present on normal trial balances
- (and (not (gnc-commodity-collector-allzero?
- neg-unrealized-gain-collector))
- (let* ((ug-row (+ header-rows
- (gnc:html-acct-table-num-rows acct-table)))
+ parent-headings))
+ (set! header-rows (+ header-rows 1))))
+ ;; add the DEBIT/CREDIT headers
+ (let* ((debit-cell
+ (gnc:make-html-table-cell/markup
+ "th" (_ "Debit")))
+ (credit-cell
+ (gnc:make-html-table-cell/markup
+ "th" (_ "Credit")))
+ (row (append
+ (list (gnc:make-html-table-cell/markup
+ "th" (_ "Account Name")))
+ (gnc:html-make-empty-cells (- account-cols 1))
+ (list debit-cell)
+ (list credit-cell)))
+ (ws-col 0))
+ (if (eq? report-variant 'work-sheet)
+ (let ((rownum 0)
+ (ws-cols 4))
+ (while (< rownum ws-cols)
+ (set! row (append row (list debit-cell credit-cell)))
+ (set! rownum (+ rownum 1)))))
+ (gnc:html-table-append-row! build-table row)
+ (set! header-rows (+ header-rows 1)))
+
+ ;; now, for each account, calculate all the column values
+ ;; and store them in the utility object...
+ ;;
+ ;; this handles merchandising (inventory and income summary)
+ ;; accounts specially. instead of storing a commodity collector,
+ ;; it stores a two-element list of commodity collectors:
+ ;; (list debit-collector credit-collector)
+ (let* ((row 0)
+ (rows (gnc:html-acct-table-num-rows acct-table)))
+
+ (while (< row rows)
+ (let* ((env (gnc:html-acct-table-get-row-env acct-table row))
+ (acct (get-val env 'account))
+ (group (list acct))
+ (curr-bal (get-val env 'account-bal))
+ (closing
+ (gnc:account-get-trans-type-balance-interval-with-closing
+ group
+ (list (list 'str closing-str)
+ (list 'cased closing-cased)
+ (list 'regexp closing-regexp)
+ (list 'closing #t)
+ )
+ start-date end-date
+ ))
+ (adjusting
+ (gnc:account-get-trans-type-balance-interval-with-closing
+ group
+ (list (list 'str adjusting-str)
+ (list 'cased adjusting-cased)
+ (list 'regexp adjusting-regexp)
+ )
+ start-date end-date
+ ))
+ (is? (member acct all-is-accounts))
+ (ga-or-is? (or (member acct all-ga-accounts) is?))
+ (pos-adjusting
+ (and ga-or-is?
+ adjusting
+ (account-get-pos-trans-total-interval
+ group
+ (list (list 'str adjusting-str)
+ (list 'cased adjusting-cased)
+ (list 'regexp adjusting-regexp)
+ (list 'positive #t))
+ start-date end-date)))
+ (neg-adjusting
+ (and pos-adjusting (gnc:make-commodity-collector)))
+ (pre-closing-bal (gnc:make-commodity-collector))
+ (pre-adjusting-bal (gnc:make-commodity-collector))
+ (atb #f))
+
+ ;; +P_ADJ + -N_ADJ = xADJ. xADJ - +P_ADJ = -N_ADJ.
+ ;; That is, credit values are stored as such (negative).
+ (when neg-adjusting
+ (neg-adjusting 'merge adjusting #f)
+ (neg-adjusting 'minusmerge pos-adjusting #f))
+
+ (pre-closing-bal 'merge curr-bal #f)
+ ;; remove closing entries
+ (pre-closing-bal 'minusmerge closing #f)
+ (pre-adjusting-bal 'merge pre-closing-bal #f)
+ ;; remove closing entries
+ (pre-adjusting-bal 'minusmerge adjusting #f)
+ ;; we now have a pre-adjusting-bal,
+ ;; pre-closing-bal, and curr-bal
+
+ (set! atb
+ ;; calculate the adjusted trial balance to use
+ ;; this depends on whether or not we are netting
+ ;; the atb value... so we check is?.
+ (if is?
+ (let* ((debit (gnc:make-commodity-collector))
+ (credit (gnc:make-commodity-collector)))
+ (debit 'merge pos-adjusting #f)
+ (credit 'merge neg-adjusting #f)
+ (if (double-col
+ 'credit-q pre-adjusting-bal
+ report-commodity exchange-fn show-fcur?)
+ (credit 'merge pre-adjusting-bal #f)
+ (debit 'merge pre-adjusting-bal #f))
+ (list debit credit))
+ pre-closing-bal))
+
+ (gnc:html-acct-table-set-cell!
+ acct-table row pa-col pre-adjusting-bal)
+ (gnc:html-acct-table-set-cell!
+ acct-table row adj-col
+ (if ga-or-is?
+ (list pos-adjusting neg-adjusting)
+ adjusting))
+ (gnc:html-acct-table-set-cell! acct-table row atb-col atb)
+ (gnc:html-acct-table-set-cell!
+ acct-table row
+ (if (or (gnc:account-is-inc-exp? acct) is?)
+ is-col bs-col)
+ atb)
+ (gnc:html-acct-table-set-cell! acct-table row bal-col curr-bal)
+
+ (set! row (+ row 1)))))
+
+ ;; next, set up the account tree and pre-adjustment balances
+ ;; (This fills in the Account Title and Trial Balance columns.)
+ (let ((row 0)
+ (rows (gnc:html-acct-table-num-rows acct-table)))
+ (while (< row rows)
+ (let* ((env (gnc:html-acct-table-get-row-env acct-table row))
+ (account-bal
+ (gnc:html-acct-table-get-cell
+ acct-table row
+ (assq-ref (list (cons 'pre-adj pa-col)
+ (cons 'work-sheet pa-col)
+ (cons 'current bal-col))
+ report-variant)))
+ (label (get-val env 'account-label)))
+ ;; yeah, i know, global vars are devil... so deal with it
+ (set! indented-depth (get-val env 'indented-depth))
+ (add-line build-table label account-bal))
+ (set! row (+ row 1))))
+
+ ;; handle any unrealized gains
+ ;;
+ ;; we omit unrealized gains from the balance report, if
+ ;; zero, since they are not present on normal trial balances
+ (and (not (gnc-commodity-collector-allzero?
+ neg-unrealized-gain-collector))
+ (let* ((ug-row (+ header-rows
+ (gnc:html-acct-table-num-rows acct-table)))
(credit? (double-col
'credit-q neg-unrealized-gain-collector
report-commodity exchange-fn show-fcur?))
(entry (double-col
'entry neg-unrealized-gain-collector
- report-commodity exchange-fn show-fcur?))
- )
+ report-commodity exchange-fn show-fcur?)))
(add-line build-table
(if credit?
(_ "Unrealized Gains")
(_ "Unrealized Losses"))
neg-unrealized-gain-collector)
- (if (equal? report-variant 'work-sheet)
- (begin
- ;; make table line wide enough
- (gnc:html-table-set-cell!
- build-table
- ug-row
- (+ account-cols (* 2 bs-col) 1)
- #f)
- (gnc:html-table-set-cell!
- build-table
- ug-row
- (+ account-cols (* 2 atb-col) (if credit? 1 0))
- entry)
- (gnc:html-table-set-cell!
- build-table
- ug-row
- (+ account-cols (* 2 bs-col) (if credit? 1 0))
- entry)
- (if credit?
- (and (atb-credits 'minusmerge
- neg-unrealized-gain-collector #f)
- (bs-credits 'minusmerge
- neg-unrealized-gain-collector #f))
- (and (atb-debits 'merge
- neg-unrealized-gain-collector #f)
- (bs-debits 'merge
- neg-unrealized-gain-collector #f))
- )
- )
- )
- )
- )
-
- ;;
- ;; now, if requested, complete the worksheet
- ;;
- ;; to complete the worksheet, we mostly just have to dink
- ;; around, reading acct-table, putting values in the right
- ;; build-table cells... which is comparatively easy.
- ;;
- (if (equal? report-variant 'work-sheet)
- (let ((row 0)
- (rows (gnc:html-acct-table-num-rows acct-table))
- (last-col #f)
- (html-row #f)
- )
- (while (< row rows)
- (map (lambda (colpair debit-coll credit-coll)
- (set! html-row (+ row header-rows))
- (let* ((bal
- (gnc:html-acct-table-get-cell
- acct-table
- row
- colpair))
- (gross-bal? (list? bal))
- (entry (and bal
- (not gross-bal?)
- (double-col
- 'entry bal
- report-commodity
- exchange-fn
- show-fcur?)))
- (credit? (and bal
- (or gross-bal?
- (double-col
- 'credit-q bal
- report-commodity
- exchange-fn
- show-fcur?)
- )
- ))
- (non-credit? (and bal
- (or gross-bal?
- (not credit?))
- ))
- (debit (or
- (and gross-bal? (car bal))
- (and non-credit? bal)
- ))
- (credit (or
- (and gross-bal? (cadr bal))
- (and credit? bal)
- ))
- (debit-entry
- (and gross-bal?
- (double-col
- 'entry debit
- report-commodity
- exchange-fn
- show-fcur?))
- )
- (credit-entry
- (and gross-bal?
- (double-col
- 'entry credit
- report-commodity
- exchange-fn
- show-fcur?))
- )
- (col (+ account-cols
- (* 2 colpair)
- (if non-credit? 0 1))
- )
- )
- (gnc:html-table-set-cell!
- build-table
- html-row
- col
- (or entry debit-entry)
- )
- (if gross-bal?
- (gnc:html-table-set-cell!
- build-table
- html-row
- (+ col 1)
- credit-entry
- )
- )
- ;; update the corresponding running total
- (and bal
- (begin
- (if credit?
- (credit-coll 'minusmerge
- (if gross-bal?
- credit bal)
- #f)
- )
- (if non-credit?
- (debit-coll 'merge
- (if gross-bal?
- debit bal)
- #f)
- )
- )
- )
- )
- )
- (list adj-col atb-col is-col bs-col)
- (list adj-debits atb-debits
- is-debits bs-debits)
- (list adj-credits atb-credits
- is-credits bs-credits)
- )
- ;; make sure the row extends to the final column
- (set! last-col (+ account-cols (* 2 bs-col) 1))
- (or
- (gnc:html-table-get-cell
- build-table html-row last-col)
- (gnc:html-table-set-cell!
- build-table html-row last-col #f)
- )
- (set! row (+ row 1))
- )
- )
- )
-
- ;; now do the column totals
- (let ()
- (gnc:html-table-append-row/markup!
- build-table "primary-subheading"
- (append
- (list (gnc:make-html-table-cell/markup
- "total-label-cell" #f))
- (gnc:html-make-empty-cells (- account-cols 1))
- (list (tot-abs-amt-cell debit-tot))
- (list (tot-abs-amt-cell credit-tot))
- (if (equal? report-variant 'work-sheet)
- (list
- (tot-abs-amt-cell adj-debits)
- (tot-abs-amt-cell adj-credits)
- (tot-abs-amt-cell atb-debits)
- (tot-abs-amt-cell atb-credits)
- (tot-abs-amt-cell is-debits)
- (tot-abs-amt-cell is-credits)
- (tot-abs-amt-cell bs-debits)
- (tot-abs-amt-cell bs-credits)
- )
- (list)
- )
- )
- )
- )
- (if (equal? report-variant 'work-sheet)
- (let* ((net-is (gnc:make-commodity-collector))
- (net-bs (gnc:make-commodity-collector))
- (tot-is (gnc:make-commodity-collector))
- (tot-bs (gnc:make-commodity-collector))
- (is-entry #f)
- (is-credit? #f)
- (bs-entry #f)
- (bs-credit? #f)
- (tbl-width (+ account-cols (* 2 bs-col) 2))
- (this-row (gnc:html-table-num-rows build-table))
- )
- (net-is 'merge is-debits #f)
- (net-is 'minusmerge is-credits #f)
- (net-bs 'merge bs-debits #f)
- (net-bs 'minusmerge bs-credits #f)
- (set! is-entry
- (double-col
- 'entry net-is report-commodity
- exchange-fn show-fcur?))
- (set! is-credit?
- (double-col
- 'credit-q net-is report-commodity
- exchange-fn show-fcur?))
- (set! bs-entry
- (double-col
- 'entry net-bs report-commodity
- exchange-fn show-fcur?))
- (set! bs-credit?
- (double-col
- 'credit-q net-bs report-commodity
- exchange-fn show-fcur?))
- (gnc:html-table-add-labeled-amount-line!
- build-table tbl-width "primary-subheading" #f
- (if is-credit? (_ "Net Income") (_ "Net Loss"))
- 0 1 "total-label-cell"
- is-entry
- (+ account-cols (* 2 is-col) (if is-credit? 0 1))
- 1 "total-number-cell"
- )
- (gnc:html-table-set-cell!
- build-table
- this-row
- (+ account-cols (* 2 bs-col) (if bs-credit? 0 1))
- (tot-abs-amt-cell net-bs)
- )
- (set! this-row (+ this-row 1))
-
- ;; now slap on the grand totals
- (tot-is 'merge (if is-credit? is-debits is-credits) #f)
- (if is-credit?
- (tot-is 'minusmerge net-is #f)
- (tot-is 'merge net-is #f))
- (tot-bs 'merge (if bs-credit? bs-debits bs-credits) #f)
- (if bs-credit?
- (tot-bs 'minusmerge net-bs #f)
- (tot-bs 'merge net-bs #f))
-
- (gnc:html-table-append-row/markup!
- build-table
- "primary-subheading"
- (append
+ (when (eq? report-variant 'work-sheet)
+ ;; make table line wide enough
+ (gnc:html-table-set-cell!
+ build-table ug-row (+ account-cols (* 2 bs-col) 1) #f)
+ (gnc:html-table-set-cell!
+ build-table ug-row
+ (+ account-cols (* 2 atb-col) (if credit? 1 0)) entry)
+ (gnc:html-table-set-cell!
+ build-table ug-row
+ (+ account-cols (* 2 bs-col) (if credit? 1 0)) entry)
+ (if credit?
+ (and (atb-credits 'minusmerge neg-unrealized-gain-collector #f)
+ (bs-credits 'minusmerge neg-unrealized-gain-collector #f))
+ (and (atb-debits 'merge neg-unrealized-gain-collector #f)
+ (bs-debits 'merge neg-unrealized-gain-collector #f))))))
+
+ ;;
+ ;; now, if requested, complete the worksheet
+ ;;
+ ;; to complete the worksheet, we mostly just have to dink
+ ;; around, reading acct-table, putting values in the right
+ ;; build-table cells... which is comparatively easy.
+ ;;
+ (if (eq? report-variant 'work-sheet)
+ (let ((row 0)
+ (rows (gnc:html-acct-table-num-rows acct-table))
+ (last-col #f)
+ (html-row #f))
+ (while (< row rows)
+ (for-each
+ (lambda (colpair debit-coll credit-coll)
+ (set! html-row (+ row header-rows))
+ (let* ((bal (gnc:html-acct-table-get-cell acct-table row colpair))
+ (gross-bal? (list? bal))
+ (entry (and bal
+ (not gross-bal?)
+ (double-col
+ 'entry bal report-commodity
+ exchange-fn show-fcur?)))
+ (credit? (and bal
+ (or gross-bal?
+ (double-col
+ 'credit-q bal report-commodity
+ exchange-fn show-fcur?))))
+ (non-credit? (and bal (or gross-bal? (not credit?))))
+ (debit (or (and gross-bal? (car bal))
+ (and non-credit? bal)))
+ (credit (or (and gross-bal? (cadr bal))
+ (and credit? bal)))
+ (debit-entry
+ (and gross-bal?
+ (double-col 'entry debit report-commodity
+ exchange-fn show-fcur?)))
+ (credit-entry
+ (and gross-bal?
+ (double-col 'entry credit report-commodity
+ exchange-fn show-fcur?)))
+ (col (+ account-cols
+ (* 2 colpair)
+ (if non-credit? 0 1))))
+ (gnc:html-table-set-cell!
+ build-table html-row col (or entry debit-entry))
+ (if gross-bal?
+ (gnc:html-table-set-cell! build-table html-row
+ (+ col 1) credit-entry))
+ ;; update the corresponding running total
+ (when bal
+ (when credit?
+ (credit-coll 'minusmerge (if gross-bal? credit bal) #f))
+ (when non-credit?
+ (debit-coll 'merge (if gross-bal? debit bal) #f)))))
+ (list adj-col atb-col is-col bs-col)
+ (list adj-debits atb-debits is-debits bs-debits)
+ (list adj-credits atb-credits is-credits bs-credits))
+ ;; make sure the row extends to the final column
+ (set! last-col (+ account-cols (* 2 bs-col) 1))
+ (or (gnc:html-table-get-cell build-table html-row last-col)
+ (gnc:html-table-set-cell! build-table html-row last-col #f))
+ (set! row (+ row 1)))))
+
+ ;; now do the column totals
+ (gnc:html-table-append-row/markup!
+ build-table "primary-subheading"
+ (append
+ (list (gnc:make-html-table-cell/markup "total-label-cell" #f))
+ (gnc:html-make-empty-cells (- account-cols 1))
+ (list (tot-abs-amt-cell debit-tot))
+ (list (tot-abs-amt-cell credit-tot))
+ (if (eq? report-variant 'work-sheet)
+ (list
+ (tot-abs-amt-cell adj-debits)
+ (tot-abs-amt-cell adj-credits)
+ (tot-abs-amt-cell atb-debits)
+ (tot-abs-amt-cell atb-credits)
+ (tot-abs-amt-cell is-debits)
+ (tot-abs-amt-cell is-credits)
+ (tot-abs-amt-cell bs-debits)
+ (tot-abs-amt-cell bs-credits))
+ '())))
+ (if (eq? report-variant 'work-sheet)
+ (let* ((net-is (gnc:make-commodity-collector))
+ (net-bs (gnc:make-commodity-collector))
+ (tot-is (gnc:make-commodity-collector))
+ (tot-bs (gnc:make-commodity-collector))
+ (is-entry #f)
+ (is-credit? #f)
+ (bs-entry #f)
+ (bs-credit? #f)
+ (tbl-width (+ account-cols (* 2 bs-col) 2))
+ (this-row (gnc:html-table-num-rows build-table)))
+ (net-is 'merge is-debits #f)
+ (net-is 'minusmerge is-credits #f)
+ (net-bs 'merge bs-debits #f)
+ (net-bs 'minusmerge bs-credits #f)
+ (set! is-entry
+ (double-col 'entry net-is report-commodity exchange-fn show-fcur?))
+ (set! is-credit?
+ (double-col 'credit-q net-is report-commodity
+ exchange-fn show-fcur?))
+ (set! bs-entry
+ (double-col 'entry net-bs report-commodity
+ exchange-fn show-fcur?))
+ (set! bs-credit?
+ (double-col 'credit-q net-bs report-commodity
+ exchange-fn show-fcur?))
+ (gnc:html-table-add-labeled-amount-line!
+ build-table tbl-width "primary-subheading" #f
+ (if is-credit? (_ "Net Income") (_ "Net Loss"))
+ 0 1 "total-label-cell" is-entry
+ (+ account-cols (* 2 is-col) (if is-credit? 0 1))
+ 1 "total-number-cell")
+ (gnc:html-table-set-cell!
+ build-table this-row
+ (+ account-cols (* 2 bs-col) (if bs-credit? 0 1))
+ (tot-abs-amt-cell net-bs))
+ (set! this-row (+ this-row 1))
+
+ ;; now slap on the grand totals
+ (tot-is 'merge (if is-credit? is-debits is-credits) #f)
+ (if is-credit?
+ (tot-is 'minusmerge net-is #f)
+ (tot-is 'merge net-is #f))
+ (tot-bs 'merge (if bs-credit? bs-debits bs-credits) #f)
+ (if bs-credit?
+ (tot-bs 'minusmerge net-bs #f)
+ (tot-bs 'merge net-bs #f))
+
+ (gnc:html-table-append-row/markup!
+ build-table "primary-subheading"
+ (append
(gnc:html-make-empty-cells (+ account-cols (* 2 is-col)))
- (list
- (tot-abs-amt-cell (if is-credit? tot-is is-debits))
- (tot-abs-amt-cell (if is-credit? is-credits tot-is))
- (tot-abs-amt-cell (if bs-credit? tot-bs bs-debits))
- (tot-abs-amt-cell (if bs-credit? bs-credits tot-bs))
- )
- )
- )
- )
- )
-
- ;; ...and that's a complete trial balance/work sheet
-
- (gnc:html-document-add-object! doc build-table)
-
+ (list (tot-abs-amt-cell (if is-credit? tot-is is-debits))
+ (tot-abs-amt-cell (if is-credit? is-credits tot-is))
+ (tot-abs-amt-cell (if bs-credit? tot-bs bs-debits))
+ (tot-abs-amt-cell (if bs-credit? bs-credits tot-bs)))))))
+
+ ;; ...and that's a complete trial balance/work sheet
+ (gnc:html-document-add-object! doc build-table)
+
;; add currency information if requested
- (gnc:report-percent-done 90)
+ (gnc:report-percent-done 90)
(if show-rates?
- (gnc:html-document-add-object!
+ (gnc:html-document-add-object!
doc
- (gnc:html-make-exchangerates
+ (gnc:html-make-exchangerates
report-commodity exchange-fn accounts)))
- (gnc:report-percent-done 100)
-
- ;; if sending the report to a file, do so now
- (if filename
- (let* ((port (open-output-file filename)))
- (gnc:display-report-list-item
- (list doc) port " trial-balance.scm ")
- (close-output-port port)))))
-
+ (gnc:report-percent-done 100)))
+
(gnc:report-finished)
-
+
doc))
-(gnc:define-report
+(gnc:define-report
'version 1
'name reportname
'report-guid "216cd0cf6931453ebcce85415aba7082"
'menu-path (list gnc:menuname-income-expense)
'options-generator trial-balance-options-generator
- 'renderer (lambda (report-obj)
- (trial-balance-renderer report-obj #f #f))
- 'export-types #f
- 'export-thunk (lambda (report-obj choice filename)
- (trial-balance-renderer report-obj #f filename)))
+ 'renderer trial-balance-renderer)
;; END
Summary of changes:
gnucash/report/standard-reports/trial-balance.scm | 1490 +++++++++------------
1 file changed, 611 insertions(+), 879 deletions(-)
More information about the gnucash-changes
mailing list