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

Merge branch 'maint'

Browse Source
This commit is contained in:
Christopher Lam 2019-12-02 23:38:15 +08:00
commit 948a5f4588
23 changed files with 806 additions and 750 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
bindings/python/example_scripts/account_analysis.py
View File

@ -38,7 +38,7 @@ import csv
from gnucash import Session, GncNumeric, Split from gnucash import Session, GncNumeric, Split
# Invoke this script like the following example # Invoke this script like the following example
# $ gnucash-env python account_analysis.py gnucash_file.gnucash \ # $ python3 account_analysis.py gnucash_file.gnucash \
# 2010 1 monthly 12 \ # 2010 1 monthly 12 \
# debits-show credits-show Assets 'Test Account' # debits-show credits-show Assets 'Test Account'
# #
@ -156,9 +156,9 @@ def main():
print('usage: account_analysis.py {book url} {start year} {start month, numeric} {period type: monthly, quarterly, or yearly} {number of periods to show, from start year and month} {whether to show debits: debits-show for true, all other values false} {whether to show credits: credits-show for true, all other values false} {space separated account path, as many nested levels as desired} ') print('usage: account_analysis.py {book url} {start year} {start month, numeric} {period type: monthly, quarterly, or yearly} {number of periods to show, from start year and month} {whether to show debits: debits-show for true, all other values false} {whether to show credits: credits-show for true, all other values false} {space separated account path, as many nested levels as desired} ')
print('examples:\n') print('examples:\n')
print("The following example analyzes 12 months of 'Assets:Test Account' from /home/username/test.gnucash, starting in January of 2010, and shows both credits and debits") print("The following example analyzes 12 months of 'Assets:Test Account' from /home/username/test.gnucash, starting in January of 2010, and shows both credits and debits")
print("gnucash-env python account_analysis.py '/home/username/test.gnucash' 2010 1 monthly 12 debits-show credits-show Assets 'Test Account'\n") print("python3 account_analysis.py '/home/username/test.gnucash' 2010 1 monthly 12 debits-show credits-show Assets 'Test Account'\n")
print("The following example analyzes 2 quarters of 'Liabilities:First Level:Second Level' from /home/username/test.gnucash, starting March 2011, and shows credits but not debits") print("The following example analyzes 2 quarters of 'Liabilities:First Level:Second Level' from /home/username/test.gnucash, starting March 2011, and shows credits but not debits")
print("gnucash-env python account_analysis.py '/home/username/test.gnucash' 2011 3 quarterly 2 debits-noshow credits-show Liabilities 'First Level' 'Second Level") print("python3 account_analysis.py '/home/username/test.gnucash' 2011 3 quarterly 2 debits-noshow credits-show Liabilities 'First Level' 'Second Level")
return return
try: try:

8
bindings/python/example_scripts/new_book_with_opening_balances.py
View File

@ -51,11 +51,11 @@ from datetime import date
# mutual, and trading, you'll have to put the opening balance in yourself # mutual, and trading, you'll have to put the opening balance in yourself
# #
# Invocation examples: # Invocation examples:
# gnucash-env python new_book_with_opening_balances.py \ # python3 new_book_with_opening_balances.py \
# '/home/mark/test.gnucash' # '/home/mark/test.gnucash'
# 'sqlite3:///home/mark/new_test.gnucash' # 'sqlite3:///home/mark/new_test.gnucash'
# #
# gnucash-env python new_book_with_opening_balances.py \ # python3 new_book_with_opening_balances.py \
# '/home/mark/test.gnucash' \ # '/home/mark/test.gnucash' \
# 'xml:///crypthome/mark/parit-financial-system/new_test.gnucash' # 'xml:///crypthome/mark/parit-financial-system/new_test.gnucash'
# #
@ -293,8 +293,8 @@ def main():
print('not enough parameters') print('not enough parameters')
print('usage: new_book_with_opening_balances.py {source_book_url} {destination_book_url}') print('usage: new_book_with_opening_balances.py {source_book_url} {destination_book_url}')
print('examples:') print('examples:')
print("gnucash-env python new_book_with_opening_balances.py '/home/username/test.gnucash' 'sqlite3:///home/username/new_test.gnucash'") print("python3 new_book_with_opening_balances.py '/home/username/test.gnucash' 'sqlite3:///home/username/new_test.gnucash'")
print("gnucash-env python new_book_with_opening_balances.py '/home/username/test.gnucash' 'xml:///crypthome/username/finances/new_test.gnucash'") print("python3 new_book_with_opening_balances.py '/home/username/test.gnucash' 'xml:///crypthome/username/finances/new_test.gnucash'")
return return
#have everything in a try block to unable us to release our hold on stuff to the extent possible #have everything in a try block to unable us to release our hold on stuff to the extent possible

5
bindings/python/example_scripts/priceDB_test.py
View File

@ -5,8 +5,9 @@
# before running this. # before running this.
# Adding to a calling bash script would be better # Adding to a calling bash script would be better
# Although calling it from here would be even better! # Although calling it from here would be even better!
# OR: export PYTHONPATH=$HOME/progs/lib/python2.6/site-packages # OR: export PYTHONPATH=<path-to-gnucash-inst-dir>/lib/python3.7/site-packages:$PYTHONPATH
# Then: gnucash-env ipython # You may have to adjust the above path to your local system (lib->lib64, python3.7->...)
# Then: ipython3
# The account file is not saved but always use a disposable copy. # The account file is not saved but always use a disposable copy.
# Change, FILE, CURRENCY and STOCK to those defined in your test account. # Change, FILE, CURRENCY and STOCK to those defined in your test account.

5
bindings/python/example_scripts/price_database_example.py
View File

@ -5,8 +5,9 @@
# before running this. # before running this.
# Adding to a calling bash script would be better # Adding to a calling bash script would be better
# Although calling it from here would be even better! # Although calling it from here would be even better!
# OR: export PYTHONPATH=$HOME/progs/lib/python2.6/site-packages # OR: export PYTHONPATH=<path-to-gnucash-inst-dir>/lib/python3.7/site-packages:$PYTHONPATH
# Then: gnucash-env ipython # You may have to adjust the above path to your local system (lib->lib64, python3.7->...)
# Then: ipython3
# The account file is not saved but always use a disposable copy. # The account file is not saved but always use a disposable copy.
# Thanks for contributions by Christoph Holtermann and Mark Jenkins # Thanks for contributions by Christoph Holtermann and Mark Jenkins

16
bindings/python/example_scripts/rest-api/gnucash_simple.py
View File

@ -34,14 +34,14 @@ def addressToDict(address):
return None return None
else: else:
simple_address = {} simple_address = {}
simple_address['name'] = address.GetName(); simple_address['name'] = address.GetName()
simple_address['line_1'] = address.GetAddr1(); simple_address['line_1'] = address.GetAddr1()
simple_address['line_2'] = address.GetAddr2(); simple_address['line_2'] = address.GetAddr2()
simple_address['line_3'] = address.GetAddr3(); simple_address['line_3'] = address.GetAddr3()
simple_address['line_4'] = address.GetAddr4(); simple_address['line_4'] = address.GetAddr4()
simple_address['phone'] = address.GetPhone(); simple_address['phone'] = address.GetPhone()
simple_address['fax'] = address.GetFax(); simple_address['fax'] = address.GetFax()
simple_address['email'] = address.GetEmail(); simple_address['email'] = address.GetEmail()
return simple_address return simple_address

