"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "gnucash/report/html-acct-table.scm" between
gnucash-5.0.tar.bz2 and gnucash-5.1.tar.bz2

About: GnuCash is personal and small-business financial-accounting software.

html-acct-table.scm  (gnucash-5.0.tar.bz2)	:	html-acct-table.scm  (gnucash-5.1.tar.bz2)
skipping to change at line 240		skipping to change at line 240
;;		;;
;; closing-pattern: alist of 'str 'cased 'regexp		;; closing-pattern: alist of 'str 'cased 'regexp
;;		;;
;; a pattern alist, as accepted by		;; a pattern alist, as accepted by
;; gnc:account-get-trans-type-balance-interval, matching		;; gnc:account-get-trans-type-balance-interval, matching
;; closing transactions to be ignored when balance-mode is		;; closing transactions to be ignored when balance-mode is
;; 'pre-closing.		;; 'pre-closing.
;;		;;
;; report-budget: budget		;; report-budget: budget
;;		;;
;; (optional) a budget used to ignore accounts with zero		;; (optional) a budget used to ignore accounts with zero
;; budget or balance (if zb-balance-mode is set to omit).		;; budget or balance (if zb-balance-mode is set to omit).
;;		;;
;; account-type: unimplemented		;; account-type: unimplemented
;; account-class: unimplemented		;; account-class: unimplemented
;; row-thunk: unimplemented (for gnc:html-acct-table-render)		;; row-thunk: unimplemented (for gnc:html-acct-table-render)
;; row-list: unimplemented (list of all the rows ever added)		;; row-list: unimplemented (list of all the rows ever added)
;;		;;
;; The html-acct-table object lets you generate, store, and access the		;; The html-acct-table object lets you generate, store, and access the
;; following parameters:		;; following parameters:
;;		;;
;; account: Account		;; account: Account
skipping to change at line 574		skipping to change at line 574
(row (gnc:html-table-num-rows html-table)))		(row (gnc:html-table-num-rows html-table)))
(gnc:html-table-set-cell! html-table row 0 env)		(gnc:html-table-set-cell! html-table row 0 env)
row))		row))
;; Add more stuff to an existing row		;; Add more stuff to an existing row
(define (append-to-row row env)		(define (append-to-row row env)
(gnc:html-acct-table-set-row-env! acct-table row		(gnc:html-acct-table-set-row-env! acct-table row
(append (gnc:html-acct-table-get-row-env acct-table row) env)))		(append (gnc:html-acct-table-get-row-env acct-table row) env)))
(let* ((env (gnc:_html-acct-table-env_ acct-table))		(let* ((env (gnc:_html-acct-table-env_ acct-table))
;; establish all input parameters and their defaults		;; establish all input parameters and their defaults
(depth-limit (let ((lim (get-val env 'display-tree-depth)))		(depth-limit (let ((lim (get-val env 'display-tree-depth)))
(and (number? lim) lim)))		(and (number? lim) lim)))
(limit-behavior (or (get-val env 'depth-limit-behavior) 'summarize))		(limit-behavior (or (get-val env 'depth-limit-behavior) 'summarize))
(indent (or (get-val env 'initial-indent) 0))		(indent (or (get-val env 'initial-indent) 0))
(less-p (let ((pred (get-val env 'account-less-p)))		(less-p (let ((pred (get-val env 'account-less-p)))
(if (eq? pred #t) gnc:account-code-less-p pred)))		(if (eq? pred #t) gnc:account-code-less-p pred)))
(start-date (get-val env 'start-date))		(start-date (get-val env 'start-date))
(end-date (or (get-val env 'end-date)		(end-date (or (get-val env 'end-date)
(gnc:get-today)))		(gnc:get-today)))
(report-commodity (or (get-val env 'report-commodity)		(report-commodity (or (get-val env 'report-commodity)
(gnc-default-report-currency)))		(gnc-default-report-currency)))
;; BUG: other code expects a real function here, maybe		;; BUG: other code expects a real function here, maybe
;; someone was thinking price-source?		;; someone was thinking price-source?
(exchange-fn (get-val env 'exchange-fn))		(exchange-fn (get-val env 'exchange-fn))
(get-balance-fn (get-val env 'get-balance-fn))		(get-balance-fn (get-val env 'get-balance-fn))
(column-header (let ((cell (get-val env 'column-header)))		(column-header (let ((cell (get-val env 'column-header)))
(if (eq? cell #t)		(if (eq? cell #t)
(gnc:make-html-table-cell "Account name")		(gnc:make-html-table-cell "Account name")
cell)))		cell)))
(subtotal-mode (get-val env 'parent-account-subtotal-mode))		(subtotal-mode (get-val env 'parent-account-subtotal-mode))
(zero-mode (let ((mode (get-val env 'zero-balance-mode)))		(zero-mode (let ((mode (get-val env 'zero-balance-mode)))
(if (boolean? mode) 'show-leaf-acct mode)))		(if (boolean? mode) 'show-leaf-acct mode)))
(label-mode (or (get-val env 'account-label-mode) 'anchor))		(label-mode (or (get-val env 'account-label-mode) 'anchor))
(balance-mode (or (get-val env 'balance-mode) 'post-closing))		(balance-mode (or (get-val env 'balance-mode) 'post-closing))
(closing-pattern (or (get-val env 'closing-pattern)		(closing-pattern (or (get-val env 'closing-pattern)
(list		(list
(list 'str (G_ "Closing Entries"))		(list 'str (G_ "Closing Entries"))
(list 'cased #f)		(list 'cased #f)
(list 'regexp #f)		(list 'regexp #f)
(list 'closing #t))))		(list 'closing #t))))
(report-budget (or (get-val env 'report-budget) #f))		(report-budget (or (get-val env 'report-budget) #f))
;; local variables		;; local variables
(toplvl-accts		(toplvl-accts
(gnc-account-get-children-sorted (gnc-get-current-root-account)))		(gnc-account-get-children-sorted (gnc-get-current-root-account)))
(acct-depth-reached 0)		(acct-depth-reached 0)
(logi-depth-reached (if depth-limit (- depth-limit 1) 0))		(logi-depth-reached (if depth-limit (- depth-limit 1) 0))
(disp-depth-reached 0)		(disp-depth-reached 0)
)		)
;; 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)
(define ret-hash (make-hash-table))		(define ret-hash (make-hash-table))
(define (calculate-balances-helper)		(define (calculate-balances-helper)
(for-each		(for-each
(lambda (acct)		(lambda (acct)
(hash-set! ret-hash (gncAccountGetGUID acct)		(hash-set! ret-hash (gncAccountGetGUID acct)
skipping to change at line 874		skipping to change at line 874
;; "alternate-row", "primary-subheading", "secondary-subheading", and		;; "alternate-row", "primary-subheading", "secondary-subheading", and
;; "grand-total".		;; "grand-total".
;; There really should also be a "first-number-cell"		;; There really should also be a "first-number-cell"
;; and "last-number-cell" to put currency symbols and underlines,		;; and "last-number-cell" to put currency symbols and underlines,
;; respectively, on the numbers.		;; respectively, on the numbers.
;; Note: arguably, this procedure belongs in html-table.scm instead of here.		;; Note: arguably, this procedure belongs in html-table.scm instead of here.
(define (gnc:html-table-add-labeled-amount-line!		(define (gnc:html-table-add-labeled-amount-line!
;; function to add a label and/or amount (which we'll call a "line")		;; function to add a label and/or amount (which we'll call a "line")
;; to the end of a gnc:html-table. all depths are zero-indexed.		;; to the end of a gnc:html-table. all depths are zero-indexed.
html-table		html-table
table-width ;; if #f defaults to (amount-depth + amount-colspan)		table-width ;; if #f defaults to (amount-depth + amount-colspan)
row-markup ;; optional		row-markup ;; optional
total-rule? ;; Place an <hr> in the cell previous to label?		total-rule? ;; Place an <hr> in the cell previous to label?
label ;; the actual label text		label ;; the actual label text
label-depth ;; defaults to zero		label-depth ;; defaults to zero
label-colspan ;; defaults to one		label-colspan ;; defaults to one
label-markup ;; optional		label-markup ;; optional
amount ;; a <gnc:monetary> or #f		amount ;; a <gnc:monetary> or #f
amount-depth ;; defaults to (label-depth + label-colspan)		amount-depth ;; defaults to (label-depth + label-colspan)
amount-colspan ;; defaults to one		amount-colspan ;; defaults to one
amount-markup) ;; optional		amount-markup) ;; optional
(let* ((lbl-depth (or label-depth 0))		(let* ((lbl-depth (or label-depth 0))
(lbl-colspan 1)		(lbl-colspan 1)
(amt-depth (or amount-depth (+ lbl-depth lbl-colspan)))		(amt-depth (or amount-depth (+ lbl-depth lbl-colspan)))
(amt-colspan 1)		(amt-colspan 1)
(tbl-width (or table-width (+ amt-depth amt-colspan)))		(tbl-width (or table-width (+ amt-depth amt-colspan)))
(row		(row
(append		(append
(list		(list
(if label-markup ;; the actual label		(if label-markup ;; the actual label
(gnc:make-html-table-cell/size/markup		(gnc:make-html-table-cell/size/markup
1 1 label-markup (gnc:make-html-text (gnc:html-make-nbsps lbl-de		1 1 label-markup (gnc:make-html-text (gnc:html-make-nbsps lbl-d
pth)) label)		epth)) label)
(gnc:make-html-table-cell/size		(gnc:make-html-table-cell/size
1 1 (gnc:make-html-text (gnc:html-make-nbsps lbl-depth)) label))		1 1 (gnc:make-html-text (gnc:html-make-nbsps lbl-depth)) label)
)		)
(gnc:html-make-empty-cells ;; padding after label		)
		(gnc:html-make-empty-cells ;; padding after label
(+ (- amt-depth (floor (/ tbl-width 2)))		(+ (- amt-depth (floor (/ tbl-width 2)))
(if total-rule? -1 0)		(if total-rule? -1 0)
)		)
)		)
(if total-rule? ;; include <hr>?		(if total-rule? ;; include <hr>?
(list (gnc:make-html-table-cell		(list (gnc:make-html-table-cell
(gnc:make-html-text (gnc:html-markup-hr))))		(gnc:make-html-text (gnc:html-markup-hr))))
(list)		(list)
)		)
(list		(list
(if amount-markup ;; the amount		(if amount-markup ;; the amount
(gnc:make-html-table-cell/size/markup		(gnc:make-html-table-cell/size/markup
1 amt-colspan amount-markup amount)		1 amt-colspan amount-markup amount)
(gnc:make-html-table-cell/size		(gnc:make-html-table-cell/size
1 amt-colspan amount))		1 amt-colspan amount))
)		)
(gnc:html-make-empty-cells ;; padding out to full width		(gnc:html-make-empty-cells ;; padding out to full width
(- tbl-width (+ amt-depth amt-colspan)))		(- tbl-width (+ amt-depth amt-colspan)))
)		)
) ;; end of row		) ;; end of row
)		)
(if row-markup		(if row-markup
(gnc:html-table-append-row/markup! html-table row-markup row)		(gnc:html-table-append-row/markup! html-table row-markup row)
(gnc:html-table-append-row! html-table row))))		(gnc:html-table-append-row! html-table row))))
(define (gnc-commodity-table amount report-commodity exchange-fn)		(define (gnc-commodity-table amount report-commodity exchange-fn)
;; this creates a small two-column table listing each commodity		;; this creates a small two-column table listing each commodity
;; balance and its respective report balance. note that this		;; balance and its respective report balance. note that this
;; shows report-commodity amounts twice: first as a commodity		;; shows report-commodity amounts twice: first as a commodity
;; and second in the report commodity. though this may arguably		;; and second in the report commodity. though this may arguably
;; be a bit redundant, i believe that it makes the report more		;; be a bit redundant, i believe that it makes the report more
;; readable.		;; readable.
(let* ((table (gnc:make-html-table))		(let* ((table (gnc:make-html-table))
(spacer (gnc:make-html-table-cell))		(spacer (gnc:make-html-table-cell))
(list-of-balances (amount 'format gnc:make-gnc-monetary #f)))		(list-of-balances (amount 'format gnc:make-gnc-monetary #f)))
(gnc:html-table-cell-set-style! spacer "td"		(gnc:html-table-cell-set-style! spacer "td"
'attribute (list "style" "min-width: 1em"))		'attribute (list "style" "min-width: 1em"))
(for-each		(for-each
(lambda (bal)		(lambda (bal)
(gnc:html-table-append-row!		(gnc:html-table-append-row!
table (list (gnc:make-html-table-cell/markup "number-cell" bal)		table (list (gnc:make-html-table-cell/markup "number-cell" bal)
spacer		spacer
(gnc:make-html-table-cell/markup		(gnc:make-html-table-cell/markup
"number-cell" (exchange-fn bal report-commodity)))))		"number-cell" (exchange-fn bal report-commodity)))))
list-of-balances)		list-of-balances)
(gnc:html-table-set-style! table "table"		(gnc:html-table-set-style! table "table"
'attribute (list "style" "width:100%; max-width:2 0em")		'attribute (list "style" "width:100%; max-width:2 0em")
'attribute (list "cellpadding" "0"))		'attribute (list "cellpadding" "0"))
table))		table))
;;		;;
;; This function adds all the lines from a gnc:html-acct-table to a		;; This function adds all the lines from a gnc:html-acct-table to a
;; gnc:html-table in "labeled amount" form. IOW, it uses		;; gnc:html-table in "labeled amount" form. IOW, it uses
skipping to change at line 970		skipping to change at line 970
;; parent-account-balance-mode: 'immediate-bal 'recursive-bal ['omit-bal/#f]		;; parent-account-balance-mode: 'immediate-bal 'recursive-bal ['omit-bal/#f]
;; zero-balance-display-mode: ['show-balance] 'omit-balance		;; zero-balance-display-mode: ['show-balance] 'omit-balance
;; multicommodity-mode: [#f] 'table/#t		;; multicommodity-mode: [#f] 'table/#t
;; rule-mode: #t [#f] (not meant to affect subtotal rules)		;; rule-mode: #t [#f] (not meant to affect subtotal rules)
;;		;;
(define (gnc:html-table-add-account-balances		(define (gnc:html-table-add-account-balances
html-table ;; can be #f to create a new table		html-table ;; can be #f to create a new table
acct-table		acct-table
params)		params)
(let* ((num-rows (gnc:html-acct-table-num-rows acct-table))		(let* ((num-rows (gnc:html-acct-table-num-rows acct-table))
(rownum 0)		(rownum 0)
(html-table (or html-table (gnc:make-html-table)))		(html-table (or html-table (gnc:make-html-table)))
(get-val (lambda (alist key)		(get-val (lambda (alist key)
(let ((lst (assoc-ref alist key)))		(let ((lst (assoc-ref alist key)))
(if lst (car lst) lst))))		(if lst (car lst) lst))))
)		)
(while (< rownum num-rows)		(while (< rownum num-rows)
(let* ((env (append		(let* ((env (append
(gnc:html-acct-table-get-row-env acct-table rownum)		(gnc:html-acct-table-get-row-env acct-table rownum)
params))		params))
(acct (get-val env 'account))		(acct (get-val env 'account))
(children (get-val env 'account-children))		(children (get-val env 'account-children))
(label (get-val env 'account-label))		(label (get-val env 'account-label))
(acct-name (get-val env 'account-name)) ;; for diagnostics...		(acct-name (get-val env 'account-name)) ;; for diagnostics...
(report-commodity (get-val env 'report-commodity))		(report-commodity (get-val env 'report-commodity))
(exchange-fn (get-val env 'exchange-fn))		(exchange-fn (get-val env 'exchange-fn))
(account-cols (get-val env 'account-cols))		(account-cols (get-val env 'account-cols))
(logical-cols (get-val env 'logical-cols))		(logical-cols (get-val env 'logical-cols))
(label-cols (get-val env 'label-cols))		(label-cols (get-val env 'label-cols))
(logical-depth (get-val env 'logical-depth))		(logical-depth (get-val env 'logical-depth))
(display-depth (get-val env 'display-depth))		(display-depth (get-val env 'display-depth))
(display-tree-depth (get-val env 'display-tree-depth))		(display-tree-depth (get-val env 'display-tree-depth))
(row-type (get-val env 'row-type))		(row-type (get-val env 'row-type))
(rule-mode (and (equal? row-type 'subtotal-row)		(rule-mode (and (equal? row-type 'subtotal-row)
(get-val env 'rule-mode)))		(get-val env 'rule-mode)))
(row-markup (and (equal? row-type 'subtotal-row)		(row-markup (and (equal? row-type 'subtotal-row)
"primary-subheading"))		"primary-subheading"))
(multicommodity-mode (get-val env 'multicommodity-mode))		(multicommodity-mode (get-val env 'multicommodity-mode))
(limit-behavior		(limit-behavior
(or (get-val env 'depth-limit-behavior)		(or (get-val env 'depth-limit-behavior)
'summarize))		'summarize))
(parent-acct-bal-mode		(parent-acct-bal-mode
(or (get-val env 'parent-account-balance-mode)		(or (get-val env 'parent-account-balance-mode)
'omit-bal))		'omit-bal))
(bal-method		(bal-method
;; figure out how to calculate our balance:		;; figure out how to calculate our balance:
;; 'immediate-bal|'recursive-bal ('omit-bal handled below)		;; 'immediate-bal|'recursive-bal ('omit-bal handled below)
(cond ((eq? row-type 'subtotal-row) 'recursive-bal)		(cond ((eq? row-type 'subtotal-row) 'recursive-bal)
((eq? (1+ display-depth) display-tree-depth)		((eq? (1+ display-depth) display-tree-depth)
(cond ((eq? limit-behavior 'summarize) 'recursive-bal)		(cond ((eq? limit-behavior 'summarize) 'recursive-bal)
((null? children) 'immediate-bal)		((null? children) 'immediate-bal)
(else parent-acct-bal-mode)))		(else parent-acct-bal-mode)))
((not (null? children)) parent-acct-bal-mode)		((not (null? children)) parent-acct-bal-mode)
(else 'immediate-bal)))		(else 'immediate-bal)))
(zero-mode (let ((mode (get-val env 'zero-balance-display-mode )))		(zero-mode (let ((mode (get-val env 'zero-balance-display-mode )))
(if (boolean? mode) 'show-balance mode)))		(if (boolean? mode) 'show-balance mode)))
(amt (and-let* ((bal-syms '((immediate-bal . account-bal)		(amt (and-let* ((bal-syms '((immediate-bal . account-bal)
(recursive-bal . recursive-bal)		(recursive-bal . recursive-bal)
(omit-bal . #f)))		(omit-bal . #f)))
(bal-sym (assq-ref bal-syms bal-method))		(bal-sym (assq-ref bal-syms bal-method))
(comm-amt (get-val env bal-sym)))		(comm-amt (get-val env bal-sym)))
		(when (eq? zero-mode 'omit-balance)
		(comm-amt 'remove-zeros #f #f))
(cond		(cond
((and (eq? zero-mode 'omit-balance)		((and (eq? zero-mode 'omit-balance)
(gnc-commodity-collector-allzero? comm-amt)) #f)		(gnc-commodity-collector-allzero? comm-amt)) #f)
((gnc-reverse-balance acct)		((gnc-reverse-balance acct)
(gnc:commodity-collector-get-negated comm-amt))		(gnc:commodity-collector-get-negated comm-amt))
(else comm-amt))))		(else comm-amt))))
(amount		(amount
(cond		(cond
((not amt) #f)		((not amt) #f)
((and (not (gnc:uniform-commodity? amt report-commodity))		((and (not (gnc:uniform-commodity? amt report-commodity))
(eq? multicommodity-mode 'table)		(eq? multicommodity-mode 'table)
(eq? row-type 'account-row))		(eq? row-type 'account-row))
(gnc-commodity-table amt report-commodity exchange-fn))		(gnc-commodity-table amt report-commodity exchange-fn))
(else		(else
(gnc:sum-collector-commodity amt report-commodity exchange- fn))))		(gnc:sum-collector-commodity amt report-commodity exchange- fn))))
(indented-depth (get-val env 'indented-depth))		(indented-depth (get-val env 'indented-depth))
(account-colspan (get-val env 'account-colspan))		(account-colspan (get-val env 'account-colspan))
)		)
;; for each row do:		;; for each row do:
(gnc:html-table-add-labeled-amount-line!		(gnc:html-table-add-labeled-amount-line!
html-table		html-table
(+ account-cols logical-cols) ;; table-width		(+ account-cols logical-cols) ;; table-width
row-markup ;; row-markup		row-markup ;; row-markup
rule-mode		rule-mode
label		label
indented-depth		indented-depth
account-colspan ;; label-colspan		account-colspan ;; label-colspan
"anchor-cell" ;; label-markup		"anchor-cell" ;; label-markup
amount		amount
(+ account-cols (- 0 1)		(+ account-cols (- 0 1)
(- logical-cols display-depth)		(- logical-cols display-depth)
) ;; amount-depth		) ;; amount-depth
1 ;; amount-colspan		1 ;; amount-colspan
"number-cell" ;; amount-markup		"number-cell" ;; amount-markup
)		)
(set! rownum (+ rownum 1)) ;; increment rownum		(set! rownum (+ rownum 1)) ;; increment rownum
)		)
) ;; end of while		) ;; end of while
html-table		html-table
)		)
)		)
;; END		;; END
End of changes. 22 change blocks.
123 lines changed or deleted		126 lines changed or added

---