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-10-03 13:27:16 +08:00
commit eb58bca7af
8 changed files with 410 additions and 567 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gnucash/report/reports/standard/budget-flow.scm
View File

@ -276,7 +276,8 @@
;; calculate the exchange rates ;; calculate the exchange rates
(exchange-fn (gnc:case-exchange-fn (exchange-fn (gnc:case-exchange-fn
price-source report-currency #f)) price-source report-currency
(gnc-budget-get-period-end-date budget period)))
;; The HTML document ;; The HTML document
(doc (gnc:make-html-document))) (doc (gnc:make-html-document)))

383
gnucash/report/reports/standard/budget-income-statement.scm
View File

@ -417,270 +417,185 @@
;; wrapper around gnc:html-table-append-ruler! ;; wrapper around gnc:html-table-append-ruler!
(define (add-rule table) (define (add-rule table)
(gnc:html-table-append-ruler! (gnc:html-table-append-ruler! table (* 2 tree-depth)))
table (* 2 tree-depth)))
(cond (cond
((null? accounts) ((null? accounts)
;; No accounts selected. ;; No accounts selected.
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc doc
(gnc:html-make-no-account-warning (gnc:html-make-no-account-warning
reportname (gnc:report-id report-obj)))) reportname (gnc:report-id report-obj))))
((not budget-valid?)
;; No budget selected. ((not budget-valid?)
(gnc:html-document-add-object! ;; No budget selected.
doc (gnc:html-make-generic-budget-warning report-title))) (gnc:html-document-add-object!
((and use-budget-period-range? doc (gnc:html-make-generic-budget-warning report-title)))
(< user-budget-period-end user-budget-period-start))
;; User has selected a range with end period lower than start period. ((and use-budget-period-range?
(gnc:html-document-add-object! (< user-budget-period-end user-budget-period-start))
doc ;; User has selected a range with end period lower than start period.
(gnc:html-make-generic-simple-warning (gnc:html-document-add-object!
doc (gnc:html-make-generic-simple-warning
report-title report-title
(_ "Reporting range end period cannot be less than start period.")))) (_ "Reporting range end period cannot be less than start period."))))
(else (begin
;; Get all the balances for each of the account types.
(let* (
(revenue-account-balances #f)
(expense-account-balances #f)
(revenue-total #f) (else
(revenue-get-balance-fn #f) ;; Get all the balances for each of the account types.
(let* ((revenue-account-balances
(get-assoc-account-balances-budget
budget revenue-accounts period-start period-end
get-budget-account-budget-balance))
(expense-total #f) (expense-account-balances
(expense-get-balance-fn #f) (get-assoc-account-balances-budget
budget expense-accounts period-start period-end
get-budget-account-budget-balance))
(net-income #f) (revenue-total
(gnc:get-assoc-account-balances-total revenue-account-balances))
;; Create the account tables below where their (expense-total
;; percentage time can be tracked. (gnc:get-assoc-account-balances-total expense-account-balances))
(inc-table (gnc:make-html-table)) ;; gnc:html-table
(exp-table (gnc:make-html-table))
(table-env #f) ;; parameters for :make- (net-income
(params #f) ;; and -add-account- (gnc:collector- revenue-total expense-total))
(revenue-table #f) ;; gnc:html-acct-table
(expense-table #f) ;; gnc:html-acct-table
(budget-name (gnc-budget-get-name budget))
(period-for
(if use-budget-period-range?
(if (equal? user-budget-period-start user-budget-period-end)
(format
#f
(_ "for Budget ~a Period ~d")
budget-name
user-budget-period-start)
(format
#f
(_ "for Budget ~a Periods ~d - ~d")
budget-name
user-budget-period-start
user-budget-period-end))
(format
#f
(_ "for Budget ~a")
budget-name)))
)
;; a helper to add a line to our report (table-env
(define (report-line (list
table pos-label neg-label amount col exchange-fn rule? row-style) (list 'display-tree-depth tree-depth)
(let* ((neg? (and amount neg-label (list 'depth-limit-behavior
(negative? (if bottom-behavior 'flatten 'summarize))
(gnc:gnc-monetary-amount (list 'report-commodity report-commodity)
(gnc:sum-collector-commodity (list 'exchange-fn exchange-fn)
amount report-commodity exchange-fn))))) (list 'parent-account-subtotal-mode parent-total-mode)
(label (if neg? (or neg-label pos-label) pos-label)) (list 'zero-balance-mode
(abs-amt (if neg? (gnc:collector- amount) amount)) (if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
(bal (gnc:sum-collector-commodity (list 'account-label-mode (if use-links? 'anchor 'name))))
abs-amt report-commodity exchange-fn)))
(gnc:html-table-add-labeled-amount-line!
table (* 2 tree-depth) row-style rule?
label 0 1 "text-cell"
bal (1+ col) 1 "number-cell")))
(gnc:report-percent-done 5) (params
(list
(list 'parent-account-balance-mode parent-balance-mode)
(list 'zero-balance-display-mode
(if omit-zb-bals? 'omit-balance 'show-balance))
(list 'multicommodity-mode (and show-fcur? 'table))
(list 'rule-mode use-rules?)))
;; Pre-fetch expense account balances. (revenue-get-balance-fn
(set! expense-account-balances (lambda (acct start-date end-date)
(get-assoc-account-balances-budget (gnc:collector-
budget (gnc:select-assoc-account-balance revenue-account-balances acct))))
expense-accounts
period-start
period-end
get-budget-account-budget-balance))
;; Total expenses. (revenue-table
(set! expense-total (gnc:make-html-acct-table/env/accts
(gnc:get-assoc-account-balances-total expense-account-balances)) (cons (list 'get-balance-fn revenue-get-balance-fn) table-env)
revenue-accounts))
;; Function to get individual expense account total. (expense-get-balance-fn
(set! expense-get-balance-fn (lambda (acct start-date end-date)
(lambda (account start-date end-date) (gnc:select-assoc-account-balance expense-account-balances acct)))
(gnc:select-assoc-account-balance expense-account-balances account)))
(gnc:report-percent-done 10) (expense-table
(gnc:make-html-acct-table/env/accts
(cons (list 'get-balance-fn expense-get-balance-fn) table-env)
expense-accounts))
;; Pre-fetch revenue account balances. (space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))
(set! revenue-account-balances
(get-assoc-account-balances-budget
budget
revenue-accounts
period-start
period-end
get-budget-account-budget-balance))
;; Total revenue. (inc-table
(set! revenue-total (let ((table (gnc:make-html-table)))
(gnc:get-assoc-account-balances-total revenue-account-balances)) (gnc:html-table-append-row! table space)
(when label-revenue?
(add-subtotal-line table (_ "Revenues") #f #f))
(gnc:html-table-add-account-balances table revenue-table params)
(when total-revenue?
(add-subtotal-line table (_ "Total Revenue") #f revenue-total))
table))
;; Function to get individual revenue account total. (exp-table
;; Budget revenue is always positive, so this must be negated. (let ((table (gnc:make-html-table)))
(set! revenue-get-balance-fn (gnc:html-table-append-row! table space)
(lambda (account start-date end-date) (when label-expense?
(gnc:commodity-collector-get-negated (add-subtotal-line table (_ "Expenses") #f #f))
(gnc:select-assoc-account-balance revenue-account-balances account)))) (gnc:html-table-add-account-balances table expense-table params)
(when total-expense?
(add-subtotal-line table (_ "Total Expenses") #f expense-total))
table))
(gnc:report-percent-done 20) (budget-name (gnc-budget-get-name budget))
;; calculate net income (period-for
(set! net-income (cond
(gnc:collector- revenue-total expense-total)) ((not use-budget-period-range?)
(format #f (_ "for Budget ~a") budget-name))
((= user-budget-period-start user-budget-period-end)
(format #f (_ "for Budget ~a Period ~d")
budget-name user-budget-period-start))
(else
(format #f (_ "for Budget ~a Periods ~d - ~d")
budget-name user-budget-period-start
user-budget-period-end)))))
(gnc:report-percent-done 30) ;; a helper to add a line to our report
(define (report-line
table pos-label neg-label amount col exchange-fn rule? row-style)
(let* ((neg? (and amount neg-label
(negative?
(gnc:gnc-monetary-amount
(gnc:sum-collector-commodity
amount report-commodity exchange-fn)))))
(label (if neg? (or neg-label pos-label) pos-label))
(abs-amt (if neg? (gnc:collector- amount) amount))
(bal (gnc:sum-collector-commodity
abs-amt report-commodity exchange-fn)))
(gnc:html-table-add-labeled-amount-line!
table (* 2 tree-depth) row-style rule?
label 0 1 "text-cell"
bal (1+ col) 1 "number-cell")))
(gnc:html-document-set-title! (gnc:report-percent-done 30)
doc
(format #f "~a ~a ~a" company-name report-title period-for))
(set! table-env (gnc:html-document-set-title!
(list doc (format #f "~a ~a ~a" company-name report-title period-for))
(list 'display-tree-depth tree-depth)
(list 'depth-limit-behavior (if bottom-behavior
'flatten
'summarize))
(list 'report-commodity report-commodity)
(list 'exchange-fn exchange-fn)
(list 'parent-account-subtotal-mode parent-total-mode)
(list 'zero-balance-mode (if show-zb-accts?
'show-leaf-acct
'omit-leaf-acct))
(list 'account-label-mode (if use-links?
'anchor
'name))
)
)
(set! params
(list
(list 'parent-account-balance-mode parent-balance-mode)
(list 'zero-balance-display-mode (if omit-zb-bals?
'omit-balance
'show-balance))
(list 'multicommodity-mode (if show-fcur? 'table #f))
(list 'rule-mode use-rules?)
)
)
(let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60)))) (report-line
(gnc:html-table-append-row! inc-table space) (if standard-order? exp-table inc-table)
(gnc:html-table-append-row! exp-table space)) (string-append (_ "Net income") " " period-for)
(string-append (_ "Net loss") " " period-for)
net-income
(* 2 (1- tree-depth)) exchange-fn #f #f)
(gnc:report-percent-done 80) (let ((build-table (gnc:make-html-table))
(if label-revenue? (inc-cell (gnc:make-html-table-cell inc-table))
(add-subtotal-line inc-table (_ "Revenues") #f #f)) (exp-cell (gnc:make-html-table-cell exp-table)))
(set! revenue-table (define (add-cells . lst) (gnc:html-table-append-row! build-table lst))
(gnc:make-html-acct-table/env/accts (cond
(append table-env (list (list 'get-balance-fn revenue-get-balance-fn))) ((and two-column? standard-order?)
revenue-accounts)) (add-cells inc-cell exp-cell))
(gnc:html-table-add-account-balances
inc-table revenue-table params)
(if total-revenue?
(add-subtotal-line
inc-table (_ "Total Revenue") #f revenue-total))
(gnc:report-percent-done 85) (two-column?
(if label-expense? (add-cells exp-cell inc-cell))
(add-subtotal-line
exp-table (_ "Expenses") #f #f))
(set! expense-table
(gnc:make-html-acct-table/env/accts
(append table-env (list (list 'get-balance-fn expense-get-balance-fn)))
expense-accounts))
(gnc:html-table-add-account-balances
exp-table expense-table params)
(if total-expense?
(add-subtotal-line
exp-table (_ "Total Expenses") #f expense-total))
(report-line (standard-order?
(if standard-order? (add-cells inc-cell)
exp-table (add-cells exp-cell))
inc-table)
(string-append (_ "Net income") " " period-for)
(string-append (_ "Net loss") " " period-for)
net-income
(* 2 (- tree-depth 1)) exchange-fn #f #f
)
(gnc:html-document-add-object! (else
doc (add-cells exp-cell)
(let* ((build-table (gnc:make-html-table))) (add-cells inc-cell)))
(if two-column?
(gnc:html-table-append-row!
build-table
(if standard-order?
(list
(gnc:make-html-table-cell inc-table)
(gnc:make-html-table-cell exp-table)
)
(list
(gnc:make-html-table-cell exp-table)
(gnc:make-html-table-cell inc-table)
)
)
)
(if standard-order?
(begin
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell inc-table)))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell exp-table)))
)
(begin
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell exp-table)))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell inc-table)))
)
)
)
(gnc:html-table-set-style! (gnc:html-table-set-style!
build-table "td" build-table "td"
'attribute '("align" "left") 'attribute '("align" "left")
'attribute '("valign" "top")) 'attribute '("valign" "top"))
build-table (gnc:html-document-add-object! doc build-table))
)
)
;; add currency information if requested
(gnc:report-percent-done 90)
;; add currency information if requested (when show-rates?
(gnc:report-percent-done 90) (gnc:html-document-add-object!
(if show-rates? doc (gnc:html-make-exchangerates report-commodity exchange-fn accounts)))
(gnc:html-document-add-object! (gnc:report-percent-done 100))))
doc ;;(gnc:html-markup-p)
(gnc:html-make-exchangerates
report-commodity exchange-fn accounts)))
(gnc:report-percent-done 100)
)
))) ;; end cond
(gnc:report-finished) (gnc:report-finished)

6
gnucash/report/reports/standard/budget.scm
View File

@ -332,7 +332,7 @@
(let* ((comm (xaccAccountGetCommodity acct)) (let* ((comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct)) (reverse-balance? (gnc-reverse-balance acct))
(allperiods (filter number? (gnc:list-flatten column-list))) (allperiods (filter number? (gnc:list-flatten column-list)))
(total-periods (if accumulate? (total-periods (if (and accumulate? (not (null? allperiods)))
(iota (1+ (apply max allperiods))) (iota (1+ (apply max allperiods)))
allperiods)) allperiods))
(income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME))) (income-acct? (eqv? (xaccAccountGetType acct) ACCT-TYPE-INCOME)))
@ -537,7 +537,9 @@
(define (calc-periods (define (calc-periods
budget user-start user-end collapse-before? collapse-after? show-total?) budget user-start user-end collapse-before? collapse-after? show-total?)
(define (range start end) (define (range start end)
(iota (- end start) start)) (if (< start end)
(iota (- end start) start)
(iota (- start end) end)))
(let* ((num-periods (gnc-budget-get-num-periods budget)) (let* ((num-periods (gnc-budget-get-num-periods budget))
(range-start (or user-start 0)) (range-start (or user-start 0))
(range-end (if user-end (1+ user-end) num-periods)) (range-end (if user-end (1+ user-end) num-periods))

7
gnucash/report/reports/standard/cash-flow.scm
View File

@ -196,8 +196,6 @@
(let* ((tree-depth (if (equal? display-depth 'all) (let* ((tree-depth (if (equal? display-depth 'all)
(accounts-get-children-depth accounts) (accounts-get-children-depth accounts)
display-depth)) display-depth))
(money-diff-collector (gnc:make-commodity-collector))
(account-disp-list (account-disp-list
(map (map
(lambda (account) (lambda (account)
@ -253,8 +251,6 @@
account-full-name<?)) account-full-name<?))
(money-out-alist (cdr (assq 'money-out-alist result))) (money-out-alist (cdr (assq 'money-out-alist result)))
(money-out-collector (cdr (assq 'money-out-collector result)))) (money-out-collector (cdr (assq 'money-out-collector result))))
(money-diff-collector 'merge money-in-collector #f)
(money-diff-collector 'minusmerge money-out-collector #f)
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc doc
@ -318,7 +314,8 @@
(gnc:make-html-table-header-cell/markup (gnc:make-html-table-header-cell/markup
"total-number-cell" "total-number-cell"
(gnc:sum-collector-commodity (gnc:sum-collector-commodity
money-diff-collector report-currency exchange-fn)))) (gnc:collector- money-in-collector money-out-collector)
report-currency exchange-fn))))
(gnc:html-document-add-object! doc table) (gnc:html-document-add-object! doc table)

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

@ -387,290 +387,183 @@
;; Wrapper to call gnc:html-table-add-labeled-amount-line! ;; Wrapper to call gnc:html-table-add-labeled-amount-line!
;; with the proper arguments. ;; with the proper arguments.
(define (add-subtotal-line table pos-label neg-label signed-balance) (define (add-subtotal-line table pos-label neg-label signed-balance)
(let* ((neg? (and signed-balance (let* ((neg? (and signed-balance neg-label
neg-label (negative?
(gnc-numeric-negative-p (gnc:gnc-monetary-amount
(gnc:gnc-monetary-amount (gnc:sum-collector-commodity
(gnc:sum-collector-commodity signed-balance report-commodity exchange-fn)))))
signed-balance report-commodity exchange-fn))))) (label (if neg? (or neg-label pos-label) pos-label))
(label (if neg? (or neg-label pos-label) pos-label)) (balance (if neg? (gnc:collector- signed-balance) signed-balance)))
(balance (if neg? (gnc:collector- signed-balance) signed-balance))) (gnc:html-table-add-labeled-amount-line!
(gnc:html-table-add-labeled-amount-line! table (* tree-depth 2) "primary-subheading" #f label 0 1 "total-label-cell"
table (* tree-depth 2) "primary-subheading" #f label 0 1 "total-label-cell" (gnc:sum-collector-commodity balance report-commodity exchange-fn)
(gnc:sum-collector-commodity balance report-commodity exchange-fn) (1- (* tree-depth 2)) 1 "total-number-cell")))
(1- (* tree-depth 2)) 1 "total-number-cell")))
;; wrapper around gnc:html-table-append-ruler! ;; wrapper around gnc:html-table-append-ruler!
(define (add-rule table) (define (add-rule table)
(gnc:html-table-append-ruler! table (* 2 tree-depth))) (gnc:html-table-append-ruler! table (* 2 tree-depth)))
(gnc:html-document-set-title! (gnc:html-document-set-title!
doc (format #f doc (format #f (string-append "~a ~a " (_ "For Period Covering ~a to ~a"))
(string-append "~a ~a " company-name report-title
(_ "For Period Covering ~a to ~a"))
company-name report-title
(qof-print-date start-date-printable) (qof-print-date start-date-printable)
(qof-print-date end-date))) (qof-print-date end-date)))
(if (null? accounts) (if (null? accounts)
;; error condition: no accounts specified ;; error condition: no accounts specified is this *really*
;; is this *really* necessary?? ;; necessary?? i'd be fine with an all-zero P&L that would,
;; i'd be fine with an all-zero P&L ;; technically, be correct....
;; that would, technically, be correct....
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc doc (gnc:html-make-no-account-warning
(gnc:html-make-no-account-warning reportname (gnc:report-id report-obj)))
reportname (gnc:report-id report-obj)))
;; Get all the balances for each of the account types. ;; Get all the balances for each of the account types.
(let* ((revenue-closing #f) (let* ((expense-total
(expense-closing #f) (gnc:collector-
(neg-revenue-total #f) (gnc:accountlist-get-comm-balance-interval-with-closing
(revenue-total #f) expense-accounts start-date end-date)
(expense-total #f) (gnc:account-get-trans-type-balance-interval-with-closing
(trading-total #f) expense-accounts closing-pattern start-date end-date)))
(net-income #f)
;; Create the account tables below where their (revenue-total
;; percentage time can be tracked. (gnc:collector-
(inc-table (gnc:make-html-table)) ;; gnc:html-table (gnc:account-get-trans-type-balance-interval-with-closing
(exp-table (gnc:make-html-table)) revenue-accounts closing-pattern start-date end-date)
(tra-table (gnc:make-html-table)) (gnc:accountlist-get-comm-balance-interval-with-closing
revenue-accounts start-date end-date)))
(table-env #f) ;; parameters for :make- (trading-total
(params #f) ;; and -add-account- (gnc:accountlist-get-comm-balance-interval-with-closing
(revenue-table #f) ;; gnc:html-acct-table trading-accounts start-date end-date))
(expense-table #f) ;; gnc:html-acct-table
(trading-table #f) (net-income
(gnc:collector+ revenue-total
trading-total
(gnc:collector- expense-total)))
(inc-table (gnc:make-html-table))
(exp-table (gnc:make-html-table))
(tra-table (gnc:make-html-table))
(table-env
(list
(list 'start-date start-date)
(list 'end-date end-date)
(list 'display-tree-depth tree-depth)
(list 'depth-limit-behavior (if bottom-behavior 'flatten 'summarize))
(list 'report-commodity report-commodity)
(list 'exchange-fn exchange-fn)
(list 'parent-account-subtotal-mode parent-total-mode)
(list 'zero-balance-mode
(if show-zb-accts? 'show-leaf-acct 'omit-leaf-acct))
(list 'account-label-mode (if use-links? 'anchor 'name))
;; we may, at some point, want to add an option to
;; generate a pre-adjustment income statement...
(list 'balance-mode 'pre-closing)
(list 'closing-pattern closing-pattern)))
(params
(list
(list 'parent-account-balance-mode parent-balance-mode)
(list 'zero-balance-display-mode
(if omit-zb-bals? 'omit-balance 'show-balance))
(list 'multicommodity-mode (and show-fcur? 'table))
(list 'rule-mode use-rules?)))
(revenue-table
(gnc:make-html-acct-table/env/accts table-env revenue-accounts))
(expense-table
(gnc:make-html-acct-table/env/accts table-env expense-accounts))
(trading-table
(gnc:make-html-acct-table/env/accts table-env trading-accounts))
(period-for (string-append " " (_ "for Period")))) (period-for (string-append " " (_ "for Period"))))
;; a helper to add a line to our report ;; a helper to add a line to our report
(define (report-line (define (add-report-line
table pos-label neg-label amount col table pos-label neg-label amount col
exchange-fn rule? row-style) exchange-fn rule? row-style)
(let* ((neg? (and amount (let* ((mon (gnc:sum-collector-commodity
neg-label amount report-commodity exchange-fn))
(gnc-numeric-negative-p (neg? (and amount neg-label
(gnc:gnc-monetary-amount (negative? (gnc:gnc-monetary-amount mon))))
(gnc:sum-collector-commodity (label (if neg? (or neg-label pos-label) pos-label))
amount report-commodity exchange-fn))))) (bal (if neg? (gnc:monetary-neg mon) mon)))
(label (if neg? (or neg-label pos-label) pos-label)) (gnc:html-table-add-labeled-amount-line!
(pos-bal (if neg? table (* 2 tree-depth) row-style rule?
(let ((bal (gnc:make-commodity-collector))) label 0 1 "text-cell"
(bal 'minusmerge amount #f) bal (+ col 1) 1 "number-cell")))
bal)
amount))
(bal (gnc:sum-collector-commodity
pos-bal report-commodity exchange-fn))
(balance
(or (and (gnc:uniform-commodity? pos-bal report-commodity)
bal)
(and show-fcur?
(gnc-commodity-table
pos-bal report-commodity exchange-fn))
bal
))
(column (or col 0))
)
(gnc:html-table-add-labeled-amount-line!
table (* 2 tree-depth) row-style rule?
label 0 1 "text-cell"
bal (+ col 1) 1 "number-cell")
)
)
;; sum revenues and expenses (let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60))))
(set! revenue-closing
(gnc:account-get-trans-type-balance-interval-with-closing
revenue-accounts closing-pattern
start-date end-date)
) ;; this is norm positive (debit)
(set! expense-closing
(gnc:account-get-trans-type-balance-interval-with-closing
expense-accounts closing-pattern
start-date end-date)
) ;; this is norm negative (credit)
(set! expense-total
(gnc:accountlist-get-comm-balance-interval-with-closing
expense-accounts
start-date end-date))
(expense-total 'minusmerge expense-closing #f)
(set! neg-revenue-total
(gnc:accountlist-get-comm-balance-interval-with-closing
revenue-accounts
start-date end-date))
(neg-revenue-total 'minusmerge revenue-closing #f)
(set! revenue-total (gnc:make-commodity-collector))
(revenue-total 'minusmerge neg-revenue-total #f)
(set! trading-total
(gnc:accountlist-get-comm-balance-interval-with-closing
trading-accounts
start-date end-date))
;; calculate net income
(set! net-income (gnc:make-commodity-collector))
(net-income 'merge revenue-total #f)
(net-income 'merge trading-total #f)
(net-income 'minusmerge expense-total #f)
(set! table-env
(list
(list 'start-date start-date)
(list 'end-date end-date)
(list 'display-tree-depth tree-depth)
(list 'depth-limit-behavior (if bottom-behavior
'flatten
'summarize))
(list 'report-commodity report-commodity)
(list 'exchange-fn exchange-fn)
(list 'parent-account-subtotal-mode parent-total-mode)
(list 'zero-balance-mode (if show-zb-accts?
'show-leaf-acct
'omit-leaf-acct))
(list 'account-label-mode (if use-links?
'anchor
'name))
;; we may, at some point, want to add an option to
;; generate a pre-adjustment income statement...
(list 'balance-mode 'pre-closing)
(list 'closing-pattern closing-pattern)
)
)
(set! params
(list
(list 'parent-account-balance-mode parent-balance-mode)
(list 'zero-balance-display-mode (if omit-zb-bals?
'omit-balance
'show-balance))
(list 'multicommodity-mode (if show-fcur? 'table #f))
(list 'rule-mode use-rules?)
)
)
(let ((space (make-list tree-depth (gnc:make-html-table-cell/min-width 60))))
(gnc:html-table-append-row! inc-table space) (gnc:html-table-append-row! inc-table space)
(gnc:html-table-append-row! exp-table space) (gnc:html-table-append-row! exp-table space)
(gnc:html-table-append-row! tra-table space)) (gnc:html-table-append-row! tra-table space))
(gnc:report-percent-done 80)
(gnc:report-percent-done 80) (when label-revenue?
(if label-revenue? (add-subtotal-line inc-table (_ "Revenues") #f #f))
(add-subtotal-line inc-table (_ "Revenues") #f #f)) (gnc:html-table-add-account-balances inc-table revenue-table params)
(set! revenue-table (when total-revenue?
(gnc:make-html-acct-table/env/accts (add-subtotal-line inc-table (_ "Total Revenue") #f revenue-total))
table-env revenue-accounts)) (gnc:report-percent-done 85)
(gnc:html-table-add-account-balances
inc-table revenue-table params)
(if total-revenue?
(add-subtotal-line
inc-table (_ "Total Revenue") #f revenue-total))
(gnc:report-percent-done 85) (when label-expense?
(if label-expense? (add-subtotal-line exp-table (_ "Expenses") #f #f))
(add-subtotal-line (gnc:html-table-add-account-balances exp-table expense-table params)
exp-table (_ "Expenses") #f #f)) (when total-expense?
(set! expense-table (add-subtotal-line exp-table (_ "Total Expenses") #f expense-total))
(gnc:make-html-acct-table/env/accts
table-env expense-accounts))
(gnc:html-table-add-account-balances
exp-table expense-table params)
(if total-expense?
(add-subtotal-line
exp-table (_ "Total Expenses") #f expense-total))
(if label-trading? (when label-trading?
(add-subtotal-line tra-table (_ "Trading") #f #f)) (add-subtotal-line tra-table (_ "Trading") #f #f))
(set! trading-table (gnc:html-table-add-account-balances tra-table trading-table params)
(gnc:make-html-acct-table/env/accts (when total-trading?
table-env trading-accounts)) (add-subtotal-line tra-table (_ "Total Trading") #f trading-total))
(gnc:html-table-add-account-balances
tra-table trading-table params)
(if total-trading?
(add-subtotal-line
tra-table (_ "Total Trading") #f trading-total))
(report-line (add-report-line
(if standard-order? (if standard-order? exp-table inc-table)
exp-table (string-append (_ "Net income") period-for)
inc-table) (string-append (_ "Net loss") period-for)
(string-append (_ "Net income") period-for) net-income (* 2 (1- tree-depth)) exchange-fn #f #f)
(string-append (_ "Net loss") period-for)
net-income
(* 2 (- tree-depth 1)) exchange-fn #f #f
)
(gnc:html-document-add-object! ;; add the sections in the desired order to document
doc (let ((build-table (gnc:make-html-table))
(let* ((build-table (gnc:make-html-table))) (inc-cell (gnc:make-html-table-cell inc-table))
(if two-column? (tra-cell (if (null? trading-accounts)
(gnc:html-table-append-row! (gnc:html-make-empty-cell)
build-table (gnc:make-html-table-cell tra-table)))
(if standard-order? (exp-cell (gnc:make-html-table-cell exp-table)))
(list (define (add-cells . lst) (gnc:html-table-append-row! build-table lst))
(gnc:make-html-table-cell inc-table) (cond
(if (null? trading-accounts) ((and two-column? standard-order?)
(gnc:html-make-empty-cell) (add-cells inc-cell tra-cell exp-cell))
(gnc:make-html-table-cell tra-table))
(gnc:make-html-table-cell exp-table)
)
(list
(gnc:make-html-table-cell exp-table)
(gnc:make-html-table-cell inc-table)
(if (null? trading-accounts)
(gnc:html-make-empty-cell)
(gnc:make-html-table-cell tra-table))
)
)
)
(if standard-order?
(begin
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell inc-table)))
(if (not (null? trading-accounts))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell tra-table))))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell exp-table)))
)
(begin
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell exp-table)))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell inc-table)))
(if (not (null? trading-accounts))
(gnc:html-table-append-row!
build-table
(list (gnc:make-html-table-cell tra-table))))
)
)
)
(gnc:html-table-set-style! (two-column?
build-table "td" (add-cells exp-cell inc-cell tra-cell))
'attribute '("align" "left")
'attribute '("valign" "top"))
build-table
)
)
(standard-order?
(add-cells inc-cell)
(unless (null? trading-accounts) (add-cells tra-cell))
(add-cells exp-cell))
(else
(add-cells exp-cell)
(add-cells inc-cell)
(unless (null? trading-accounts) (add-cells tra-cell))))
(gnc:html-table-set-style!
build-table "td"
'attribute '("align" "left")
'attribute '("valign" "top"))
(gnc:html-document-add-object! doc build-table))
;; add currency information if requested ;; add currency information if requested
(gnc:report-percent-done 90) (gnc:report-percent-done 90)
(if show-rates? (when show-rates?
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc ;;(gnc:html-markup-p) doc (gnc:html-make-exchangerates
(gnc:html-make-exchangerates report-commodity exchange-fn accounts)))
report-commodity exchange-fn accounts))) (gnc:report-percent-done 100)))
(gnc:report-percent-done 100)
)
)
(gnc:report-finished) (gnc:report-finished)

85
gnucash/report/reports/standard/test/test-budget.scm
View File

@ -31,18 +31,26 @@
(use-modules (gnucash engine)) (use-modules (gnucash engine))
(use-modules (sw_engine)) (use-modules (sw_engine))
(use-modules (gnucash reports standard budget)) (use-modules (gnucash reports standard budget))
(use-modules (gnucash reports standard budget-income-statement))
(use-modules (tests test-report-extras)) (use-modules (tests test-report-extras))
(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 (tests test-engine-extras)) (use-modules (tests test-engine-extras))
(use-modules (sxml xpath))
;; Explicitly set locale to make the report output predictable ;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C") (setlocale LC_ALL "C")
(define uuid "810ed4b25ef0486ea43bbd3dddb32b11") (define budget-uuid "810ed4b25ef0486ea43bbd3dddb32b11")
(define budget-is-uuid "583c313fcc484efc974c4c844404f454")
(define (run-test) (define (run-test)
(test-runner-factory gnc:test-runner) (test-runner-factory gnc:test-runner)
(test-begin "budget") (test-begin "budget")
(test-budget) (test-group-with-cleanup "budget.scm"
(test-budget)
(teardown))
(test-group-with-cleanup "budget-income-statement.scm"
(test-budget-income-statement)
(teardown))
(test-end "budget")) (test-end "budget"))
(define (set-option options page tag value) (define (set-option options page tag value)
@ -51,52 +59,23 @@
(define (teardown) (define (teardown)
(gnc-clear-current-session)) (gnc-clear-current-session))
(define (options->sxml options test-title) (define (options->sxml options uuid test-title)
(gnc:options->sxml uuid options "test-budget" test-title)) (gnc:options->sxml uuid options "test-budget" test-title))
(define (create-budget-and-transactions env account-alist)
(let* ((book (gnc-get-current-book))
(budget (gnc-budget-new book))
(bank (cdr (assoc "Bank" account-alist)))
(income (cdr (assoc "Income" account-alist)))
(expense (cdr (assoc "Expenses" account-alist))))
(gnc-budget-set-name budget "test budget")
(gnc-budget-begin-edit budget)
(gnc-budget-set-num-periods budget 6)
(gnc-budget-set-account-period-value budget bank 0 20)
(gnc-budget-set-account-period-value budget bank 1 40)
(gnc-budget-set-account-period-value budget bank 3 60)
(gnc-budget-set-account-period-value budget expense 1 30)
(gnc-budget-set-account-period-value budget expense 2 20)
(gnc-budget-set-account-period-value budget expense 3 40)
(gnc-budget-set-account-period-value budget income 0 -55)
(gnc-budget-set-account-period-value budget income 2 -65)
(gnc-budget-set-account-period-value budget income 3 -75)
(gnc-budget-commit-edit budget)
(let ((midperiod (lambda (period)
(floor (/ (+ (gnc-budget-get-period-start-date budget period)
(gnc-budget-get-period-end-date budget period))
2)))))
(env-create-transaction env (midperiod 0) bank income 55)
(env-create-transaction env (midperiod 2) bank income 67)
(env-create-transaction env (midperiod 3) bank income 77)
(env-create-transaction env (midperiod 0) expense bank 20)
(env-create-transaction env (midperiod 1) expense bank 20))
budget))
(define (test-budget) (define (test-budget)
(let* ((env (create-test-env)) (let* ((env (create-test-env))
(account-alist (create-test-data)) (account-alist (create-test-data))
(budget (create-budget-and-transactions env account-alist)) (budget (gnc:create-budget-and-transactions env account-alist))
(options (gnc:make-report-options uuid)) (options (gnc:make-report-options budget-uuid))
(bank (cdr (assoc "Bank" account-alist)))) (bank (cdr (assoc "Bank" account-alist))))
(display "\nbudget.scm\n")
(set-option options "Accounts" "Account Display Depth" 'all) (set-option options "Accounts" "Account Display Depth" 'all)
(set-option options "Display" "Show Difference" #f) (set-option options "Display" "Show Difference" #f)
(set-option options "Display" "Show Budget" #f) (set-option options "Display" "Show Budget" #f)
(set-option options "Display" "Show Actual" #f) (set-option options "Display" "Show Actual" #f)
(let ((sxml (options->sxml options "basic all display off"))) (let ((sxml (options->sxml options budget-uuid "basic all display off")))
(test-equal "all display OFF, table has 15 cells" (test-equal "all display OFF, table has 15 cells"
15 15
(length (sxml->table-row-col sxml 1 #f #f)))) (length (sxml->table-row-col sxml 1 #f #f))))
@ -105,7 +84,7 @@
(set-option options "Display" "Show Budget" #t) (set-option options "Display" "Show Budget" #t)
(set-option options "Display" "Show Actual" #t) (set-option options "Display" "Show Actual" #t)
(set-option options "Display" "Show Column with Totals" #t) (set-option options "Display" "Show Column with Totals" #t)
(let ((sxml (options->sxml options "basic"))) (let ((sxml (options->sxml options budget-uuid "basic")))
(test-equal "all display ON, table has 226 cells" (test-equal "all display ON, table has 226 cells"
226 226
(length (sxml->table-row-col sxml 1 #f #f))) (length (sxml->table-row-col sxml 1 #f #f)))
@ -128,7 +107,7 @@
(set-option options "General" "Report for range of budget periods" #t) (set-option options "General" "Report for range of budget periods" #t)
(set-option options "General" "Range start" 'current) (set-option options "General" "Range start" 'current)
(set-option options "General" "Range end" 'next) (set-option options "General" "Range end" 'next)
(let ((sxml (options->sxml options "only next period"))) (let ((sxml (options->sxml options budget-uuid "only next period")))
(test-equal "only next period - 133 cells" (test-equal "only next period - 133 cells"
133 133
(length (sxml->table-row-col sxml 1 #f #f))) (length (sxml->table-row-col sxml 1 #f #f)))
@ -140,7 +119,7 @@
(set-option options "General" "Range start" 'last) (set-option options "General" "Range start" 'last)
(set-option options "General" "Range end" 'last) (set-option options "General" "Range end" 'last)
(let ((sxml (options->sxml options "only last period"))) (let ((sxml (options->sxml options budget-uuid "only last period")))
(test-equal "only last period - 102 cells" (test-equal "only last period - 102 cells"
102 102
(length (sxml->table-row-col sxml 1 #f #f))) (length (sxml->table-row-col sxml 1 #f #f)))
@ -156,7 +135,7 @@
(set-option options "General" "Exact end period" 4) (set-option options "General" "Exact end period" 4)
(set-option options "General" "Include collapsed periods before selected." #f) (set-option options "General" "Include collapsed periods before selected." #f)
(set-option options "General" "Include collapsed periods after selected." #f) (set-option options "General" "Include collapsed periods after selected." #f)
(let ((sxml (options->sxml options "exact periods"))) (let ((sxml (options->sxml options budget-uuid "exact periods")))
(test-equal "exact periods - 133 cells" (test-equal "exact periods - 133 cells"
133 133
(length (sxml->table-row-col sxml 1 #f #f))) (length (sxml->table-row-col sxml 1 #f #f)))
@ -167,9 +146,33 @@
(sxml->table-row-col sxml 1 5 #f))) (sxml->table-row-col sxml 1 5 #f)))
(set-option options "General" "Use accumulated amounts" #t) (set-option options "General" "Use accumulated amounts" #t)
(let ((sxml (options->sxml options "Use accumulated amounts"))) (let ((sxml (options->sxml options budget-uuid "Use accumulated amounts")))
(test-equal "use accumulated amounts" (test-equal "use accumulated amounts"
'("Bank" "$60.00" "$15.00" "$45.00" "$60.00" "$82.00" "-$22.00" '("Bank" "$60.00" "$15.00" "$45.00" "$60.00" "$82.00" "-$22.00"
"$120.00" "$159.00" "-$39.00" "$120.00" "$159.00" "-$39.00") "$120.00" "$159.00" "-$39.00" "$120.00" "$159.00" "-$39.00")
(sxml->table-row-col sxml 1 5 #f))) (sxml->table-row-col sxml 1 5 #f)))
)) ))
(define (test-budget-income-statement)
(let* ((env (create-test-env))
(account-alist (create-test-data))
(budget (gnc:create-budget-and-transactions env account-alist))
(options (gnc:make-report-options budget-is-uuid))
(bank (assoc-ref account-alist "Bank")))
(display "\nbudget-income-statement.scm\n")
(let ((sxml (options->sxml options budget-is-uuid "budget-is-basic")))
(test-equal "basic test"
72
(length (sxml->table-row-col sxml 1 #f #f)))
(test-equal "budgeted income amounts"
'("$195.00" "Income")
((sxpath '(// table // (tr 1) // table // (tr 3) // *text*))
sxml))
(test-equal "net loss for budget"
'("Net loss for Budget test budget" "$285.00")
((sxpath '(// table // (tr 2) // table // (tr 5) // *text*))
sxml)))))

4
gnucash/report/reports/standard/test/test-stress-options.scm
View File

@ -267,6 +267,8 @@
(define (tests) (define (tests)
(run-tests "with empty book") (run-tests "with empty book")
(create-test-data) (let ((env (create-test-env))
(account-alist (create-test-data)))
(gnc:create-budget-and-transactions env account-alist))
(create-test-invoice-data) (create-test-invoice-data)
(run-tests "on a populated book")) (run-tests "on a populated book"))

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

@ -834,6 +834,36 @@
(vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8))) (vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8)))
(define-public (gnc:create-budget-and-transactions env account-alist)
(let* ((book (gnc-get-current-book))
(budget (gnc-budget-new book))
(bank (cdr (assoc "Bank" account-alist)))
(income (cdr (assoc "Income" account-alist)))
(expense (cdr (assoc "Expenses" account-alist))))
(gnc-budget-set-name budget "test budget")
(gnc-budget-begin-edit budget)
(gnc-budget-set-num-periods budget 6)
(gnc-budget-set-account-period-value budget bank 0 20)
(gnc-budget-set-account-period-value budget bank 1 40)
(gnc-budget-set-account-period-value budget bank 3 60)
(gnc-budget-set-account-period-value budget expense 1 30)
(gnc-budget-set-account-period-value budget expense 2 20)
(gnc-budget-set-account-period-value budget expense 3 40)
(gnc-budget-set-account-period-value budget income 0 -55)
(gnc-budget-set-account-period-value budget income 2 -65)
(gnc-budget-set-account-period-value budget income 3 -75)
(gnc-budget-commit-edit budget)
(let ((midperiod (lambda (period)
(floor (/ (+ (gnc-budget-get-period-start-date budget period)
(gnc-budget-get-period-end-date budget period))
2)))))
(env-create-transaction env (midperiod 0) bank income 55)
(env-create-transaction env (midperiod 2) bank income 67)
(env-create-transaction env (midperiod 3) bank income 77)
(env-create-transaction env (midperiod 0) expense bank 20)
(env-create-transaction env (midperiod 1) expense bank 20))
budget))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; various stock transactions ;; various stock transactions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;