4
bindings/python/example_scripts/simple_business_create.py
View File

@ -24,7 +24,7 @@
# Creates a new book file (or *overwrites* an existing one) that has elements # Creates a new book file (or *overwrites* an existing one) that has elements
# in it for business use -- intended as a demonstration program. # in it for business use -- intended as a demonstration program.
# Syntax: # Syntax:
# gnucash-env python simple_business_create.py \ # python3 simple_business_create.py \
# sqlite3:///home/blah/blah.gnucash # sqlite3:///home/blah/blah.gnucash
# #
# Specifically, this sets up a simple tree, creates a customer, job, # Specifically, this sets up a simple tree, creates a customer, job,
@ -65,7 +65,7 @@ if len(argv) < 2:
print('not enough parameters') print('not enough parameters')
print('usage: simple_business_create.py {new_book_url}') print('usage: simple_business_create.py {new_book_url}')
print('example:') print('example:')
print("gnucash-env python simple_business_create.py sqlite3:///home/blah/blah.gnucash") print("python3 simple_business_create.py sqlite3:///home/blah/blah.gnucash")
exit() exit()

2
bindings/python/example_scripts/simple_invoice_insert.py
View File

@ -30,7 +30,7 @@
# this to become an invoice importer for your own books # this to become an invoice importer for your own books
# #
# Syntax: # Syntax:
# gnucash-env python simple_invoice_insert.py \ # python3 simple_invoice_insert.py \
# /home/blah/blah.gnucash # /home/blah/blah.gnucash
# dda2ec8e3e63c7715097f852851d6b22 1001 'The Goods' 201.43 # dda2ec8e3e63c7715097f852851d6b22 1001 'The Goods' 201.43
# #

2
bindings/python/example_scripts/test_imbalance_transaction.py
View File

@ -45,7 +45,7 @@ if len(argv) < 2:
print('not enough parameters') print('not enough parameters')
print('usage: test_imbalance_transaction.py {book_url}') print('usage: test_imbalance_transaction.py {book_url}')
print('examples:') print('examples:')
print("gnucash-env python test_imbalance_transaction.py '/home/username/test.gnucash'") print("python3 test_imbalance_transaction.py '/home/username/test.gnucash'")
exit() exit()

6
bindings/python/gnucash_core.py
View File

