Merge branch 'maint'

This commit is contained in:
Christopher Lam 2019-09-21 13:56:10 +08:00
commit 7cdb79ccf2
19 changed files with 139 additions and 132 deletions

View File

@ -303,6 +303,25 @@
(define (gnc-commodity-collector-allzero? collector)
(every zero? (map cdr (collector 'format cons #f))))
;; (gnc:collector+ collectors ...) equiv to (+ collectors ...) and
;; outputs: a collector
(define (gnc:collector+ . collectors)
(let ((res (gnc:make-commodity-collector)))
(for-each (lambda (coll) (res 'merge coll #f)) collectors)
res))
;; (gnc:collectors- collectors ...) equiv to (- collectors ...), can
;; also negate single-argument collector. outputs collector
(define gnc:collector-
(case-lambda
(() (error "gnc:collector- needs at least 1 collector argument"))
((coll) (gnc:collector- (gnc:make-commodity-collector) coll))
((coll . rest)
(let ((res (gnc:make-commodity-collector)))
(res 'merge coll #f)
(res 'minusmerge (apply gnc:collector+ rest) #f)
res))))
;; add any number of gnc-monetary objects into a commodity-collector
;; usage: (gnc:monetaries-add monetary1 monetary2 ...)
;; output: a commodity-collector object
@ -341,7 +360,7 @@
(define (amount->monetary bal)
(gnc:make-gnc-monetary (xaccAccountGetCommodity account) bal))
(let loop ((splits (xaccAccountGetSplitList account))
(dates-list (stable-sort! dates-list <))
(dates-list (sort dates-list <))
(currentbal 0)
(lastbal 0)
(balancelist '()))

View File

@ -683,6 +683,8 @@
(export gnc:accounts-and-all-descendants)
(export gnc:make-value-collector)
(export gnc:make-commodity-collector)
(export gnc:collector+)
(export gnc:collector-)
(export gnc:commodity-collector-get-negated)
(export gnc:account-get-balances-at-dates)
(export gnc:account-get-comm-balance-at-date)

View File

@ -505,11 +505,7 @@
(validate (reverse
(gnc-account-get-children-sorted
(gnc-get-current-root-account))))))
(book (if selected-accounts
(gnc-account-get-book (if (pair? selected-accounts)
(car selected-accounts)
selected-accounts))
#f))
(book (gnc-get-current-book))
(generations (if (pair? selected-accounts)
(apply max (map (lambda (x) (num-generations x 1))
selected-accounts))
@ -772,12 +768,7 @@
(to-year (gnc-print-time64 to-value "%Y"))
(today-date (gnc-print-time64 (time64CanonicalDayTime (current-time))
"%d.%m.%Y"))
(tax-nr (unless book
(or
(gnc:option-get-value book gnc:*tax-label* gnc:*tax-nr-label*)
"")
""))
)
(tax-nr (gnc:option-get-value book gnc:*tax-label* gnc:*tax-nr-label*)))
;; Now, the main body
;; Reset all the balance collectors

View File

@ -961,9 +961,8 @@ also show overall period profit & loss."))
asset-liability
(lambda (acc)
(gnc:account-get-comm-value-at-date acc date #f))))
(unrealized (gnc:make-commodity-collector)))
(unrealized 'merge asset-liability-basis #f)
(unrealized 'minusmerge asset-liability-balance #f)
(unrealized (gnc:collector- asset-liability-basis
asset-liability-balance)))
(monetaries->exchanged
unrealized common-currency price-source date)))))
(retained-earnings-fn

View File

@ -317,17 +317,6 @@
(gnc-budget-get-account-period-actual-value budget acct period))
periodlist)))
(define (flatten lst)
(reverse!
(let loop ((lst lst) (result '()))
(if (null? lst)
result
(let ((elt (car lst))
(rest (cdr lst)))
(if (pair? elt)
(loop rest (append (loop elt '()) result))
(loop rest (cons elt result))))))))
;; Adds a line to the budget report.
;;
;; Parameters:
@ -342,7 +331,7 @@
column-list exchange-fn)
(let* ((comm (xaccAccountGetCommodity acct))
(reverse-balance? (gnc-reverse-balance acct))
(allperiods (filter number? (flatten column-list)))
(allperiods (filter number? (gnc:list-flatten column-list)))
(total-periods (if accumulate?
(iota (1+ (apply max allperiods)))
allperiods))
@ -396,6 +385,7 @@
budget acct total-periods))
(act-total (gnc:get-account-periodlist-actual-value
budget acct total-periods))
(act-total (if reverse-balance? (- act-total) act-total))
(dif-total (if income-acct?
(- act-total bgt-total)
(- bgt-total act-total))))

View File

@ -336,12 +336,6 @@ developing over time"))
c report-currency
(lambda (a b) (exchange-fn a b date)))))))
(define (collector-minus a b)
(let ((coll (gnc:make-commodity-collector)))
(coll 'merge a #f)
(coll 'minusmerge b #f)
coll))
;; copy of gnc:not-all-zeros using gnc-monetary
(define (not-all-zeros data)
(cond ((gnc:gnc-monetary? data) (not (zero? (gnc:gnc-monetary-amount data))))
@ -396,7 +390,7 @@ developing over time"))
(cdr dates-list)
(cons (if do-intervals?
(collector->monetary
(collector-minus (cadr list-of-mon-collectors)
(gnc:collector- (cadr list-of-mon-collectors)
(car list-of-mon-collectors))
(cadr dates-list))
(collector->monetary

View File

@ -261,11 +261,6 @@
(member (xaccSplitGetAccount s) accounts))
splits))))
(define (coll-minus minuend subtrahend)
(let ((coll (gnc:make-commodity-collector)))
(coll 'merge minuend #f)
(coll 'minusmerge subtrahend #f)
coll))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -347,7 +342,7 @@
(sales (gnc:commodity-collector-get-negated
(filter-splits splits sales-accounts)))
(expense (filter-splits splits expense-accounts))
(profit (coll-minus sales expense)))
(profit (gnc:collector- sales expense)))
(list owner profit sales expense)))
ownerlist))
(sortingtable '()))
@ -402,9 +397,10 @@
;; Add the "No Customer" lines to the sortingtable for sorting
;; as well
(let* ((other-sales (coll-minus toplevel-total-sales total-sales))
(other-expense (coll-minus toplevel-total-expense total-expense))
(other-profit (coll-minus other-sales other-expense)))
(let* ((other-sales (gnc:collector- toplevel-total-sales total-sales))
(other-expense (gnc:collector- toplevel-total-expense
total-expense))
(other-profit (gnc:collector- other-sales other-expense)))
(for-each
(lambda (comm)
(let* ((profit (cadr (other-profit 'getpair comm #f)))
@ -478,7 +474,8 @@
(gnc:make-html-text (gnc:html-markup/attr/no-end "hr" "noshade")))))
;; Summary lines - 1 per currency
(let ((total-profit (coll-minus toplevel-total-sales toplevel-total-expense)))
(let ((total-profit (gnc:collector- toplevel-total-sales
toplevel-total-expense)))
(for-each
(lambda (comm)
(let* ((profit (cadr (total-profit 'getpair comm #f)))

View File

@ -727,6 +727,7 @@ for styling the invoice. Please see the exported report for the CSS class names.
(fax (gnc:company-info book gnc:*company-fax*))
(email (gnc:company-info book gnc:*company-email*))
(url (gnc:company-info book gnc:*company-url*))
(taxnr (gnc:option-get-value book gnc:*tax-label* gnc:*tax-nr-label*))
(taxid (gnc:company-info book gnc:*company-id*)))
(if (and name (not (string-null? name)))
@ -764,6 +765,11 @@ for styling the invoice. Please see the exported report for the CSS class names.
(gnc:make-html-div/markup
"maybe-align-right company-tax-id" taxid))))
(if (and taxnr (not (string-null? taxnr)))
(gnc:html-table-append-row!
table (list (gnc:make-html-div/markup
"maybe-align-right company-tax-nr" taxnr))))
table))
(define (reg-renderer report-obj)

View File

@ -254,12 +254,6 @@
;; conversion function above. Returns a list of gnc-monetary.
(define (process-datelist account-balances dates left-col?)
(define (collector-minus coll1 coll2)
(let ((res (gnc:make-commodity-collector)))
(res 'merge coll1 #f)
(res 'minusmerge coll2 #f)
res))
(define accountlist
(if inc-exp?
(if left-col?
@ -297,7 +291,7 @@
(cons
(collector->monetary
(if inc-exp?
(collector-minus (car acct-balances) (cadr acct-balances))
(gnc:collector- (car acct-balances) (cadr acct-balances))
(car acct-balances))
(if inc-exp? (cadr dates) (car dates)))
result)))))

View File

@ -746,8 +746,8 @@
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-to-date))))
(book (gnc-account-get-book account))
(date-format (if (not (null? book)) (gnc:options-fancy-date book)))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date book))
(type (opt-val "__reg" "owner-type"))
(owner-descr (owner-string type))
(date-type (opt-val gnc:pagename-general optname-date-driver))

View File

@ -62,13 +62,15 @@
(define (test-trial-balance)
(let* ((options (gnc:make-report-options uuid))
(account-alist (create-test-data))
(gbp-bank (assoc-ref account-alist "GBP Bank"))
(usd-bank (assoc-ref account-alist "Bank"))
(expense (assoc-ref account-alist "Expenses"))
(equity (assoc-ref account-alist "Equity"))
(income (assoc-ref account-alist "Income"))
(bank (assoc-ref account-alist "Bank")))
(gnc-commodity-set-user-symbol
(xaccAccountGetCommodity (assoc-ref account-alist "GBP Bank"))
(xaccAccountGetCommodity gbp-bank)
"#")
(let ((closing-txn (env-transfer #f 30 06 2003 expense equity
@ -167,6 +169,18 @@
(sxml->table-row-col sxml 1 #f 10))
(test-equal "work-sheet bs credits"
' ("$3.00" "$2,356.00" "$2,359.00" "$760.00" "$3,119.00")
'("$3.00" "$2,356.00" "$2,359.00" "$760.00" "$3,119.00")
(sxml->table-row-col sxml 1 #f 11)))
))
;; A couple of transactions which involve foreign currency
;; conversions. We'll set the currencies to GBP and USD.
(env-transfer-foreign #f 15 01 2000 gbp-bank usd-bank
10 14 #:description "GBP 10 to USD 14")
(env-transfer-foreign #f 15 02 2000 usd-bank gbp-bank
9 8 #:description "USD 9 to GBP 8")
(set-option options "General" "Report variation" 'current)
(let ((sxml (options->sxml options "test-unrealized-gain")))
(test-equal "unrealized losses"
'("Unrealized Gains" "$3.25")
(sxml->table-row-col sxml 1 -2 #f)))))

View File

@ -152,9 +152,7 @@
(amt (and sum (gnc:gnc-monetary-amount sum)))
(neg? (and amt (negative? amt)))
(bal (if neg?
(let ((bal (gnc:make-commodity-collector)))
(bal 'minusmerge signed-balance #f)
bal)
(gnc:commodity-collector-get-negated signed-balance)
signed-balance))
(bal-sum (gnc:sum-collector-commodity
bal
@ -512,36 +510,21 @@
;;
;; This procedure returns a commodity collector.
(define (collect-unrealized-gains)
(define (acct->bal acct)
(gnc:account-get-comm-balance-at-date acct end-date #f))
(if (eq? price-source 'average-cost)
;; No need to calculate if doing valuation at cost.
(gnc:make-commodity-collector)
(let ((book-balance (gnc:make-commodity-collector))
(unrealized-gain-collector (gnc:make-commodity-collector))
(cost-fn (gnc:case-exchange-fn
'average-cost report-commodity end-date)))
;; Calculate book balance.
;; assets - liabilities - equity; normally 0
(for-each
(lambda (acct)
(book-balance
'merge
(gnc:account-get-comm-balance-at-date acct end-date #f)
#f))
all-accounts)
(let ((value (gnc:gnc-monetary-amount
(gnc:sum-collector-commodity
book-balance report-commodity exchange-fn)))
(cost (gnc:gnc-monetary-amount
(gnc:sum-collector-commodity
book-balance report-commodity cost-fn))))
(let* ((cost-fn (gnc:case-exchange-fn
'average-cost report-commodity end-date))
(acct-balances (map acct->bal all-accounts))
(book-balance (apply gnc:collector+ acct-balances))
(value (gnc:sum-collector-commodity
book-balance report-commodity exchange-fn))
(cost (gnc:sum-collector-commodity
book-balance report-commodity cost-fn)))
;; Get the unrealized gain or loss (value minus cost).
(unrealized-gain-collector
'add report-commodity (- value cost))
unrealized-gain-collector))))
(gnc:monetaries-add value (gnc:monetary-neg cost)))))
;; set default cell alignment
(gnc:html-table-set-style!
@ -667,12 +650,6 @@
splits)
total))
(define (coll-minus . collectors)
(let ((res (gnc:make-commodity-collector)))
(res 'merge (car collectors) #f)
(for-each (lambda (mon) (res 'minusmerge mon #f)) (cdr collectors))
res))
(while (< row rows)
(let* ((env (gnc:html-acct-table-get-row-env acct-table row))
(acct (get-val env 'account))
@ -684,21 +661,19 @@
(pos-adjusting
(and ga-or-is? (sum-account-splits acct adjusting-splits #t)))
(neg-adjusting
(and ga-or-is? (coll-minus adjusting pos-adjusting)))
(pre-closing-bal (coll-minus curr-bal closing))
(pre-adjusting-bal (coll-minus pre-closing-bal adjusting))
(atb (if is?
(let* ((debit (gnc:make-commodity-collector))
(credit (gnc:make-commodity-collector)))
(debit 'merge pos-adjusting #f)
(credit 'merge neg-adjusting #f)
(if (double-col
'credit-q pre-adjusting-bal
(and ga-or-is? (gnc:collector- adjusting pos-adjusting)))
(pre-closing-bal (gnc:collector- curr-bal closing))
(pre-adjusting-bal (gnc:collector- pre-closing-bal
adjusting))
(atb (cond ((not is?) pre-closing-bal)
((double-col 'credit-q pre-adjusting-bal
report-commodity exchange-fn show-fcur?)
(credit 'merge pre-adjusting-bal #f)
(debit 'merge pre-adjusting-bal #f))
(list debit credit))
pre-closing-bal)))
(list (gnc:collector+ pos-adjusting)
(gnc:collector+ neg-adjusting
pre-adjusting-bal)))
(else
(list (gnc:collector+ pos-adjusting pre-adjusting-bal)
(gnc:collector+ neg-adjusting))))))
;; curr-bal = account-bal with closing & adj entries
;; pre-closing-bal = account-bal with adj entries only
@ -865,8 +840,8 @@
(tot-abs-amt-cell bs-credits))
'())))
(if (eq? report-variant 'work-sheet)
(let* ((net-is (gnc:make-commodity-collector))
(net-bs (gnc:make-commodity-collector))
(let* ((net-is (gnc:collector- is-debits is-credits))
(net-bs (gnc:collector- bs-debits bs-credits))
(tot-is (gnc:make-commodity-collector))
(tot-bs (gnc:make-commodity-collector))
(is-entry #f)
@ -875,10 +850,6 @@
(bs-credit? #f)
(tbl-width (+ account-cols (* 2 bs-col) 2))
(this-row (gnc:html-table-num-rows build-table)))
(net-is 'merge is-debits #f)
(net-is 'minusmerge is-credits #f)
(net-bs 'merge bs-debits #f)
(net-bs 'minusmerge bs-credits #f)
(set! is-entry
(double-col 'entry net-is report-commodity exchange-fn show-fcur?))
(set! is-credit?

View File

@ -212,6 +212,21 @@
(gnc:make-gnc-monetary USD 25)
(coll-A 'getmonetary USD #f))
(test-equal "gnc:collector+"
'(("USD" . 50) ("GBP" . -20))
(collector->list
(gnc:collector+ coll-A coll-A coll-B)))
(test-equal "gnc:collector- 1 arg"
'(("GBP" . 20) ("USD" . -25))
(collector->list
(gnc:collector- coll-A)))
(test-equal "gnc:collector- 3 args"
'(("USD" . 25) ("GBP" . -60))
(collector->list
(gnc:collector- coll-A coll-B coll-B)))
(test-equal "gnc:commodity-collector-get-negated"
'(("USD" . -25) ("GBP" . 20))
(collector->list

View File

@ -276,6 +276,8 @@
(define gnc:*company-contact* (N_ "Company Contact Person"))
(define gnc:*fancy-date-label* (N_ "Fancy Date Format"))
(define gnc:*fancy-date-format* (N_ "custom"))
(define gnc:*tax-label* (N_ "Tax"))
(define gnc:*tax-nr-label* (N_ "Tax Number"))
(define (gnc:company-info book key)
;; Access company info from key-value pairs for current book
@ -304,6 +306,7 @@
gnc:*option-name-currency-accounting* gnc:*option-name-book-currency*
gnc:*option-name-default-gains-policy*
gnc:*option-name-default-gain-loss-account*
gnc:*tax-label* gnc:*tax-nr-label*
gnc:*option-name-auto-readonly-days* gnc:*option-name-num-field-source*)
(define gnc:*option-section-budgeting* OPTION-SECTION-BUDGETING)

View File

@ -157,6 +157,12 @@
gnc:*option-section-budgeting* gnc:*option-name-default-budget*
"a" (N_ "Budget to be used when none has been otherwise specified.")))
;; Tax Tab
(reg-option
(gnc:make-string-option
gnc:*tax-label* gnc:*tax-nr-label*
"a" (N_ "The electronic tax number of your business") ""))
;; Counters Tab
(for-each
(lambda (vals)

View File

@ -10,6 +10,7 @@
(test-traverse-vec)
(test-substring-replace)
(test-sort-and-delete-duplicates)
(test-gnc:list-flatten)
(test-begin "test-libgnucash-scm-utilities.scm"))
(define (test-traverse-vec)
@ -87,3 +88,14 @@
'(1 2 3)
(sort-and-delete-duplicates '(3 1 2) <))
(test-end "sort-and-delete-duplicates"))
(define (test-gnc:list-flatten)
(test-equal "gnc:list-flatten null"
'()
(gnc:list-flatten '()))
(test-equal "gnc:list-flatten noop"
'(1 2 3)
(gnc:list-flatten '(1 2 3)))
(test-equal "gnc:list-flatten deep"
'(1 2 3 4 5 6)
(gnc:list-flatten '(1 (2) (() () (((((3))) ())) 4 () ((5) (6)))))))

View File

@ -47,6 +47,7 @@
(export gnc:debug)
(export addto!)
(export sort-and-delete-duplicates)
(export gnc:list-flatten)
;; Do this stuff very early -- but other than that, don't add any
;; executable code until the end of the file if you can help it.
@ -191,6 +192,17 @@
(define (kons a b) (if (and (pair? b) (= a (car b))) b (cons a b)))
(reverse (fold kons '() (sort lst <))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; flattens an arbitrary deep nested list into simple list. this is
;; probably the most efficient algorithm available. '(1 2 (3 4)) -->
;; '(1 2 3 4)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:list-flatten . lst)
(reverse
(let lp ((e lst) (accum '()))
(if (list? e)
(fold lp accum e)
(cons e accum)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility hack for fixing guile-2.0 string handling. this code

View File

@ -49,10 +49,5 @@
(export txf-asset-categories)
(export txf-liab-eq-categories)
(define gnc:*tax-label* (N_ "Tax"))
(define gnc:*tax-nr-label* (N_ "Tax Number"))
(export gnc:*tax-label* gnc:*tax-nr-label*)
(load-from-path "gnucash/locale/de_DE/tax/txf")
(load-from-path "gnucash/locale/de_DE/tax/txf-help")

View File

@ -312,16 +312,3 @@ Fehlermeldungen + Dankschreiben an: stoll@bomhardt.de"))
)
)
))
;;; Register global options in this book
(define (book-options-generator options)
(define (reg-option new-option)
(gnc:register-option options new-option))
(reg-option
(gnc:make-string-option
gnc:*tax-label* gnc:*tax-nr-label*
"a" (N_ "The electronic tax number of your business") ""))
)
(gnc-register-kvp-option-generator QOF-ID-BOOK-SCM book-options-generator)