@ -619,7 +619,7 @@ methods_return_instance(GncLot, gnclot_dict)
# Transaction # Transaction
Transaction.add_methods_with_prefix('xaccTrans') Transaction.add_methods_with_prefix('xaccTrans')
Transaction.add_method('gncTransGetGUID', 'GetGUID'); Transaction.add_method('gncTransGetGUID', 'GetGUID')
Transaction.add_method('xaccTransGetDescription', 'GetDescription') Transaction.add_method('xaccTransGetDescription', 'GetDescription')
Transaction.add_method('xaccTransDestroy', 'Destroy') Transaction.add_method('xaccTransDestroy', 'Destroy')
@ -648,7 +648,7 @@ Transaction.decorate_functions(
# Split # Split
Split.add_methods_with_prefix('xaccSplit') Split.add_methods_with_prefix('xaccSplit')
Split.add_method('gncSplitGetGUID', 'GetGUID'); Split.add_method('gncSplitGetGUID', 'GetGUID')
Split.add_method('xaccSplitDestroy', 'Destroy') Split.add_method('xaccSplitDestroy', 'Destroy')
split_dict = { split_dict = {
@ -677,7 +677,7 @@ Split.parent = property( Split.GetParent, Split.SetParent )
# Account # Account
Account.add_methods_with_prefix('xaccAccount') Account.add_methods_with_prefix('xaccAccount')
Account.add_methods_with_prefix('gnc_account_') Account.add_methods_with_prefix('gnc_account_')
Account.add_method('gncAccountGetGUID', 'GetGUID'); Account.add_method('gncAccountGetGUID', 'GetGUID')
Account.add_method('xaccAccountGetPlaceholder', 'GetPlaceholder') Account.add_method('xaccAccountGetPlaceholder', 'GetPlaceholder')
account_dict = { account_dict = {

3
gnucash/import-export/import-account-matcher.c
View File

@ -86,7 +86,8 @@ static gpointer test_acct_online_id_match(Account *acct, gpointer param_online_i
const gchar * current_online_id = gnc_import_get_acc_online_id(acct); const gchar * current_online_id = gnc_import_get_acc_online_id(acct);
if ( (current_online_id != NULL if ( (current_online_id != NULL
&& param_online_id != NULL ) && param_online_id != NULL )
&& strcmp( current_online_id, param_online_id ) == 0 ) && strncmp( current_online_id, param_online_id,
strlen( current_online_id ) ) == 0 )
{ {
return (gpointer *) acct; return (gpointer *) acct;
} }

245
gnucash/report/html-acct-table.scm
View File

@ -610,7 +610,6 @@
) )
;; the following function was adapted from html-utilities.scm ;; the following function was adapted from html-utilities.scm
;;
;; helper to calculate the balances for all required accounts ;; helper to calculate the balances for all required accounts
(define (calculate-balances accts start-date end-date get-balance-fn) (define (calculate-balances accts start-date end-date get-balance-fn)
@ -667,7 +666,6 @@
(define (traverse-accounts! accts acct-depth logi-depth new-balances) (define (traverse-accounts! accts acct-depth logi-depth new-balances)
(define (use-acct? acct) (define (use-acct? acct)
;; BUG? when depth-limit is not integer but boolean?
(and (or (eq? limit-behavior 'flatten) (and (or (eq? limit-behavior 'flatten)
(< logi-depth depth-limit)) (< logi-depth depth-limit))
(member acct accounts))) (member acct accounts)))
@ -692,215 +690,149 @@
(gnc:accounts-and-all-descendants (list account))) (gnc:accounts-and-all-descendants (list account)))
this-collector)) this-collector))
(let ((disp-depth (if (integer? depth-limit) (let lp ((accounts (if less-p (sort accts less-p) accts))
(min (- depth-limit 1) logi-depth) (row-added? #f)
logi-depth)) (disp-depth (if (integer? depth-limit)
(row-added? #f)) (min (1- depth-limit) logi-depth)
logi-depth)))
(cond
((null? accounts) row-added?)
(else
(let* ((acct (car accounts))
(subaccts (gnc-account-get-children-sorted acct))
(for-each
(lambda (acct)
(let* ((subaccts (gnc-account-get-children-sorted acct))
;; assign output parameters
(account acct)
(account-name (xaccAccountGetName acct))
(account-code (xaccAccountGetCode acct))
(account-path (gnc-account-get-full-name acct))
(account-anchor (gnc:html-account-anchor acct))
(account-parent (gnc-account-get-parent acct))
(account-children subaccts)
(account-depth acct-depth)
(logical-depth logi-depth)
(account-commodity (xaccAccountGetCommodity acct))
(account-type (xaccAccountGetType acct))
;; N.B.: xaccAccountGetTypeStr really should be
;; called gnc:account-type-get-string
(account-type-string (xaccAccountGetTypeStr
(xaccAccountGetType acct)))
(account-guid (gncAccountGetGUID acct))
(account-description (xaccAccountGetDescription acct))
(account-notes (xaccAccountGetNotes acct))
;; These next two are commodity-collectors. ;; These next two are commodity-collectors.
(account-bal (get-balance (account-bal (get-balance new-balances acct))
new-balances acct)) (recursive-bal (get-balance-sub new-balances acct))
(recursive-bal (get-balance-sub
new-balances acct)) ;; These next two are of type <gnc:monetary>
;; These next two are of type <gnc:monetary>, right?
(report-comm-account-bal (report-comm-account-bal
(gnc:sum-collector-commodity (gnc:sum-collector-commodity
account-bal report-commodity exchange-fn)) account-bal report-commodity exchange-fn))
(report-comm-recursive-bal (report-comm-recursive-bal
(gnc:sum-collector-commodity (gnc:sum-collector-commodity
recursive-bal report-commodity exchange-fn)) recursive-bal report-commodity exchange-fn))
(grp-env (grp-env
(append env (cons*
(list
(list 'initial-indent indent) (list 'initial-indent indent)
(list 'account account) (list 'account acct)
(list 'account-name account-name) (list 'account-name (xaccAccountGetName acct))
(list 'account-code account-code) (list 'account-code (xaccAccountGetCode acct))
(list 'account-type account-type) (list 'account-type (xaccAccountGetType acct))
(list 'account-type-string account-type-string) (list 'account-type-string (xaccAccountGetTypeStr
(list 'account-guid account-guid) (xaccAccountGetType acct)))
(list 'account-description account-description) (list 'account-guid (gncAccountGetGUID acct))
(list 'account-notes account-notes) (list 'account-description (xaccAccountGetDescription acct))
(list 'account-path account-path) (list 'account-notes (xaccAccountGetNotes acct))
(list 'account-parent account-parent) (list 'account-path (gnc-account-get-full-name acct))
(list 'account-children account-children) (list 'account-parent (gnc-account-get-parent acct))
(list 'account-depth account-depth) (list 'account-children subaccts)
(list 'logical-depth logical-depth) (list 'account-depth acct-depth)
(list 'account-commodity account-commodity) (list 'logical-depth logi-depth)
(list 'account-anchor account-anchor) (list 'account-commodity (xaccAccountGetCommodity acct))
(list 'account-anchor (gnc:html-account-anchor acct))
(list 'account-bal account-bal) (list 'account-bal account-bal)
(list 'recursive-bal recursive-bal) (list 'recursive-bal recursive-bal)
(list 'report-comm-account-bal (list 'report-comm-account-bal report-comm-account-bal)
report-comm-account-bal) (list 'report-comm-recursive-bal report-comm-recursive-bal)
(list 'report-comm-recursive-bal
report-comm-recursive-bal)
(list 'report-commodity report-commodity) (list 'report-commodity report-commodity)
(list 'exchange-fn exchange-fn) (list 'exchange-fn exchange-fn)
))) env))
(row-env #f)
(label (case label-mode (label (case label-mode
((anchor) account-anchor) ((anchor) (gnc:html-account-anchor acct))
((name) (gnc:make-html-text account-name)))) ((name) (gnc:make-html-text (xaccAccountGetName acct)))))
(row #f) (row #f)
(children-displayed? #f) (children-displayed? #f))
)
(set! acct-depth-reached (max acct-depth-reached acct-depth)) (set! acct-depth-reached (max acct-depth-reached acct-depth))
(set! logi-depth-reached (max logi-depth-reached logi-depth)) (set! logi-depth-reached (max logi-depth-reached logi-depth))
(set! disp-depth-reached (max disp-depth-reached disp-depth)) (set! disp-depth-reached (max disp-depth-reached disp-depth))
(or (not (use-acct? acct)) (unless (or (not (use-acct? acct))
;; ok, so we'll consider parent accounts with zero ;; ok, so we'll consider parent accounts with zero
;; recursive-bal to be zero balance leaf accounts ;; recursive-bal to be zero balance leaf accounts
(and (gnc-commodity-collector-allzero? recursive-bal) (and (gnc-commodity-collector-allzero? recursive-bal)
(eq? zero-mode 'omit-leaf-acct)
(or (not report-budget) (or (not report-budget)
(gnc-numeric-zero-p (zero? (gnc:budget-account-get-rolledup-net
(gnc:budget-account-get-rolledup-net report-budget acct #f #f)))))
report-budget account #f #f))) (set! row
(equal? zero-mode 'omit-leaf-acct)) (add-row
(begin (cons* (list 'account-label label)
(set! row-env
(append grp-env
(list
(list 'account-label label)
(list 'row-type 'account-row) (list 'row-type 'account-row)
(list 'display-depth disp-depth) (list 'display-depth disp-depth)
(list 'indented-depth (list 'indented-depth (+ disp-depth indent))
(+ disp-depth indent)) grp-env))))
)
))
(set! row (add-row row-env))
)
)
;; Recurse: ;; Recurse:
;; Dive into an account even if it isn't selected! ;; Dive into an account even if it isn't selected!
;; why? because some subaccts may be selected. ;; why? because some subaccts may be selected.
(set! children-displayed? (set! children-displayed?
(traverse-accounts! subaccts (traverse-accounts! subaccts
(+ acct-depth 1) (1+ acct-depth)
(if (use-acct? acct) (if (use-acct? acct)
(+ logi-depth 1) (1+ logi-depth)
logi-depth) logi-depth)
new-balances)) new-balances))
;; record whether any children were displayed ;; record whether any children were displayed
(if row (append-to-row row (list (list 'children-displayed? children-displayed?)))) (when row
(append-to-row
row (list (list 'children-displayed? children-displayed?))))
;; after the return from recursion: subtotals ;; after the return from recursion: subtotals
(or (not (use-acct? acct)) (unless (or (not (use-acct? acct))
(not subtotal-mode) (not subtotal-mode)
;; ditto that remark concerning zero recursive-bal...
(and (gnc-commodity-collector-allzero? recursive-bal)
(equal? zero-mode 'omit-leaf-acct))
;; ignore use-acct for subtotals...?
;; (not (use-acct? acct))
(not children-displayed?) (not children-displayed?)
(let* ((lbl-txt (gnc:make-html-text (_ "Total") " "))) (and (gnc-commodity-collector-allzero? recursive-bal)
(apply gnc:html-text-append! lbl-txt (eq? zero-mode 'omit-leaf-acct)))
(gnc:html-text-body label)) (let ((lbl-txt (gnc:make-html-text (_ "Total") " ")))
(if (equal? subtotal-mode 'canonically-tabbed) (apply gnc:html-text-append! lbl-txt (gnc:html-text-body label))
(if (eq? subtotal-mode 'canonically-tabbed)
(set! disp-depth (+ disp-depth 1)) (set! disp-depth (+ disp-depth 1))
(set! disp-depth-reached (set! disp-depth-reached (max disp-depth-reached disp-depth)))
(max disp-depth-reached disp-depth)) (add-row
) (cons* (list 'account-label lbl-txt)
(set! row-env
(append grp-env
(list
(list 'account-label lbl-txt)
(list 'row-type 'subtotal-row) (list 'row-type 'subtotal-row)
(list 'display-depth disp-depth) (list 'display-depth disp-depth)
(list 'indented-depth (list 'indented-depth (+ disp-depth indent))
(+ disp-depth indent)) grp-env))))
)
)) (lp (cdr accounts)
(add-row row-env) (or row-added? children-displayed? row)
) disp-depth))))))
)
(if (or row-added? children-displayed? row) (set! row-added? #t))
)) ;; end of (lambda (acct) ...)
;; lambda is applied to each item in the (sorted) account list
(if less-p
(sort accts less-p)
accts)
) ;; end of for-each
row-added?
)
) ;; end of definition of traverse-accounts!
;; do it ;; do it
(traverse-accounts! toplvl-accts 0 0 (traverse-accounts!
toplvl-accts 0 0
(calculate-balances accounts start-date end-date get-balance-fn)) (calculate-balances accounts start-date end-date get-balance-fn))
;; now set the account-colspan entries ;; now set the account-colspan entries
;; he he... (let ((x 0)) (while (< x 5) (display x) (set! x (+ x 1)))) (let lp ((row 0)
;; now I know how to loop in scheme... yay!
(let ((row 0)
(rows (gnc:html-acct-table-num-rows acct-table))) (rows (gnc:html-acct-table-num-rows acct-table)))
(while (< row rows) (when (< row rows)
(let* ((orig-env (let* ((orig-env (gnc:html-acct-table-get-row-env acct-table row))
(gnc:html-acct-table-get-row-env acct-table row))
(display-depth (get-val orig-env 'display-depth)) (display-depth (get-val orig-env 'display-depth))
(depth-limit (get-val orig-env 'display-tree-depth)) (depth-limit (get-val orig-env 'display-tree-depth))
(indent (get-val orig-env 'initial-indent)) (indent (get-val orig-env 'initial-indent))
(indented-depth (get-val orig-env 'indented-depth)) (indented-depth (get-val orig-env 'indented-depth))
(subtotal-mode (subtotal-mode (get-val orig-env 'parent-account-subtotal-mode))
(get-val orig-env 'parent-account-subtotal-mode))
(label-cols (+ disp-depth-reached 1)) (label-cols (+ disp-depth-reached 1))
(logical-cols (if depth-limit
(min
(+ logi-depth-reached 1)
;; BUG? when depth-limit is not integer?
depth-limit)
(+ logi-depth-reached 1)))
(colspan (- label-cols display-depth))
;; these parameters *should* always, by now, be set... ;; these parameters *should* always, by now, be set...
(new-env (new-env
(append (cons*
orig-env (list 'account-colspan (- label-cols display-depth))
(list
(list 'account-colspan colspan)
(list 'label-cols label-cols) (list 'label-cols label-cols)
(list 'logical-cols logical-cols) (list 'account-cols (+ indent (max label-cols (or depth-limit 0))))
(list 'account-cols (list 'logical-cols (min (+ logi-depth-reached)
(+ indent (or depth-limit +inf.0)))
(max label-cols orig-env)))
(if depth-limit depth-limit 0)
)
)
)
)
))
)
(gnc:html-acct-table-set-row-env! acct-table row new-env) (gnc:html-acct-table-set-row-env! acct-table row new-env)
(set! row (+ row 1)))) (lp (1+ row) rows))))))
)
;; done
)
)
(define (gnc:html-acct-table-num-rows acct-table) (define (gnc:html-acct-table-num-rows acct-table)
(gnc:html-table-num-rows (gnc:_html-acct-table-matrix_ acct-table))) (gnc:html-table-num-rows (gnc:_html-acct-table-matrix_ acct-table)))
@ -908,12 +840,9 @@
(define (gnc:html-acct-table-get-cell acct-table row col) (define (gnc:html-acct-table-get-cell acct-table row col)
;; we'll only ever store one object in an html-table-cell ;; we'll only ever store one object in an html-table-cell
;; returns the first object stored in that cell ;; returns the first object stored in that cell
(let* ((cell (gnc:html-table-get-cell (and-let* ((cell (gnc:html-table-get-cell
(gnc:_html-acct-table-matrix_ acct-table) (gnc:_html-acct-table-matrix_ acct-table) row (1+ col))))
row (+ col 1)))) (car (gnc:html-table-cell-data cell))))
(and cell (car (gnc:html-table-cell-data cell)))
)
)
(define (gnc:html-acct-table-set-cell! acct-table row col obj) (define (gnc:html-acct-table-set-cell! acct-table row col obj)
(gnc:html-table-set-cell! (gnc:html-table-set-cell!

3
gnucash/report/html-text.scm
View File

@ -182,6 +182,9 @@
(gnc:html-markup "li" obj)) (gnc:html-markup "li" obj))
items))) items)))
(define (gnc:html-markup-ol lst)
(apply gnc:html-markup "ol"
(map (lambda (elt) (gnc:html-markup "li" elt)) lst)))
(define (gnc:html-markup-anchor href . rest) (define (gnc:html-markup-anchor href . rest)
(apply gnc:html-markup/attr (apply gnc:html-markup/attr

34
gnucash/report/html-utilities.scm
View File

@ -91,29 +91,17 @@
(define (gnc:owner-report-text owner acc) (define (gnc:owner-report-text owner acc)
(let* ((end-owner (gncOwnerGetEndOwner owner)) (let* ((end-owner (gncOwnerGetEndOwner owner))
(type (gncOwnerGetType end-owner)) (type (gncOwnerGetType end-owner)))
(ref #f)) (gnc-build-url
URL-TYPE-OWNERREPORT
(cond (string-append
((eqv? type GNC-OWNER-CUSTOMER) (cond ((eqv? type GNC-OWNER-CUSTOMER) "owner=c:")
(set! ref "owner=c:")) ((eqv? type GNC-OWNER-VENDOR) "owner=v:")
((eqv? type GNC-OWNER-EMPLOYEE) "owner=e:")
((eqv? type GNC-OWNER-VENDOR) (else "unknown-type="))
(set! ref "owner=v:")) (gncOwnerReturnGUID end-owner)
(if (null? acc) "" (string-append "&acct=" (gncAccountGetGUID acc))))
((eqv? type GNC-OWNER-EMPLOYEE) "")))
(set! ref "owner=e:"))
(else (set! ref "unknown-type=")))
(if ref
(begin
(set! ref (string-append ref (gncOwnerReturnGUID end-owner)))
(if (not (null? acc))
(set! ref (string-append ref "&acct="
(gncAccountGetGUID acc))))
(gnc-build-url URL-TYPE-OWNERREPORT ref ""))
ref)))
;; Make a new report and return the anchor to it. The new report of ;; Make a new report and return the anchor to it. The new report of
;; type 'reportname' will have the option values copied from ;; type 'reportname' will have the option values copied from

24
gnucash/report/report-utilities.scm
View File

@ -868,6 +868,16 @@
account-balances) account-balances)
total)) total))
(define (gnc:multiline-to-html-text str)
;; simple function - splits string containing #\newline into
;; substrings, and convert to a gnc:make-html-text construct which
;; adds gnc:html-markup-br after each substring.
(let loop ((list-of-substrings (string-split str #\newline))
(result '()))
(if (null? list-of-substrings)
(apply gnc:make-html-text (if (null? result) '() (reverse (cdr result))))
(loop (cdr list-of-substrings)
(cons* (gnc:html-markup-br) (car list-of-substrings) result)))))
;; *************************************************************************** ;; ***************************************************************************
;; Business Functions ;; Business Functions
@ -1008,6 +1018,18 @@
(gnc-lot-get-notes lot) (gnc-lot-get-notes lot)
(gnc-lot-get-balance lot) (gnc-lot-get-balance lot)
(gnc-lot-count-splits lot))) (gnc-lot-count-splits lot)))
(define (record->str rec)
(let ((rtd (record-type-descriptor rec)))
(define (fld->str fld)
(format #f "~a=~a" fld (gnc:strify ((record-accessor rtd fld) rec))))
(format #f "Rec:~a{~a}"
(record-type-name rtd)
(string-join (map fld->str (record-type-fields rtd)) ", "))))
(define (hash-table->str hash)
(string-append
"Hash(" (string-join
(hash-map->list (lambda (k v) (format #f "~a=~a" k v)) hash) ",")
")"))
(define (try proc) (define (try proc)
;; Try proc with d as a parameter, catching exceptions to return ;; Try proc with d as a parameter, catching exceptions to return
;; #f to the (or) evaluator below. ;; #f to the (or) evaluator below.
@ -1043,6 +1065,8 @@
(try owner->str) (try owner->str)
(try invoice->str) (try invoice->str)
(try lot->str) (try lot->str)
(try hash-table->str)
(try record->str)
(object->string d))) (object->string d)))
(define (pair->num pair) (define (pair->num pair)

2
gnucash/report/report.scm
View File

@ -649,6 +649,7 @@
(export gnc:html-markup-h3) (export gnc:html-markup-h3)
(export gnc:html-markup-br) (export gnc:html-markup-br)
(export gnc:html-markup-hr) (export gnc:html-markup-hr)
(export gnc:html-markup-ol)
(export gnc:html-markup-ul) (export gnc:html-markup-ul)
(export gnc:html-markup-anchor) (export gnc:html-markup-anchor)
(export gnc:html-markup-img) (export gnc:html-markup-img)
@ -717,6 +718,7 @@
(export gnc:get-assoc-account-balances) (export gnc:get-assoc-account-balances)
(export gnc:select-assoc-account-balance) (export gnc:select-assoc-account-balance)
(export gnc:get-assoc-account-balances-total) (export gnc:get-assoc-account-balances-total)
(export gnc:multiline-to-html-text)
(export make-file-url) (export make-file-url)
(export gnc:strify) (export gnc:strify)
(export gnc:pk) (export gnc:pk)

186
gnucash/report/reports/standard/balsheet-pnl.scm
View File

@ -38,10 +38,11 @@
;; the column-data record. the gnc:account-accumulate-at-dates will ;; the column-data record. the gnc:account-accumulate-at-dates will
;; create a record for each report-date with split-data as follows: ;; create a record for each report-date with split-data as follows:
(define-record-type :col-datum (define-record-type :col-datum
(make-datum last-split split-balance) (make-datum last-split split-balance split-value-balance)
col-datum? col-datum?
(last-split col-datum-get-last-split) (last-split col-datum-get-last-split)
(split-balance col-datum-get-split-balance)) (split-balance col-datum-get-split-balance)
(split-value-balance col-datum-get-split-value-balance))
(define FOOTER-TEXT (define FOOTER-TEXT
(gnc:make-html-text (gnc:make-html-text
@ -785,14 +786,20 @@ also show overall period profit & loss."))
(map (map
(lambda (acc) (lambda (acc)
(let* ((comm (xaccAccountGetCommodity acc)) (let* ((comm (xaccAccountGetCommodity acc))
(val-coll (gnc:make-commodity-collector))
(amt->monetary (lambda (amt) (gnc:make-gnc-monetary comm amt)))) (amt->monetary (lambda (amt) (gnc:make-gnc-monetary comm amt))))
(cons acc (cons acc
(gnc:account-accumulate-at-dates (gnc:account-accumulate-at-dates
acc report-dates acc report-dates
#:nosplit->elt (make-datum #f (amt->monetary 0)) #:nosplit->elt (make-datum #f (amt->monetary 0)
(gnc:make-commodity-collector))
#:split->elt #:split->elt
(lambda (s) (lambda (s)
(make-datum s (amt->monetary (xaccSplitGetBalance s)))))))) (val-coll 'add
(xaccTransGetCurrency (xaccSplitGetParent s))
(xaccSplitGetValue s))
(make-datum s (amt->monetary (xaccSplitGetBalance s))
(gnc:collector+ val-coll)))))))
accounts)) accounts))
;; an alist of (cons account account-balances) whereby ;; an alist of (cons account account-balances) whereby
@ -902,6 +909,15 @@ also show overall period profit & loss."))
(maxindent (1+ (apply max (cons 0 (map gnc-account-get-current-depth (maxindent (1+ (apply max (cons 0 (map gnc-account-get-current-depth
accounts)))))) 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! (gnc:html-document-set-title!
doc (with-output-to-string doc (with-output-to-string
(lambda () (lambda ()
@ -910,7 +926,7 @@ also show overall period profit & loss."))
(if (or incr (eq? report-type 'pnl)) (if (or incr (eq? report-type 'pnl))
(format #t (_ "~a to ~a") (format #t (_ "~a to ~a")
(qof-print-date startdate) (qof-print-date enddate)) (qof-print-date startdate) (qof-print-date enddate))
(qof-print-date enddate))))) (display (qof-print-date enddate))))))
(if (eq? (get-option gnc:pagename-general optname-options-summary) 'always) (if (eq? (get-option gnc:pagename-general optname-options-summary) 'always)
(gnc:html-document-add-object! (gnc:html-document-add-object!
@ -945,28 +961,36 @@ also show overall period profit & loss."))
(split (vector-ref date-splits col-idx))) (split (vector-ref date-splits col-idx)))
(gnc:split-anchor-text split)))) (gnc:split-anchor-text split))))
;; a vector of collectors whereby collector is the sum of
;; asset and liabilities at report dates
(asset-liability-balances (asset-liability-balances
(let ((asset-liab-balances (sum-balances-of-accounts
(map cdr (filter accounts-balances asset-liability gnc:monetaries-add))
(lambda (acc-balances)
(member (car acc-balances) asset-liability))
accounts-balances))))
(if (null? asset-liab-balances)
(map (const (gnc:make-commodity-collector)) report-dates)
(apply map gnc:monetaries-add asset-liab-balances))))
;; a vector of collectors whereby collector is the sum of
;; incomes and expenses at report dates
(income-expense-balances (income-expense-balances
(let ((inc-exp-balances (sum-balances-of-accounts
(map cdr accounts-balances income-expense gnc:monetaries-add))
(filter
(lambda (acc-balances)
(member (car acc-balances) income-expense))
accounts-balances))))
(if (null? inc-exp-balances)
(map (const (gnc:make-commodity-collector)) report-dates)
(map gnc:commodity-collector-get-negated
(apply map gnc:monetaries-add inc-exp-balances)))))
;; 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 (monetaries->exchanged
(lambda (monetaries target-currency price-source date) (lambda (monetaries target-currency price-source date)
(let ((exchange-fn (gnc:case-exchange-fn (let ((exchange-fn (gnc:case-exchange-fn
@ -978,30 +1002,35 @@ also show overall period profit & loss."))
(exchange-fn mon target-currency)) (exchange-fn mon target-currency))
(monetaries 'format gnc:make-gnc-monetary #f))))))) (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 (unrealized-gain-fn
(lambda (col-idx) (lambda (col-idx)
(and common-currency (and-let* (common-currency
(let* ((date (case price-source (date (case price-source
((pricedb-latest) (current-time)) ((pricedb-latest) (current-time))
(else (list-ref report-dates col-idx)))) (else (list-ref report-dates col-idx))))
(asset-liability-balance (asset-liability-balance
(list-ref asset-liability-balances col-idx)) (vector-ref asset-liability-balances col-idx))
(asset-liability-basis (asset-liability-basis
(gnc:accounts-get-comm-total-assets (vector-ref asset-liability-value-balances col-idx))
asset-liability
(lambda (acc)
(gnc:account-get-comm-value-at-date acc date #f))))
(unrealized (gnc:collector- asset-liability-basis (unrealized (gnc:collector- asset-liability-basis
asset-liability-balance))) asset-liability-balance)))
(monetaries->exchanged (monetaries->exchanged
unrealized common-currency price-source date))))) 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 (retained-earnings-fn
(lambda (col-idx) (lambda (col-idx)
(let* ((date (case price-source (let* ((date (case price-source
((pricedb-latest) (current-time)) ((pricedb-latest) (current-time))
(else (list-ref report-dates col-idx)))) (else (list-ref report-dates col-idx))))
(income-expense-balance (income-expense-balance
(list-ref income-expense-balances col-idx))) (vector-ref income-expense-balances col-idx)))
(if (and common-currency (if (and common-currency
(every has-price? (every has-price?
(gnc:accounts-get-commodities income-expense #f))) (gnc:accounts-get-commodities income-expense #f)))
@ -1012,18 +1041,21 @@ also show overall period profit & loss."))
gnc:monetary-neg gnc:monetary-neg
(income-expense-balance 'format gnc:make-gnc-monetary #f)))))) (income-expense-balance 'format gnc:make-gnc-monetary #f))))))
(chart (and include-chart? incr (chart (and-let* (include-chart?
incr
(curr (or common-currency book-main-currency))
(price (or price-source 'pricedb-nearest)))
(gnc:make-report-anchor (gnc:make-report-anchor
networth-barchart-uuid report-obj networth-barchart-uuid report-obj
(list (list "General" "Start Date" (cons 'absolute startdate)) (list (list "General" "Start Date" (cons 'absolute startdate))
(list "General" "End Date" (cons 'absolute enddate)) (list "General" "End Date" (cons 'absolute enddate))
(list "General" "Report's currency" (list "General" "Report's currency" curr)
(or common-currency book-main-currency))
(list "General" "Step Size" incr) (list "General" "Step Size" incr)
(list "General" "Price Source" (list "General" "Price Source" price)
(or price-source 'pricedb-nearest))
(list "Accounts" "Accounts" asset-liability))))) (list "Accounts" "Accounts" asset-liability)))))
(get-col-header-fn (lambda (accounts col-idx)
(get-col-header-fn
(lambda (accounts col-idx)
(let* ((date (list-ref report-dates col-idx)) (let* ((date (list-ref report-dates col-idx))
(header (qof-print-date date)) (header (qof-print-date date))
(cell (gnc:make-html-table-cell/markup (cell (gnc:make-html-table-cell/markup
@ -1032,6 +1064,7 @@ also show overall period profit & loss."))
cell "total-label-cell" cell "total-label-cell"
'attribute '("style" "text-align:right")) 'attribute '("style" "text-align:right"))
cell))) cell)))
(add-to-table (lambda* (table title accounts #:key (add-to-table (lambda* (table title accounts #:key
(get-col-header-fn #f) (get-col-header-fn #f)
(show-accounts? #t) (show-accounts? #t)
@ -1085,11 +1118,14 @@ also show overall period profit & loss."))
(add-to-table (add-to-table
multicol-table-right (_ "Equity") multicol-table-right (_ "Equity")
(append equity-accounts (append equity-accounts
(list (if common-currency
(vector (_ "Unrealized Gains") (list (vector (_ "Unrealized Gains")
unrealized-gain-fn) unrealized-gain-fn))
(vector (_ "Retained Earnings") '())
retained-earnings-fn))) (if (null? income-expense)
'()
(list (vector (_ "Retained Earnings")
retained-earnings-fn))))
#:negate-amounts? #t) #:negate-amounts? #t)
(if (and common-currency show-rates?) (if (and common-currency show-rates?)
@ -1127,6 +1163,7 @@ also show overall period profit & loss."))
(cons (car balancelist) (last balancelist)) (cons (car balancelist) (last balancelist))
(cons (list-ref balancelist idx) (cons (list-ref balancelist idx)
(list-ref balancelist (1+ idx)))))) (list-ref balancelist (1+ idx))))))
(closing-entries (let ((query (qof-query-create-for-splits))) (closing-entries (let ((query (qof-query-create-for-splits)))
(qof-query-set-book query (gnc-get-current-book)) (qof-query-set-book query (gnc-get-current-book))
(xaccQueryAddAccountMatch (xaccQueryAddAccountMatch
@ -1140,6 +1177,7 @@ also show overall period profit & loss."))
(let ((splits (qof-query-run query))) (let ((splits (qof-query-run query)))
(qof-query-destroy query) (qof-query-destroy query)
splits))) splits)))
;; this function will query the above closing-entries for ;; this function will query the above closing-entries for
;; splits within the date range, and produce the total ;; splits within the date range, and produce the total
;; amount for these closing entries ;; amount for these closing entries
@ -1155,52 +1193,49 @@ also show overall period profit & loss."))
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
(xaccAccountGetCommodity account) (xaccAccountGetCommodity account)
(apply + (map xaccSplitGetAmount account-closing-splits)))))) (apply + (map xaccSplitGetAmount account-closing-splits))))))
(get-cell-monetary-fn (get-cell-monetary-fn
(lambda (account col-idx) (lambda (account col-idx)
(let ((account-balance-list (assoc account accounts-balances))) (let* ((balances (assoc-ref accounts-balances account))
(and account-balance-list (monetarypair (col-idx->monetarypair balances col-idx)))
(let ((monetarypair (col-idx->monetarypair
(cdr account-balance-list)
col-idx)))
(monetary-less (monetary-less
(cdr monetarypair) (cdr monetarypair)
(car monetarypair) (car monetarypair)
(closing-adjustment account col-idx))))))) (closing-adjustment account col-idx)))))
(get-cell-anchor-fn (lambda (account col-idx) (get-cell-anchor-fn
(define datepair (col-idx->datepair col-idx)) (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 (gnc:make-report-anchor
trep-uuid report-obj trep-uuid report-obj
(list (list
(list "General" "Start Date" (list "General" "Start Date" (cons 'absolute (car datepair)))
(cons 'absolute (car datepair))) (list "General" "End Date" (cons 'absolute (cdr datepair)))
(list "General" "End Date" (list "General" "Show original currency amount" show-orig?)
(cons 'absolute (cdr datepair))) (list "General" "Common Currency" common-currency)
(list "General" "Show original currency amount" (list "General" "Report's currency" curr)
(and common-currency #t))
(list "General" "Common Currency"
common-currency)
(list "General" "Report's currency"
(or common-currency book-main-currency))
(list "Display" "Amount" 'double) (list "Display" "Amount" 'double)
(list "Accounts" "Accounts" (list "Accounts" "Accounts" accts))))))
(if (pair? account)
account
(list account)))))))
(chart (and include-chart? (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 (gnc:make-report-anchor
pnl-barchart-uuid report-obj pnl-barchart-uuid report-obj
(list (list "General" "Start Date" (list (list "General" "Start Date" (cons 'absolute startdate))
(cons 'absolute startdate)) (list "General" "End Date" (cons 'absolute enddate))
(list "General" "End Date" (list "General" "Report's currency" curr)
(cons 'absolute enddate)) (list "General" "Step Size" delta)
(list "General" "Report's currency" (list "General" "Price Source" price)
(or common-currency book-main-currency))
(list "General" "Step Size" (or incr 'MonthDelta))
(list "General" "Price Source"
(or price-source 'pricedb-nearest))
(list "Accounts" "Accounts" income-expense))))) (list "Accounts" "Accounts" income-expense)))))
(get-col-header-fn (get-col-header-fn
(lambda (accounts col-idx) (lambda (accounts col-idx)
(let* ((datepair (col-idx->datepair col-idx)) (let* ((datepair (col-idx->datepair col-idx))
@ -1215,6 +1250,7 @@ also show overall period profit & loss."))
cell "total-label-cell" cell "total-label-cell"
'attribute '("style" "text-align:right")) 'attribute '("style" "text-align:right"))
cell))) cell)))
(add-to-table (lambda* (table title accounts #:key (add-to-table (lambda* (table title accounts #:key
(get-col-header-fn #f) (get-col-header-fn #f)
(show-accounts? #t) (show-accounts? #t)

15
gnucash/report/reports/standard/customer-summary.scm
View File

@ -178,17 +178,6 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (string-expand string character replace-string)
(with-output-to-string
(lambda ()
(string-for-each
(lambda (c)
(display
(if (char=? c character)
replace-string
c)))
string))))
(define (query owner account-list start-date end-date) (define (query owner account-list start-date end-date)
(let* ((q (qof-query-create-for-splits)) (let* ((q (qof-query-create-for-splits))
(guid (and owner (guid (and owner
@ -213,6 +202,7 @@
;; guid QOF-QUERY-OR) ;; guid QOF-QUERY-OR)
(xaccQueryAddAccountMatch q account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND) (xaccQueryAddAccountMatch q account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #t start-date #t end-date QOF-QUERY-AND) (xaccQueryAddDateMatchTT q #t start-date #t end-date QOF-QUERY-AND)
(xaccQueryAddClosingTransMatch q #f QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book)) (qof-query-set-book q (gnc-get-current-book))
(let ((result (qof-query-run q))) (let ((result (qof-query-run q)))
(qof-query-destroy q) (qof-query-destroy q)
@ -231,8 +221,7 @@
'attribute (list "cellspacing" 0) 'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)) 'attribute (list "cellpadding" 0))
(if name (gnc:html-table-append-row! table (list name))) (if name (gnc:html-table-append-row! table (list name)))
(if addy (gnc:html-table-append-row! (if addy (gnc:html-table-append-row! table (gnc:multiline-to-html-text addy)))
table (list (string-expand addy #\newline "<br/>"))))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table (list (gnc-print-time64 (gnc:get-today) date-format))) table (list (gnc-print-time64 (gnc:get-today) date-format)))
(let ((table-outer (gnc:make-html-table))) (let ((table-outer (gnc:make-html-table)))

10
gnucash/report/reports/standard/invoice.scm
View File

@ -176,15 +176,7 @@
keylist)) keylist))
(define (multiline-to-html-text str) (define (multiline-to-html-text str)
;; simple function - splits string containing #\newline into (gnc:multiline-to-html-text str))
;; substrings, and convert to a gnc:make-html-text construct which
;; adds gnc:html-markup-br after each substring.
(let loop ((list-of-substrings (string-split str #\newline))
(result '()))
(if (null? list-of-substrings)
(apply gnc:make-html-text (if (null? result) '() (reverse (cdr result))))
(loop (cdr list-of-substrings)
(cons* (gnc:html-markup-br) (car list-of-substrings) result)))))
(define (options-generator variant) (define (options-generator variant)

36
gnucash/report/reports/standard/job-report.scm
View File

@ -414,24 +414,6 @@
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE (options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE
(_ "Expense Report") #t)) (_ "Expense Report") #t))
(define (string-expand string character replace-string)
(define (car-line chars)
(take-while (lambda (c) (not (eqv? c character))) chars))
(define (cdr-line chars)
(let ((rest (drop-while (lambda (c) (not (eqv? c character))) chars)))
(if (null? rest)
'()
(cdr rest))))
(define (line-helper chars)
(if (null? chars)
""
(let ((first (car-line chars))
(rest (cdr-line chars)))
(string-append (list->string first)
(if (null? rest) "" replace-string)
(line-helper rest)))))
(line-helper (string->list string)))
(define (setup-query q owner account end-date) (define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID owner))) (let* ((guid (gncOwnerReturnGUID owner)))
@ -462,13 +444,15 @@
'attribute (list "border" 0) 'attribute (list "border" 0)
'attribute (list "cellspacing" 0) 'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)) 'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table table
(list (list (gnc:multiline-to-html-text
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>"))) (gnc:owner-get-name-and-address-dep owner))))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table table (gnc:make-html-text (gnc:html-markup-br)))
(list "<br/>"))
(gnc:html-table-set-last-row-style! (gnc:html-table-set-last-row-style!
table "td" table "td"
'attribute (list "valign" "top")) 'attribute (list "valign" "top"))
@ -505,10 +489,10 @@
'attribute (list "cellspacing" 0) 'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)) 'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (if name name ""))) (gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row! table (list (string-expand
(if addy addy "") (gnc:html-table-append-row! table (list (gnc:multiline-to-html-text (or addy ""))))
#\newline "<br/>")))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table (list (gnc-print-time64 (current-time) date-format))) table (list (gnc-print-time64 (current-time) date-format)))
table)) table))

6
gnucash/report/reports/standard/new-aging.scm
View File

@ -224,10 +224,6 @@ exist but have no suitable transactions."))
((if (eq? sort-order 'increasing) string<? string>?) ((if (eq? sort-order 'increasing) string<? string>?)
(gncOwnerGetName a) (gncOwnerGetName b))) (gncOwnerGetName a) (gncOwnerGetName b)))
(define (html-markup-ol lst)
(apply gnc:html-markup "ol"
(map (lambda (elt) (gnc:html-markup "li" elt)) lst)))
;; set default title ;; set default title
(gnc:html-document-set-title! document report-title) (gnc:html-document-set-title! document report-title)
@ -339,7 +335,7 @@ exist but have no suitable transactions."))
document document
(gnc:make-html-text (gnc:make-html-text
(_ "Please note some transactions were not processed") (_ "Please note some transactions were not processed")
(html-markup-ol (gnc:html-markup-ol
(map (map
(lambda (invalid-split) (lambda (invalid-split)
(gnc:html-markup-anchor (gnc:html-markup-anchor

39
gnucash/report/reports/standard/owner-report.scm
View File

@ -625,24 +625,6 @@
(define (employee-options-generator) (define (employee-options-generator)
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE #t)) (options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE #t))
(define (string-expand string character replace-string)
(define (car-line chars)
(take-while (lambda (c) (not (eqv? c character))) chars))
(define (cdr-line chars)
(let ((rest (drop-while (lambda (c) (not (eqv? c character))) chars)))
(if (null? rest)
'()
(cdr rest))))
(define (line-helper chars)
(if (null? chars)
""
(let ((first (car-line chars))
(rest (cdr-line chars)))
(string-append (list->string first)
(if (null? rest) "" replace-string)
(line-helper rest)))))
(line-helper (string->list string)))
(define (setup-query q owner account end-date) (define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner)))) (let* ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner))))
@ -673,16 +655,17 @@
'attribute (list "border" 0) 'attribute (list "border" 0)
'attribute (list "cellspacing" 0) 'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)) 'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table table (gnc:multiline-to-html-text (gnc:owner-get-name-and-address-dep owner)))
(list
(string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "<br/>")))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table table (gnc:make-html-text (gnc:html-markup-br)))
(list "<br/>"))
(gnc:html-table-set-last-row-style! (gnc:html-table-set-last-row-style!
table "td" table "td"
'attribute (list "valign" "top")) 'attribute (list "valign" "top"))
table)) table))
(define (make-date-row! table label date) (define (make-date-row! table label date)
@ -716,12 +699,14 @@
'attribute (list "cellspacing" 0) 'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0)) 'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (if name name ""))) (gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row! table (list (string-expand
(if addy addy "") (gnc:html-table-append-row!
#\newline "<br/>"))) table (list (gnc:multiline-to-html-text (or addy ""))))
(gnc:html-table-append-row! (gnc:html-table-append-row!
table (list (gnc-print-time64 (gnc:get-today) date-format))) table (list (gnc-print-time64 (gnc:get-today) date-format)))
table)) table))
(define (make-break! document) (define (make-break! document)

165
gnucash/report/reports/standard/test/test-balsheet-pnl.scm
View File

@ -3,6 +3,8 @@
(use-modules (tests test-engine-extras)) (use-modules (tests test-engine-extras))
(use-modules (gnucash reports standard balance-sheet)) (use-modules (gnucash reports standard balance-sheet))
(use-modules (gnucash reports standard income-statement)) (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 stylesheets plain)) ; For the default stylesheet, required for rendering
(use-modules (gnucash report)) (use-modules (gnucash report))
(use-modules (tests test-report-extras)) (use-modules (tests test-report-extras))
@ -15,6 +17,8 @@
(define balance-sheet-uuid "c4173ac99b2b448289bf4d11c731af13") (define balance-sheet-uuid "c4173ac99b2b448289bf4d11c731af13")
(define pnl-uuid "0b81a3bdfd504aff849ec2e8630524bc") (define pnl-uuid "0b81a3bdfd504aff849ec2e8630524bc")
(define multicol-balsheet-uuid "065d5d5a77ba11e8b31e83ada73c5eea")
(define multicol-pnl-uuid "0e94fd0277ba11e8825d43e27232c9d4")
;; Explicitly set locale to make the report output predictable ;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
@ -23,7 +27,11 @@
(test-runner-factory gnc:test-runner) (test-runner-factory gnc:test-runner)
(test-begin "balsheet and profit&loss") (test-begin "balsheet and profit&loss")
(null-test) (null-test)
(balsheet-pnl-tests) (create-test-data)
(balance-sheet-tests)
(pnl-tests)
(multicol-balsheet-tests)
(multicol-pnl-tests)
(test-end "balsheet and profit&loss")) (test-end "balsheet and profit&loss"))
(define (options->sxml uuid options test-title) (define (options->sxml uuid options test-title)
@ -80,7 +88,7 @@
(let ((balance-sheet-options (gnc:make-report-options balance-sheet-uuid))) (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")))) (test-assert "null-test" (options->sxml balance-sheet-uuid balance-sheet-options "null-test"))))
(define (balsheet-pnl-tests) (define (create-test-data)
;; This function will perform implementation testing on the transaction report. ;; This function will perform implementation testing on the transaction report.
(let* ((env (create-test-env)) (let* ((env (create-test-env))
(account-alist (env-create-account-structure-alist env structure)) (account-alist (env-create-account-structure-alist env structure))
@ -95,23 +103,7 @@
(bank2creditcard (cdr (assoc "CreditCard" account-alist))) (bank2creditcard (cdr (assoc "CreditCard" account-alist)))
(equity (cdr (assoc "Equity" account-alist))) (equity (cdr (assoc "Equity" account-alist)))
(income (cdr (assoc "Income" account-alist))) (income (cdr (assoc "Income" account-alist)))
(income-GBP (cdr (assoc "Income-GBP" account-alist))) (income-GBP (cdr (assoc "Income-GBP" account-alist))))
(YEAR (gnc:time64-get-year (gnc:get-today))))
(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))
(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))
;; $100 in Savings account ;; $100 in Savings account
(env-transfer env 01 01 1970 equity bank1savings 100) (env-transfer env 01 01 1970 equity bank1savings 100)
@ -169,12 +161,19 @@
;; a couple INCOME transactions, a decade later ;; a couple INCOME transactions, a decade later
(env-transfer env 01 01 1980 income bank1current 250) (env-transfer env 01 01 1980 income bank1current 250)
(env-transfer env 01 01 1980 income-GBP foreignsavings 500) (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") (env-transfer-foreign env 01 02 1980 income-GBP bank1current 100 170 #:description "earn 100GBP into $170")))
;; Finally we can begin testing balsheet (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") (display "\n\n balsheet tests\n\n")
(let* ((balance-sheet-options (default-balsheet-testing-options)) (let* ((balance-sheet-options (default-balsheet-testing-options))
(sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-default"))) (sxml (options->sxml balance-sheet-uuid balance-sheet-options "balsheet-default")))
(test-equal "total assets = $116,009" (test-equal "total assets = $116,009"
(list "$116,009.00") (list "$116,009.00")
(sxml->table-row-col sxml 1 15 6)) (sxml->table-row-col sxml 1 15 6))
@ -355,9 +354,16 @@
(sxml->table-row-col sxml 1 3 6)) (sxml->table-row-col sxml 1 3 6))
(test-equal "incl-zb-accts=#t" (test-equal "incl-zb-accts=#t"
'("Empty" "$0.00") '("Empty" "$0.00")
(sxml->table-row-col sxml 1 8 #f))) (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") (display "\n\n pnl tests\n\n")
(let* ((pnl-options (default-pnl-testing-options)) (let* ((pnl-options (default-pnl-testing-options))
(sxml (options->sxml pnl-uuid pnl-options "pnl-default"))) (sxml (options->sxml pnl-uuid pnl-options "pnl-default")))
@ -464,5 +470,114 @@
;;make-multilevel ;;make-multilevel
(set-option! pnl-options "Display" "Parent account balances" 'immediate-bal) (set-option! pnl-options "Display" "Parent account balances" 'immediate-bal)
(set-option! pnl-options "Display" "Parent account subtotals" 't) (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 FUNDS $200.00" "#1.00 $1.30")
(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 FUNDS $300.00" "#1.00 $1.50")
(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 FUNDS $350.00" "#1.00 $1.60")
(sxml->table-row-col sxml 1 #f 4)))))
(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")
(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")
(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")
(sxml->table-row-col sxml 1 #f 4)))))

10
gnucash/report/test/test-report-utilities.scm
View File

@ -151,6 +151,16 @@
(test-equal "gnc:strify <val-coll 10>" (test-equal "gnc:strify <val-coll 10>"
"coll<10>" "coll<10>"
(gnc:strify coll))) (gnc:strify coll)))
(let ((ht (make-hash-table)))
(test-equal "gnc:strify Hash()"
"Hash()"
(gnc:strify ht))
(hash-set! ht 'one "uno")
(test-equal "gnc:strify Hash(one=uno)"
"Hash(one=uno)"
(gnc:strify ht)))
(test-end "debugging tools")) (test-end "debugging tools"))
(define (test-commodity-collector) (define (test-commodity-collector)