mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Merge branch 'maint'
This commit is contained in:
Christopher Lam
commit
720f176417
@ -325,7 +325,7 @@ else(GUILE22_FOUND)
|
||||
message(STATUS "Using guile-2.0.x")
|
||||
find_program (GUILE_EXECUTABLE NAMES guile2.0 guile)
|
||||
else(GUILE2_FOUND)
|
||||
message (FATAL_ERROR "Neither guile 2.2 nor guile 2.0 were found GnuCash can't run without one of them. Ensure that one is installed and can be found with pgk-config.")
|
||||
message (FATAL_ERROR "Neither guile 2.2 nor guile 2.0 were found GnuCash can't run without one of them. Ensure that one is installed and can be found with pkg-config.")
|
||||
endif(GUILE2_FOUND)
|
||||
endif(GUILE22_FOUND)
|
||||
|
||||
|
||||
@ -140,7 +140,7 @@ function(gnc_gtest_configure)
|
||||
find_package(Threads REQUIRED)
|
||||
set(GTEST_FOUND YES CACHE INTERNAL "Found GTest")
|
||||
if(GTEST_SHARED_LIB)
|
||||
set(GTEST_LIB "${GTEST_SHARED_LIB};${GTEST_MAIN_LIB}" PARENT_SCOPE)
|
||||
set(GTEST_LIB "${GTEST_MAIN_LIB};${GTEST_SHARED_LIB}" PARENT_SCOPE)
|
||||
unset(GTEST_SRC_DIR CACHE)
|
||||
else()
|
||||
set(GTEST_SRC "${GTEST_SRC_DIR}/src/gtest_main.cc" PARENT_SCOPE)
|
||||
|
||||
@ -2694,9 +2694,8 @@ gnc_option_set_ui_widget_account_sel (GNCOption *option, GtkBox *page_box,
|
||||
G_CALLBACK(gnc_option_changed_widget_cb), option);
|
||||
|
||||
gnc_option_set_widget (option, value);
|
||||
/* DOCUMENT ME: Why is the only option type that sets use_default to
|
||||
TRUE? */
|
||||
gnc_option_set_ui_value(option, TRUE);
|
||||
|
||||
gnc_option_set_ui_value(option, FALSE);
|
||||
|
||||
*enclosing = gtk_box_new (GTK_ORIENTATION_HORIZONTAL, 5);
|
||||
gtk_box_set_homogeneous (GTK_BOX (*enclosing), FALSE);
|
||||
|
||||
@ -263,27 +263,21 @@
|
||||
;; pricelist comes from
|
||||
;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or,
|
||||
;; if pricelist was empty, #f.
|
||||
(define (gnc:pricelist-price-find-nearest
|
||||
pricelist date)
|
||||
(let* ((later (find (lambda (p)
|
||||
(< date (car p)))
|
||||
pricelist))
|
||||
(earlierlist (take-while
|
||||
(lambda (p)
|
||||
(>= date (car p)))
|
||||
pricelist))
|
||||
(earlier (and (not (null? earlierlist))
|
||||
(last earlierlist))))
|
||||
|
||||
(if (and earlier later)
|
||||
(if (< (abs (- date (car earlier)))
|
||||
(abs (- date (car later))))
|
||||
(cadr earlier)
|
||||
(cadr later))
|
||||
(or
|
||||
(and earlier (cadr earlier))
|
||||
(and later (cadr later))))))
|
||||
|
||||
(define (gnc:pricelist-price-find-nearest pricelist date)
|
||||
(let lp ((pricelist pricelist))
|
||||
(cond
|
||||
((null? pricelist) #f)
|
||||
((null? (cdr pricelist)) (cadr (car pricelist)))
|
||||
(else
|
||||
(let ((earlier (car pricelist))
|
||||
(later (cadr pricelist)))
|
||||
(cond
|
||||
((< (car later) date)
|
||||
(lp (cdr pricelist)))
|
||||
((< (- date (car earlier)) (- (car later) date))
|
||||
(cadr earlier))
|
||||
(else
|
||||
(cadr later))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Functions to get one price at a given time (i.e. not time-variant).
|
||||
@ -779,9 +773,19 @@
|
||||
;; the value of 'source-option', whose possible values are set in
|
||||
;; gnc:options-add-price-source!.
|
||||
;;
|
||||
;; <int> start-percent, delta-percent: Fill in the [start:start+delta]
|
||||
;; arguments:
|
||||
;; source-option: symbol 'average-cost 'weighted-average
|
||||
;; 'pricedb-nearest 'pricedb-latest
|
||||
;; report-currency: the target currency
|
||||
;; commodity-list: the list of commodities to generate an exchange-fn for
|
||||
;; to-date-tp (time64): last date to analyse transactions
|
||||
;; start-percent, delta-percent: Fill in the [start:start+delta]
|
||||
;; section of the progress bar while running this function.
|
||||
;;
|
||||
;; returns: a function which takes 3 arguments, and returns a gnc-monetary
|
||||
;; foreign - foreign commodity/currency
|
||||
;; domestic - a gnc-monetary pair
|
||||
;; date - time64 price
|
||||
(define (gnc:case-exchange-time-fn
|
||||
source-option report-currency commodity-list to-date-tp
|
||||
start-percent delta-percent)
|
||||
|
||||
@ -939,6 +939,7 @@
|
||||
;; utility function for testing. dumps the whole book contents to
|
||||
;; console.
|
||||
(define (gnc:dump-book)
|
||||
(display "\n(gnc:dump-book)\n")
|
||||
(for-each
|
||||
(lambda (acc)
|
||||
(format #t "\nAccount: <~a> Comm<~a> Type<~a>\n"
|
||||
@ -950,7 +951,8 @@
|
||||
(for-each
|
||||
(lambda (s)
|
||||
(let ((txn (xaccSplitGetParent s)))
|
||||
(format #t " Split: ~a Amt<~a> Val<~a> Desc<~a>\n"
|
||||
(format #t "~a Split: ~a Amt<~a> Val<~a> Desc<~a> Memo<~a>\n"
|
||||
(xaccSplitGetReconcile s)
|
||||
(qof-print-date (xaccTransGetDate txn))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
@ -960,13 +962,28 @@
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccTransGetCurrency txn)
|
||||
(xaccSplitGetValue s)))
|
||||
(xaccTransGetDescription txn))))
|
||||
(xaccAccountGetSplitList acc)))
|
||||
(xaccTransGetDescription txn)
|
||||
(xaccSplitGetMemo s))))
|
||||
(xaccAccountGetSplitList acc))
|
||||
(format #t "Balance: ~a Cleared: ~a Reconciled: ~a\n"
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccAccountGetCommodity acc)
|
||||
(xaccAccountGetBalance acc)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccAccountGetCommodity acc)
|
||||
(xaccAccountGetClearedBalance acc)))
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccAccountGetCommodity acc)
|
||||
(xaccAccountGetReconciledBalance acc)))))
|
||||
(gnc-account-get-descendants-sorted
|
||||
(gnc-get-current-root-account))))
|
||||
|
||||
;; dump all invoices posted into an AP/AR account
|
||||
(define (gnc:dump-invoices)
|
||||
(display "\n(gnc:dump-invoices)\n")
|
||||
(let* ((acc-APAR (filter (compose xaccAccountIsAPARType xaccAccountGetType)
|
||||
(gnc-account-get-descendants-sorted
|
||||
(gnc-get-current-root-account))))
|
||||
@ -984,7 +1001,7 @@
|
||||
(gncInvoiceGetCurrency inv) amt)))
|
||||
(for-each
|
||||
(lambda (inv)
|
||||
(format #t "\nInvoice: ID<~a> Owner<~a> Account<~a>\n"
|
||||
(format #t "Invoice: ID<~a> Owner<~a> Account<~a>\n"
|
||||
(gncInvoiceGetID inv)
|
||||
(gncOwnerGetName (gncInvoiceGetOwner inv))
|
||||
(xaccAccountGetName (gncInvoiceGetPostedAcc inv)))
|
||||
|
||||
@ -149,6 +149,121 @@
|
||||
(_ "Loss") (_ "Profit") ))
|
||||
|
||||
|
||||
(define (analyze-splits splits balances daily-dates interval-dates
|
||||
internal-included exchange-fn report-currency)
|
||||
;; this is a tight loop. start with: daily-balances & daily-dates,
|
||||
;; interval-dates, and the splitlist. traverse the daily balances
|
||||
;; and splitlist until we cross an interval date boundary, then
|
||||
;; summarize the interval-balances and interval-amounts
|
||||
(define work-to-do (length splits))
|
||||
(let loop ((results '())
|
||||
(interval-bals '())
|
||||
(interval-amts '())
|
||||
(splits splits)
|
||||
(work-done 0)
|
||||
(daily-balances (cdr balances))
|
||||
(daily-dates (cdr daily-dates))
|
||||
(interval-start (car interval-dates))
|
||||
(interval-dates (cdr interval-dates)))
|
||||
|
||||
(cond
|
||||
;; daily-dates finished. job done. add details for last-interval
|
||||
;; which must be handled separately, and return to caller
|
||||
((null? daily-dates)
|
||||
(reverse
|
||||
(cons (list
|
||||
(qof-print-date interval-start)
|
||||
(qof-print-date (car interval-dates))
|
||||
(/ (apply + interval-bals)
|
||||
(length interval-bals))
|
||||
(apply max interval-bals)
|
||||
(apply min interval-bals)
|
||||
(apply + (filter positive? interval-amts))
|
||||
(- (apply + (filter negative? interval-amts)))
|
||||
(apply + interval-amts))
|
||||
results)))
|
||||
|
||||
;; first daily-date > first interval-date -- crossed interval
|
||||
;; boundary -- add interval details to results
|
||||
((> (car daily-dates) (car interval-dates))
|
||||
(gnc:report-percent-done (* 100 (/ work-done work-to-do)))
|
||||
(loop (cons (list
|
||||
(qof-print-date interval-start)
|
||||
(qof-print-date (decdate (car interval-dates)
|
||||
DayDelta))
|
||||
(/ (apply + interval-bals)
|
||||
(length interval-bals))
|
||||
(apply max interval-bals)
|
||||
(apply min interval-bals)
|
||||
(apply + (filter positive? interval-amts))
|
||||
(- (apply + (filter negative? interval-amts)))
|
||||
(apply + interval-amts))
|
||||
results) ;process interval amts&bals
|
||||
'() ;reset interval-bals
|
||||
'() ;and interval-amts
|
||||
splits
|
||||
work-done
|
||||
daily-balances
|
||||
daily-dates
|
||||
(car interval-dates)
|
||||
(cdr interval-dates)))
|
||||
|
||||
;; we're still within interval, no more splits left within
|
||||
;; current interval. add daily balance to interval.
|
||||
((or (null? splits)
|
||||
(> (xaccTransGetDate (xaccSplitGetParent (car splits)))
|
||||
(car interval-dates)))
|
||||
(loop results
|
||||
(cons (car daily-balances) interval-bals)
|
||||
interval-amts
|
||||
splits
|
||||
work-done
|
||||
(cdr daily-balances)
|
||||
(cdr daily-dates)
|
||||
interval-start
|
||||
interval-dates))
|
||||
|
||||
;; we're still within interval. 'internal' is disallowed; there
|
||||
;; are at least 2 splits remaining, both from the same
|
||||
;; transaction. skip them. NOTE we should really expand this
|
||||
;; conditional whereby all splits are internal, however the
|
||||
;; option is labelled as 2-splits only. best maintain behaviour.
|
||||
((and (not internal-included)
|
||||
(pair? (cdr splits))
|
||||
(= 2 (xaccTransCountSplits (xaccSplitGetParent (car splits))))
|
||||
(equal? (xaccSplitGetParent (car splits))
|
||||
(xaccSplitGetParent (cadr splits))))
|
||||
(loop results
|
||||
interval-bals
|
||||
interval-amts ;interval-amts unchanged
|
||||
(cddr splits) ;skip two splits.
|
||||
(+ 2 work-done)
|
||||
daily-balances
|
||||
daily-dates
|
||||
interval-start
|
||||
interval-dates))
|
||||
|
||||
;; we're still within interval. there are splits remaining. add
|
||||
;; split details to interval-amts
|
||||
(else
|
||||
(loop results
|
||||
interval-bals
|
||||
(cons (gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount (car splits)))
|
||||
(xaccSplitGetAmount (car splits)))
|
||||
report-currency
|
||||
(car interval-dates)))
|
||||
interval-amts) ;add split amt to list
|
||||
(cdr splits) ;and loop to next split
|
||||
(1+ work-done)
|
||||
daily-balances
|
||||
daily-dates
|
||||
interval-start
|
||||
interval-dates)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Renderer
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
@ -168,7 +283,8 @@
|
||||
(enddate (gnc:time64-end-day-time
|
||||
(gnc:date-option-absolute-time
|
||||
(get-option gnc:pagename-general optname-to-date))))
|
||||
(stepsize (gnc:deltasym-to-delta (get-option gnc:pagename-general optname-stepsize)))
|
||||
(stepsize (gnc:deltasym-to-delta
|
||||
(get-option gnc:pagename-general optname-stepsize)))
|
||||
(report-currency (get-option gnc:pagename-general
|
||||
optname-report-currency))
|
||||
(price-source (get-option gnc:pagename-general
|
||||
@ -267,128 +383,14 @@
|
||||
(exchange-fn monetary target-curr date)))))
|
||||
(iota work-to-do)
|
||||
daily-dates
|
||||
(apply zip accounts-balances)))
|
||||
(apply zip accounts-balances))))
|
||||
|
||||
;; for upcoming interval-calculators
|
||||
(work-to-do (length splits)))
|
||||
(qof-query-destroy query)
|
||||
|
||||
;; this is a complicated tight loop. start with:
|
||||
;; daily-balances & daily-dates, interval-dates, and the
|
||||
;; splitlist. traverse the daily balances and splitlist
|
||||
;; until we cross an interval date boundary, then
|
||||
;; summarize the interval-balances and interval-amounts
|
||||
(let loop ((results '())
|
||||
(interval-bals '())
|
||||
(interval-amts '())
|
||||
(splits splits)
|
||||
(work-done 0)
|
||||
(daily-balances (cdr balances))
|
||||
(daily-dates (cdr daily-dates))
|
||||
(interval-start (car interval-dates))
|
||||
(interval-dates (cdr interval-dates)))
|
||||
|
||||
(cond
|
||||
|
||||
;; daily-dates finished. job done. add details for
|
||||
;; last-interval which must be handled separately.
|
||||
((null? daily-dates)
|
||||
(set! data
|
||||
(reverse!
|
||||
(cons (list
|
||||
(qof-print-date interval-start)
|
||||
(qof-print-date (car interval-dates))
|
||||
(/ (apply + interval-bals)
|
||||
(length interval-bals))
|
||||
(apply max interval-bals)
|
||||
(apply min interval-bals)
|
||||
(apply + (filter positive? interval-amts))
|
||||
(- (apply + (filter negative? interval-amts)))
|
||||
(apply + interval-amts))
|
||||
results))))
|
||||
|
||||
;; first daily-date > first interval-date -- crossed
|
||||
;; interval boundary -- add interval details to results
|
||||
((> (car daily-dates) (car interval-dates))
|
||||
(gnc:report-percent-done (* 100 (/ work-done work-to-do)))
|
||||
(loop (cons (list
|
||||
(qof-print-date interval-start)
|
||||
(qof-print-date (decdate (car interval-dates)
|
||||
DayDelta))
|
||||
(/ (apply + interval-bals)
|
||||
(length interval-bals))
|
||||
(apply max interval-bals)
|
||||
(apply min interval-bals)
|
||||
(apply + (filter positive? interval-amts))
|
||||
(- (apply + (filter negative? interval-amts)))
|
||||
(apply + interval-amts))
|
||||
results) ;process interval amts&bals
|
||||
'() ;reset interval-bals
|
||||
'() ;and interval-amts
|
||||
splits
|
||||
work-done
|
||||
daily-balances
|
||||
daily-dates
|
||||
(car interval-dates)
|
||||
(cdr interval-dates)))
|
||||
|
||||
;; we're still within interval, no more splits left
|
||||
;; within current interval. add daily balance to
|
||||
;; interval.
|
||||
((or (null? splits)
|
||||
(> (xaccTransGetDate (xaccSplitGetParent (car splits)))
|
||||
(car interval-dates)))
|
||||
(loop results
|
||||
(cons (car daily-balances) interval-bals)
|
||||
interval-amts
|
||||
splits
|
||||
work-done
|
||||
(cdr daily-balances)
|
||||
(cdr daily-dates)
|
||||
interval-start
|
||||
interval-dates))
|
||||
|
||||
;; we're still within interval. 'internal' is
|
||||
;; disallowed; there are at least 2 splits remaining,
|
||||
;; both from the same transaction. skip them. NOTE we
|
||||
;; should really expand this conditional whereby all
|
||||
;; splits are internal, however the option is labelled
|
||||
;; as 2-splits only. best maintain current behaviour.
|
||||
((and (not internal-included)
|
||||
(pair? (cdr splits))
|
||||
(= 2 (xaccTransCountSplits (xaccSplitGetParent (car splits))))
|
||||
(equal? (xaccSplitGetParent (car splits))
|
||||
(xaccSplitGetParent (cadr splits))))
|
||||
(loop results
|
||||
interval-bals
|
||||
interval-amts ;interval-amts unchanged
|
||||
(cddr splits) ;skip two splits.
|
||||
(+ work-done 2)
|
||||
daily-balances
|
||||
daily-dates
|
||||
interval-start
|
||||
interval-dates))
|
||||
|
||||
;; we're still within interval. there are splits
|
||||
;; remaining. add split details to interval-amts
|
||||
(else
|
||||
(loop results
|
||||
interval-bals
|
||||
(cons (gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary
|
||||
(xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount (car splits)))
|
||||
(xaccSplitGetAmount (car splits)))
|
||||
report-currency
|
||||
(car interval-dates)))
|
||||
interval-amts) ;add split amt to list
|
||||
(cdr splits) ;and loop to next split
|
||||
(1+ work-done)
|
||||
daily-balances
|
||||
daily-dates
|
||||
interval-start
|
||||
interval-dates)))))
|
||||
(unless (null? splits)
|
||||
(set! data
|
||||
(analyze-splits splits balances daily-dates interval-dates
|
||||
internal-included exchange-fn report-currency))))
|
||||
|
||||
(gnc:report-percent-done 70)
|
||||
|
||||
|
||||
@ -781,20 +781,30 @@ also show overall period profit & loss."))
|
||||
price-source common-currency
|
||||
(map xaccAccountGetCommodity accounts) enddate
|
||||
#f #f)))
|
||||
|
||||
;; this function will convert the monetary found at col-idx
|
||||
;; into report-currency if the latter exists. The price
|
||||
;; applicable the the col-idx column is used. If the monetary
|
||||
;; cannot be converted (eg. missing price) then it is not converted.
|
||||
(convert-curr-fn (lambda (monetary col-idx)
|
||||
(and common-currency
|
||||
(not (gnc-commodity-equal
|
||||
(gnc:gnc-monetary-commodity monetary)
|
||||
common-currency))
|
||||
(has-price? (gnc:gnc-monetary-commodity monetary))
|
||||
(let* ((date (case price-source
|
||||
((pricedb-latest) (current-time))
|
||||
(else
|
||||
(list-ref report-dates
|
||||
(case report-type
|
||||
((balsheet) col-idx)
|
||||
((pnl) (1+ col-idx))))))))
|
||||
(let ((date
|
||||
(cond
|
||||
((eq? price-source 'pricedb-latest)
|
||||
(current-time))
|
||||
((eq? col-idx 'overall-period)
|
||||
(last report-dates))
|
||||
(else
|
||||
(list-ref report-dates
|
||||
(case report-type
|
||||
((balsheet) col-idx)
|
||||
((pnl) (1+ col-idx))))))))
|
||||
(exchange-fn monetary common-currency date)))))
|
||||
|
||||
;; the following function generates an gnc:html-text object
|
||||
;; to dump exchange rate for a particular column. From the
|
||||
;; accountlist given, obtain commodities, and convert 1 unit
|
||||
|
||||
@ -84,110 +84,15 @@
|
||||
(vat-purchases (cdr (assoc "VAT-on-Purchases" account-alist)))
|
||||
(receivable (cdr (assoc "A/Receivable" account-alist)))
|
||||
(YEAR (gnc:time64-get-year (gnc:get-today)))
|
||||
|
||||
(cust-1 (let ((cust-1 (gncCustomerCreate (gnc-get-current-book))))
|
||||
(gncCustomerSetID cust-1 "cust-1-id")
|
||||
(gncCustomerSetName cust-1 "cust-1-name")
|
||||
(gncCustomerSetNotes cust-1 "cust-1-notes")
|
||||
(gncCustomerSetCurrency cust-1 (gnc-default-report-currency))
|
||||
(gncCustomerSetTaxIncluded cust-1 1) ;1 = GNC-TAXINCLUDED-YES
|
||||
cust-1))
|
||||
|
||||
(owner-1 (let ((owner-1 (gncOwnerNew)))
|
||||
(gncOwnerInitCustomer owner-1 cust-1)
|
||||
owner-1))
|
||||
|
||||
;; inv-1 is generated for a customer
|
||||
(inv-1 (let ((inv-1 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-1 owner-1)
|
||||
(gncInvoiceSetNotes inv-1 "inv-1-notes")
|
||||
(gncInvoiceSetBillingID inv-1 "inv-1-billing-id")
|
||||
inv-1))
|
||||
|
||||
(job-1 (let ((job-1 (gncJobCreate (gnc-get-current-book))))
|
||||
(gncJobSetID job-1 "job-1-id")
|
||||
(gncJobSetName job-1 "job-1-name")
|
||||
(gncJobSetOwner job-1 owner-1)
|
||||
job-1))
|
||||
|
||||
(owner-2 (let ((owner-2 (gncOwnerNew)))
|
||||
(gncOwnerInitJob owner-2 job-1)
|
||||
owner-2))
|
||||
|
||||
;; inv-2 is generated from a customer's job
|
||||
(inv-2 (let ((inv-2 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-2 owner-2)
|
||||
(gncInvoiceSetNotes inv-2 "inv-2-notes")
|
||||
inv-2))
|
||||
|
||||
(vend-1 (let ((vend-1 (gncVendorCreate (gnc-get-current-book))))
|
||||
(gncVendorSetID vend-1 "vend-1-id")
|
||||
(gncVendorSetName vend-1 "vend-1-name")
|
||||
(gncVendorSetNotes vend-1 "vend-1-notes")
|
||||
(gncVendorSetCurrency vend-1 (gnc-default-report-currency))
|
||||
(gncVendorSetTaxIncluded vend-1 1) ;1 = GNC-TAXINCLUDED-YES
|
||||
vend-1))
|
||||
|
||||
(owner-3 (let ((owner-3 (gncOwnerNew)))
|
||||
(gncOwnerInitVendor owner-3 vend-1)
|
||||
owner-3))
|
||||
|
||||
;; inv-3 is generated from a vendor
|
||||
(inv-3 (let ((inv-3 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-3 owner-3)
|
||||
(gncInvoiceSetNotes inv-3 "inv-3-notes")
|
||||
inv-3))
|
||||
|
||||
(emp-1 (let ((emp-1 (gncEmployeeCreate (gnc-get-current-book))))
|
||||
(gncEmployeeSetID emp-1 "emp-1-id")
|
||||
(gncEmployeeSetCurrency emp-1 (gnc-default-report-currency))
|
||||
(gncEmployeeSetName emp-1 "emp-1-name")
|
||||
emp-1))
|
||||
|
||||
(owner-4 (let ((owner-4 (gncOwnerNew)))
|
||||
(gncOwnerInitEmployee owner-4 emp-1)
|
||||
owner-4))
|
||||
|
||||
;; inv-4 is generated for an employee
|
||||
(inv-4 (let ((inv-4 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-4 owner-4)
|
||||
(gncInvoiceSetNotes inv-4 "inv-4-notes")
|
||||
inv-4))
|
||||
|
||||
;; inv-5 cust-credit-note
|
||||
(inv-5 (let ((inv-5 (gncInvoiceCopy inv-1)))
|
||||
(gncInvoiceSetIsCreditNote inv-5 #t)
|
||||
inv-5))
|
||||
|
||||
;; inv-6 vend-credit-note
|
||||
(inv-6 (let ((inv-6 (gncInvoiceCopy inv-3)))
|
||||
(gncInvoiceSetIsCreditNote inv-6 #t)
|
||||
inv-6))
|
||||
|
||||
;; inv-7 emp-credit-note
|
||||
(inv-7 (let ((inv-7 (gncInvoiceCopy inv-4)))
|
||||
(gncInvoiceSetIsCreditNote inv-7 #t)
|
||||
inv-7))
|
||||
|
||||
(standard-vat-sales-tt (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt "10% vat on sales")
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-sales)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry 10)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt))
|
||||
|
||||
(standard-vat-purchases-tt (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt "10% vat on purchases")
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-purchases)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry 10)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt)))
|
||||
(invoices (create-test-invoice-data))
|
||||
(inv-1 (vector-ref invoices 0))
|
||||
(inv-2 (vector-ref invoices 1))
|
||||
(inv-3 (vector-ref invoices 2))
|
||||
(inv-4 (vector-ref invoices 3))
|
||||
(inv-5 (vector-ref invoices 4))
|
||||
(inv-6 (vector-ref invoices 5))
|
||||
(inv-7 (vector-ref invoices 6))
|
||||
(inv-8 (vector-ref invoices 7)))
|
||||
|
||||
(define* (default-testing-options inv #:optional (setting #t))
|
||||
(let ((options (gnc:make-report-options uuid)))
|
||||
@ -196,7 +101,7 @@
|
||||
(lambda (disp-col-name)
|
||||
(set-option! options "Display Columns" disp-col-name setting))
|
||||
'("Date" "Description" "Action" "Quantity" "Price" "Discount"
|
||||
"Taxable" "Tax Amount" "Total"))
|
||||
"Taxable" "Tax Amount" "Total"))
|
||||
(for-each
|
||||
(lambda (disp-col-name)
|
||||
(set-option! options "Display" disp-col-name setting))
|
||||
@ -206,17 +111,6 @@
|
||||
"Payments" "Job Details"))
|
||||
options))
|
||||
|
||||
;; entry-1 2 widgets of $3 = $6
|
||||
(let ((entry-1 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-1 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-1 "entry-1-desc")
|
||||
(gncEntrySetAction entry-1 "entry-1-action")
|
||||
(gncEntrySetNotes entry-1 "entry-1-notes")
|
||||
(gncEntrySetInvAccount entry-1 income)
|
||||
(gncEntrySetDocQuantity entry-1 2 #f)
|
||||
(gncEntrySetInvPrice entry-1 3)
|
||||
(gncInvoiceAddEntry inv-1 entry-1))
|
||||
|
||||
(test-begin "inv-1 simple entry")
|
||||
(let* ((options (default-testing-options inv-1))
|
||||
(sxml (options->sxml options "inv-1 simple entry")))
|
||||
@ -251,27 +145,6 @@
|
||||
(test-end "inv-1 simple entry, sparse options")
|
||||
|
||||
(test-begin "inv-2")
|
||||
(let ((entry-2 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-2 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-2 "entry-2-desc")
|
||||
(gncEntrySetAction entry-2 "entry-2-action")
|
||||
(gncEntrySetNotes entry-2 "entry-2-notes")
|
||||
(gncEntrySetInvAccount entry-2 income)
|
||||
(gncEntrySetInvTaxable entry-2 #f)
|
||||
(gncEntrySetDocQuantity entry-2 5 #f)
|
||||
(gncEntrySetInvPrice entry-2 11)
|
||||
(gncEntrySetInvDiscount entry-2 10)
|
||||
(gncInvoiceAddEntry inv-1 entry-2))
|
||||
;; entry-inv-2 2 widgets of $3 = $6
|
||||
(let ((entry-inv-2 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-2 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-2 "entry-inv-2-desc")
|
||||
(gncEntrySetAction entry-inv-2 "entry-inv-2-action")
|
||||
(gncEntrySetNotes entry-inv-2 "entry-inv-2-notes")
|
||||
(gncEntrySetInvAccount entry-inv-2 income)
|
||||
(gncEntrySetDocQuantity entry-inv-2 2 #f)
|
||||
(gncEntrySetInvPrice entry-inv-2 3)
|
||||
(gncInvoiceAddEntry inv-2 entry-inv-2))
|
||||
(let* ((options (default-testing-options inv-2))
|
||||
(sxml (options->sxml options "inv-2 simple entry")))
|
||||
(test-equal "inv-2 simple entry amounts are correct"
|
||||
@ -298,16 +171,6 @@
|
||||
(test-end "inv-2")
|
||||
|
||||
(test-begin "inv-3")
|
||||
;; entry-inv-3 2 widgets of $3 = $6
|
||||
(let ((entry-inv-3 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-3 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-3 "entry-inv-3-desc")
|
||||
(gncEntrySetAction entry-inv-3 "entry-inv-3-action")
|
||||
(gncEntrySetNotes entry-inv-3 "entry-inv-3-notes")
|
||||
(gncEntrySetInvAccount entry-inv-3 income)
|
||||
(gncEntrySetDocQuantity entry-inv-3 2 #f)
|
||||
(gncEntrySetBillPrice entry-inv-3 3)
|
||||
(gncInvoiceAddEntry inv-3 entry-inv-3))
|
||||
(let* ((options (default-testing-options inv-3))
|
||||
(sxml (options->sxml options "inv-3 simple entry")))
|
||||
(test-equal "inv-3 simple entry amounts are correct"
|
||||
@ -325,18 +188,7 @@
|
||||
((sxpath '(// body // *text*)) sxml))))
|
||||
(test-end "inv-3")
|
||||
|
||||
|
||||
(test-begin "inv-4")
|
||||
;; entry-inv-4 2 widgets of $3 = $6
|
||||
(let ((entry-inv-4 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-4 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-4 "entry-inv-4-desc")
|
||||
(gncEntrySetAction entry-inv-4 "entry-inv-4-action")
|
||||
(gncEntrySetNotes entry-inv-4 "entry-inv-4-notes")
|
||||
(gncEntrySetInvAccount entry-inv-4 income)
|
||||
(gncEntrySetDocQuantity entry-inv-4 2 #f)
|
||||
(gncEntrySetBillPrice entry-inv-4 3)
|
||||
(gncInvoiceAddEntry inv-4 entry-inv-4))
|
||||
(let* ((options (default-testing-options inv-4))
|
||||
(sxml (options->sxml options "inv-4 simple entry")))
|
||||
(test-equal "inv-4 simple entry amounts are correct"
|
||||
@ -355,16 +207,6 @@
|
||||
(test-end "inv-4")
|
||||
|
||||
(test-begin "inv-5 simple entry")
|
||||
;; entry-5 2 widgets of $3 = $6
|
||||
(let ((entry-5 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-5 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-5 "entry-5-desc")
|
||||
(gncEntrySetAction entry-5 "entry-5-action")
|
||||
(gncEntrySetNotes entry-5 "entry-5-notes")
|
||||
(gncEntrySetInvAccount entry-5 income)
|
||||
(gncEntrySetDocQuantity entry-5 2 #t)
|
||||
(gncEntrySetInvPrice entry-5 3)
|
||||
(gncInvoiceAddEntry inv-5 entry-5))
|
||||
(let* ((options (default-testing-options inv-5))
|
||||
(sxml (options->sxml options "inv-5 simple entry")))
|
||||
(test-equal "inv-5 simple entry amounts are correct"
|
||||
@ -379,15 +221,6 @@
|
||||
(test-end "inv-5 simple entry")
|
||||
|
||||
(test-begin "inv-6")
|
||||
(let ((entry-inv-6 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-6 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-6 "entry-inv-6-desc")
|
||||
(gncEntrySetAction entry-inv-6 "entry-inv-6-action")
|
||||
(gncEntrySetNotes entry-inv-6 "entry-inv-6-notes")
|
||||
(gncEntrySetInvAccount entry-inv-6 income)
|
||||
(gncEntrySetDocQuantity entry-inv-6 2 #t)
|
||||
(gncEntrySetBillPrice entry-inv-6 3)
|
||||
(gncInvoiceAddEntry inv-6 entry-inv-6))
|
||||
(let* ((options (default-testing-options inv-6))
|
||||
(sxml (options->sxml options "inv-6 simple entry")))
|
||||
(test-equal "inv-6 simple entry amounts are correct"
|
||||
@ -406,16 +239,6 @@
|
||||
(test-end "inv-6")
|
||||
|
||||
(test-begin "inv-7")
|
||||
;; entry-inv-7 2 widgets of $3 = $6
|
||||
(let ((entry-inv-7 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-7 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-7 "entry-inv-7-desc")
|
||||
(gncEntrySetAction entry-inv-7 "entry-inv-7-action")
|
||||
(gncEntrySetNotes entry-inv-7 "entry-inv-7-notes")
|
||||
(gncEntrySetInvAccount entry-inv-7 income)
|
||||
(gncEntrySetDocQuantity entry-inv-7 2 #t)
|
||||
(gncEntrySetBillPrice entry-inv-7 3)
|
||||
(gncInvoiceAddEntry inv-7 entry-inv-7))
|
||||
(let* ((options (default-testing-options inv-7))
|
||||
(sxml (options->sxml options "inv-7 simple entry")))
|
||||
(test-equal "inv-7 simple entry amounts are correct"
|
||||
@ -434,115 +257,27 @@
|
||||
(test-end "inv-7")
|
||||
|
||||
(test-begin "combinations of gncEntry options")
|
||||
(let* ((inv-8 (gncInvoiceCreate (gnc-get-current-book)))
|
||||
(taxrate 109/10)
|
||||
(discount 7/2)
|
||||
(unitprice 777/4)
|
||||
(quantity 11)
|
||||
(combo-vat-sales-tt (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt (format #f "~a% vat on sales" taxrate))
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-sales)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry taxrate)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt))
|
||||
(order (let ((order (gncOrderCreate (gnc-get-current-book))))
|
||||
(gncOrderSetID order "order-id")
|
||||
(gncOrderSetOwner order owner-1)
|
||||
(gncOrderSetReference order "order-ref")
|
||||
(gncOrderSetActive order #t)
|
||||
order))
|
||||
(billterm (let ((term (gncBillTermCreate (gnc-get-current-book))))
|
||||
(gncBillTermSetName term "billterm-name")
|
||||
(gncBillTermSetDescription term "billterm-desc")
|
||||
(gncBillTermSetType term 1) ;1 = GNC-TERM-TYPE-DAYS
|
||||
(gncBillTermSetDueDays term 8)
|
||||
term)))
|
||||
(gncInvoiceSetOwner inv-8 owner-1)
|
||||
(gncInvoiceSetCurrency inv-8 (gnc-default-report-currency))
|
||||
(gncInvoiceSetTerms inv-8 billterm)
|
||||
(for-each
|
||||
(lambda (combo)
|
||||
(let* ((each-entry (gncEntryCreate (gnc-get-current-book)))
|
||||
(taxable? (= (vector-ref combo 0) 1))
|
||||
(tax-included? (= (vector-ref combo 1) 1))
|
||||
(discount-type (vector-ref combo 2))
|
||||
(discount-how (vector-ref combo 3))
|
||||
(desc (format #f "taxable=~a tax-included=~a discount-type=~a discount-how=~a"
|
||||
(if taxable? "Y" "N")
|
||||
(if tax-included? "Y" "N")
|
||||
(gncAmountTypeToString discount-type)
|
||||
(gncEntryDiscountHowToString discount-how))))
|
||||
(gncEntrySetDateGDate each-entry (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription each-entry desc)
|
||||
(gncEntrySetAction each-entry "action")
|
||||
(gncEntrySetInvAccount each-entry income)
|
||||
(gncEntrySetDocQuantity each-entry quantity #f)
|
||||
(gncEntrySetInvPrice each-entry unitprice)
|
||||
(gncEntrySetInvDiscount each-entry discount)
|
||||
(gncEntrySetInvDiscountType each-entry discount-type)
|
||||
(gncEntrySetInvDiscountHow each-entry discount-how)
|
||||
(gncEntrySetInvTaxable each-entry taxable?)
|
||||
(gncEntrySetInvTaxIncluded each-entry tax-included?)
|
||||
(gncEntrySetInvTaxTable each-entry combo-vat-sales-tt)
|
||||
;; FIXME: Note: The following function hides a subtle
|
||||
;; bug. It aims to retrieve & dump the entry description
|
||||
;; and amount. Unfortunately the (gncEntryGetDocValue)
|
||||
;; function will subtly modify the entry amounts by a
|
||||
;; fraction; this means that the subsequent invoice payment
|
||||
;; will not make the invoice amount completely zero. If the
|
||||
;; following statement is uncommented, the invoice
|
||||
;; generated will not change, however, the test will fail
|
||||
;; because the (gncInvoiceIsPaid) final test will fail.
|
||||
|
||||
;; (format #t "inv-8: adding ~a to invoice, entry amount is ~a\n"
|
||||
;; desc
|
||||
;; (exact->inexact (gncEntryGetDocValue each-entry #f #t #f)))
|
||||
(gncOrderAddEntry order each-entry)
|
||||
(gncInvoiceAddEntry inv-8 each-entry)))
|
||||
(list
|
||||
;; the following list specifies combinations to test gncEntry options
|
||||
;; thanks to rgmerk and to jenny for idea how to generate list of options
|
||||
;; (vector Taxable?(1=#t) Tax-included?(1=#t) DiscountType DiscountHow)
|
||||
(vector 1 2 1 1)
|
||||
(vector 2 1 2 2)
|
||||
(vector 1 1 2 3)
|
||||
(vector 2 2 1 3)
|
||||
(vector 2 1 1 1)
|
||||
(vector 1 2 2 2)
|
||||
(vector 1 2 1 2)
|
||||
(vector 1 1 2 1)))
|
||||
(gncInvoiceSetNotes inv-8 (format #f "tax=~a%, discount=~a, qty=~a, price=~a" taxrate discount quantity unitprice))
|
||||
|
||||
(gncInvoicePostToAccount inv-8 receivable (current-time)
|
||||
(current-time) "trans-posting-memo"
|
||||
#t #f)
|
||||
|
||||
(gncInvoiceApplyPayment inv-8 '() bank 1747918/100 1
|
||||
(current-time) "trans-payment-memo-1" "trans-payment-num-1")
|
||||
(let* ((options (default-testing-options inv-8))
|
||||
(sxml (options->sxml options "inv-8 combinatorics")))
|
||||
(test-assert "inv-8 billterm-desc is in invoice body"
|
||||
(member
|
||||
"billterm-desc"
|
||||
((sxpath '(// body // *text*)) sxml)))
|
||||
(test-assert "inv-8 gncOrder reference is in invoice body"
|
||||
(member
|
||||
"REF order-ref"
|
||||
((sxpath '(// body // *text*)) sxml)))
|
||||
(test-equal "inv-8 invoice date is in invoice body"
|
||||
'("Date:")
|
||||
(sxml-get-row-col "invoice-details-table" sxml 1 1))
|
||||
(test-equal "inv-8 due date is in invoice body"
|
||||
'("Due Date:")
|
||||
(sxml-get-row-col "invoice-details-table" sxml 2 1))
|
||||
(test-equal "inv-8 combo amounts are correct"
|
||||
'("$2,133.25" "$2,061.96" "$2,133.25" "$2,061.96" "$2,133.25" "$2,133.25"
|
||||
"$1,851.95" "$1,859.30" "$16,368.17" "$1,111.01" "$17,479.18"
|
||||
"-$17,479.18" "$0.00")
|
||||
(sxml-get-row-col "entries-table" sxml #f -1))
|
||||
(test-assert "inv-8 is fully paid up!"
|
||||
(gncInvoiceIsPaid inv-8))))
|
||||
(let* ((options (default-testing-options inv-8))
|
||||
(sxml (options->sxml options "inv-8 combinatorics")))
|
||||
(test-assert "inv-8 billterm-desc is in invoice body"
|
||||
(member
|
||||
"billterm-desc"
|
||||
((sxpath '(// body // *text*)) sxml)))
|
||||
(test-assert "inv-8 gncOrder reference is in invoice body"
|
||||
(member
|
||||
"REF order-ref"
|
||||
((sxpath '(// body // *text*)) sxml)))
|
||||
(test-equal "inv-8 invoice date is in invoice body"
|
||||
'("Date:")
|
||||
(sxml-get-row-col "invoice-details-table" sxml 1 1))
|
||||
(test-equal "inv-8 due date is in invoice body"
|
||||
'("Due Date:")
|
||||
(sxml-get-row-col "invoice-details-table" sxml 2 1))
|
||||
(test-equal "inv-8 combo amounts are correct"
|
||||
'("$2,133.25" "$2,061.96" "$2,133.25" "$2,061.96" "$2,133.25" "$2,133.25"
|
||||
"$1,851.95" "$1,859.30" "$16,368.17" "$1,111.01" "$17,479.18"
|
||||
"-$17,479.18" "$0.00")
|
||||
(sxml-get-row-col "entries-table" sxml #f -1))
|
||||
(test-assert "inv-8 is fully paid up!"
|
||||
(gncInvoiceIsPaid inv-8)))
|
||||
(test-end "combinations of gncEntry options")))
|
||||
|
||||
@ -9,49 +9,77 @@
|
||||
(use-modules (gnucash reports standard taxinvoice))
|
||||
(use-modules (gnucash report))
|
||||
(use-modules (tests test-report-extras))
|
||||
(use-modules (srfi srfi-9))
|
||||
(use-modules (srfi srfi-64))
|
||||
(use-modules (srfi srfi-98))
|
||||
(use-modules (tests srfi64-extras))
|
||||
(use-modules (sxml simple))
|
||||
(use-modules (sxml xpath))
|
||||
|
||||
;; NOTE
|
||||
;; ----
|
||||
;; SIMPLE stress tests by default
|
||||
;; NOTE: This file will attempt to run most reports and set their
|
||||
;; options. First, the reports are run on empty-book, then on a book
|
||||
;; with sample transactions and invoices.
|
||||
|
||||
;; SIMPLE stress tests by default will run tests as many times as the
|
||||
;; maximum number of multichoice. if the option with most choices is a
|
||||
;; price-source with the 4 possibilities, average-cost,
|
||||
;; weighted-average, pricedb-nearest, pricedb-latest;
|
||||
;; simple-stress-test will run it 4 times using each price-source. Other
|
||||
;; options with fewer options are cycled e.g. multichoice 'simple
|
||||
;; 'detailed will be run with 'simple 'detailed 'simple 'detailed
|
||||
;; while the price-source gets more exhaustively tested. The report is
|
||||
;; only run to verify it does not crash. No testing of report output
|
||||
;; is actually done.
|
||||
;;
|
||||
;; PAIRWISE COMBINATORICS are enabled by setting environment variable COMBINATORICS
|
||||
;; to the fullpath for the compiled jenny from http://burtleburtle.net/bob/math/jenny.html
|
||||
;; PAIRWISE testing will improve test coverage. From the above
|
||||
;; example, if the stress test runs: average-cost + simple,
|
||||
;; weighted-average + detailed, pricedb-nearest + simple,
|
||||
;; pricedb-latest + detailed. No testing of average-cost + detailed is
|
||||
;; performed. PAIRWISE testing ensures pairs are tested adequately and
|
||||
;; uses an external tool jenny to generate combinations. The full-path
|
||||
;; to jenny must be specified in the COMBINATORICS environment
|
||||
;; variable. The n-tuple may be modified -- see the global variable
|
||||
;; N-TUPLE. The jenny.c is copied in the "borrowed" folder in GnuCash
|
||||
;; source. Source: http://burtleburtle.net/bob/math/jenny.html
|
||||
;;
|
||||
;; e.g. COMBINATORICS=/home/user/jenny/jenny ninja check
|
||||
|
||||
;; the following is the N-tuple
|
||||
(define N-TUPLE 2)
|
||||
|
||||
(define optionslist '())
|
||||
|
||||
(define-record-type :combo
|
||||
(make-combo section name combos)
|
||||
combo?
|
||||
(section get-section)
|
||||
(name get-name)
|
||||
(combos get-combos))
|
||||
|
||||
(define (generate-optionslist)
|
||||
(gnc:report-templates-for-each
|
||||
(lambda (report-id template)
|
||||
(let* ((options-generator (gnc:report-template-options-generator template))
|
||||
(name (gnc:report-template-name template))
|
||||
(options (options-generator)))
|
||||
(options (options-generator))
|
||||
(report-options-tested '()))
|
||||
(gnc:options-for-each
|
||||
(lambda (option)
|
||||
(when (memq (gnc:option-type option)
|
||||
'(multichoice boolean))
|
||||
(set! report-options-tested
|
||||
(cons (make-combo
|
||||
(gnc:option-section option)
|
||||
(gnc:option-name option)
|
||||
(case (gnc:option-type option)
|
||||
((multichoice) (map (lambda (d) (vector-ref d 0))
|
||||
(gnc:option-data option)))
|
||||
((boolean) (list #t #f))))
|
||||
report-options-tested))))
|
||||
options)
|
||||
(set! optionslist
|
||||
(cons (list (cons 'report-id report-id)
|
||||
(cons 'report-name (gnc:report-template-name template))
|
||||
(cons 'options (let ((report-options-tested '()))
|
||||
(gnc:options-for-each
|
||||
(lambda (option)
|
||||
(when (memq (gnc:option-type option)
|
||||
'(multichoice boolean))
|
||||
(set! report-options-tested
|
||||
(cons (vector
|
||||
(gnc:option-section option)
|
||||
(gnc:option-name option)
|
||||
(gnc:option-type option)
|
||||
(case (gnc:option-type option)
|
||||
((multichoice) (map (lambda (d) (vector-ref d 0))
|
||||
(gnc:option-data option)))
|
||||
((boolean) (list #t #f))))
|
||||
report-options-tested))))
|
||||
options)
|
||||
report-options-tested)))
|
||||
(cons 'options report-options-tested))
|
||||
optionslist))))))
|
||||
|
||||
;; Explicitly set locale to make the report output predictable
|
||||
@ -62,6 +90,8 @@
|
||||
(test-begin "stress options")
|
||||
(generate-optionslist)
|
||||
(tests)
|
||||
(gnc:dump-book)
|
||||
(gnc:dump-invoices)
|
||||
(test-end "stress options"))
|
||||
|
||||
(define jennypath
|
||||
@ -87,19 +117,19 @@
|
||||
(gnc-commodity-get-namespace (gnc-default-report-currency))
|
||||
sym))
|
||||
|
||||
(define structure
|
||||
(list "Root" (list (cons 'type ACCT-TYPE-ASSET))
|
||||
(list "Asset"
|
||||
(list "Bank")
|
||||
(list "GBP Bank" (list (cons 'commodity (mnemonic->commodity "GBP"))))
|
||||
(list "Wallet"))
|
||||
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
|
||||
(list "Income-GBP" (list (cons 'type ACCT-TYPE-INCOME)
|
||||
(cons 'commodity (mnemonic->commodity "GBP"))))
|
||||
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
|
||||
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY)))
|
||||
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
|
||||
))
|
||||
;; code snippet to run report uuid, with options object
|
||||
(define (try-run-report uuid options option-summary)
|
||||
(define (try proc . args) (gnc:apply-with-error-handling proc args))
|
||||
(let* ((res (try gnc:options->render uuid options "stress-test" "test"))
|
||||
(captured-error (cadr res)))
|
||||
(cond
|
||||
(captured-error
|
||||
(format #t "[fail]... \noptions-list are:\n~abacktrace:\n~a\n"
|
||||
(gnc:html-render-options-changed options #t)
|
||||
captured-error)
|
||||
(test-assert "logging test failure..." #f))
|
||||
(else
|
||||
(format #t "[pass] ~a\n" (string-join option-summary ","))))))
|
||||
|
||||
(define (simple-stress-test report-name uuid report-options)
|
||||
(let ((options (gnc:make-report-options uuid)))
|
||||
@ -109,109 +139,98 @@
|
||||
(for-each
|
||||
(lambda (option)
|
||||
(format #t ",~a/~a"
|
||||
(vector-ref option 0)
|
||||
(vector-ref option 1)))
|
||||
(get-section option)
|
||||
(get-name option)))
|
||||
report-options)
|
||||
(newline)
|
||||
(for-each
|
||||
(lambda (idx)
|
||||
(display report-name)
|
||||
(for-each
|
||||
(lambda (option)
|
||||
(let* ((section (vector-ref option 0))
|
||||
(name (vector-ref option 1))
|
||||
(value (list-ref (vector-ref option 3)
|
||||
(modulo idx (length (vector-ref option 3))))))
|
||||
(set-option! options section name value)
|
||||
(format #t ",~a"
|
||||
(cond
|
||||
((boolean? value) (if value 't 'f))
|
||||
(else value)))))
|
||||
report-options)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(gnc:options->render uuid options "stress-test" "test")
|
||||
(display "[pass]\n"))
|
||||
(lambda (k . args)
|
||||
(format #t "[fail]... error: (~s . ~s) options-list are:\n~a"
|
||||
k args
|
||||
(gnc:html-render-options-changed options #t))
|
||||
(test-assert "logging test failure as above..."
|
||||
#f))))
|
||||
(iota
|
||||
(apply max
|
||||
(cons 0
|
||||
(map (lambda (opt) (length (vector-ref opt 3)))
|
||||
report-options))))
|
||||
)))
|
||||
(when (gnc:lookup-option options "General" "Start Date")
|
||||
(set-option! options "General" "Start Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 12 1969))))
|
||||
(when (gnc:lookup-option options "General" "End Date")
|
||||
(set-option! options "General" "End Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 1 1972))))
|
||||
(let loop ((report-options report-options)
|
||||
(option-summary '()))
|
||||
(if (null? report-options)
|
||||
(try-run-report uuid options option-summary)
|
||||
(let* ((option (car report-options))
|
||||
(section (get-section option))
|
||||
(name (get-name option))
|
||||
(value (list-ref (get-combos option)
|
||||
(modulo idx (length (get-combos option))))))
|
||||
(set-option! options section name value)
|
||||
(loop (cdr report-options)
|
||||
(cons (cond
|
||||
((boolean? value) (if value "t" "f"))
|
||||
(else (object->string value)))
|
||||
option-summary))))))
|
||||
(iota (apply max (cons 0 (map (lambda (opt) (length (get-combos opt)))
|
||||
report-options)))))))
|
||||
|
||||
(define (combinatorial-stress-test report-name uuid report-options)
|
||||
(let* ((options (gnc:make-report-options uuid))
|
||||
(render #f))
|
||||
|
||||
(test-assert (format #f "basic test ~a" report-name)
|
||||
(set! render
|
||||
(gnc:options->render
|
||||
uuid options (string-append "stress-" report-name) "test")))
|
||||
(if render
|
||||
(begin
|
||||
(format #t "Testing n-tuple combinatorics for:\n~a" report-name)
|
||||
(for-each
|
||||
(lambda (option)
|
||||
(format #t ",~a/~a"
|
||||
(vector-ref option 0)
|
||||
(vector-ref option 1)))
|
||||
report-options)
|
||||
(newline)
|
||||
;; generate combinatorics
|
||||
(let* ((option-lengths (map (lambda (report-option)
|
||||
(length (vector-ref report-option 3)))
|
||||
report-options))
|
||||
(jennyargs (string-join (map number->string option-lengths) " "))
|
||||
(n-tuple (min
|
||||
;; the following is the n-tuple
|
||||
2
|
||||
(length report-options)))
|
||||
(cmdline (format #f "~a -n~a ~a"
|
||||
jennypath n-tuple jennyargs))
|
||||
(jennyout (get-string-all (open-input-pipe cmdline)))
|
||||
(test-cases (string-split jennyout #\newline)))
|
||||
(for-each
|
||||
(lambda (case)
|
||||
(unless (string-null? case)
|
||||
(let* ((choices-str (string-filter char-alphabetic? case))
|
||||
(choices-alpha (map char->integer (string->list choices-str)))
|
||||
(choices (map (lambda (n)
|
||||
(- n (if (> n 96) 97 39))) ; a-z -> 0-25, and A-Z -> 26-51
|
||||
choices-alpha)))
|
||||
(let loop ((option-idx (1- (length report-options)))
|
||||
(option-summary '()))
|
||||
(if (negative? option-idx)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(gnc:options->render uuid options "stress-test" "test")
|
||||
(format #t "[pass] ~a:~a \n"
|
||||
report-name
|
||||
(string-join option-summary ",")))
|
||||
(lambda (k . args)
|
||||
(format #t "[fail]... error (~s . ~s) options-list are:\n~a"
|
||||
k args
|
||||
(gnc:html-render-options-changed options #t))
|
||||
(test-assert "logging test failure as above..."
|
||||
#f)))
|
||||
(let* ((option (list-ref report-options option-idx))
|
||||
(section (vector-ref option 0))
|
||||
(name (vector-ref option 1))
|
||||
(value (list-ref (vector-ref option 3)
|
||||
(list-ref choices option-idx))))
|
||||
(set-option! options section name value)
|
||||
(loop (1- option-idx)
|
||||
(cons (format #f "~a"
|
||||
(cond
|
||||
((boolean? value) (if value 't 'f))
|
||||
(else value)))
|
||||
option-summary))))))))
|
||||
test-cases)))
|
||||
(display "...aborted due to basic test failure"))))
|
||||
|
||||
(cond
|
||||
(render
|
||||
(format #t "Testing n-tuple combinatorics for:\n~a" report-name)
|
||||
(for-each
|
||||
(lambda (option)
|
||||
(format #t ",~a/~a"
|
||||
(get-section option)
|
||||
(get-name option)))
|
||||
report-options)
|
||||
(newline)
|
||||
(when (gnc:lookup-option options "General" "Start Date")
|
||||
(set-option! options "General" "Start Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 12 1969))))
|
||||
(when (gnc:lookup-option options "General" "End Date")
|
||||
(set-option! options "General" "End Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 1 1972))))
|
||||
;; generate combinatorics
|
||||
(let* ((option-lengths (map (lambda (report-option)
|
||||
(length (get-combos report-option)))
|
||||
report-options))
|
||||
(jennyargs (string-join (map number->string option-lengths) " "))
|
||||
(n-tuple (min N-TUPLE (length report-options)))
|
||||
(cmdline (format #f "~a -n~a ~a" jennypath n-tuple jennyargs))
|
||||
(jennyout (get-string-all (open-input-pipe cmdline)))
|
||||
(test-cases (string-split jennyout #\newline)))
|
||||
(for-each
|
||||
(lambda (case)
|
||||
(unless (string-null? case)
|
||||
(let* ((choices-str (string-filter char-alphabetic? case))
|
||||
(choices-alpha (map char->integer (string->list choices-str)))
|
||||
(choices (map (lambda (n)
|
||||
;; a-z -> 0-25, and A-Z -> 26-51
|
||||
(- n (if (> n 96) 97 39)))
|
||||
choices-alpha)))
|
||||
(let loop ((option-idx (1- (length report-options)))
|
||||
(option-summary '()))
|
||||
(if (negative? option-idx)
|
||||
(try-run-report uuid options option-summary)
|
||||
(let* ((option (list-ref report-options option-idx))
|
||||
(section (get-section option))
|
||||
(name (get-name option))
|
||||
(value (list-ref (get-combos option)
|
||||
(list-ref choices option-idx))))
|
||||
(set-option! options section name value)
|
||||
(loop (1- option-idx)
|
||||
(cons (cond
|
||||
((boolean? value) (if value "t" "f"))
|
||||
(else (object->string value)))
|
||||
option-summary))))))))
|
||||
test-cases)))
|
||||
|
||||
(else
|
||||
(display "...aborted due to basic test failure")))))
|
||||
|
||||
(define test
|
||||
;; what strategy are we using here? simple stress test (ie tests as
|
||||
@ -221,63 +240,6 @@
|
||||
combinatorial-stress-test
|
||||
simple-stress-test))
|
||||
|
||||
(define (create-test-data)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-account-structure-alist env structure))
|
||||
(bank (cdr (assoc "Bank" account-alist)))
|
||||
(gbp-bank (cdr (assoc "GBP Bank" account-alist)))
|
||||
(wallet (cdr (assoc "Wallet" account-alist)))
|
||||
(income (cdr (assoc "Income" account-alist)))
|
||||
(gbp-income (cdr (assoc "Income-GBP" account-alist)))
|
||||
(expense (cdr (assoc "Expenses" account-alist)))
|
||||
(liability (cdr (assoc "Liabilities" account-alist)))
|
||||
(equity (cdr (assoc "Equity" account-alist))))
|
||||
;; populate datafile with old transactions
|
||||
(env-transfer env 01 01 1970 bank expense 5 #:description "desc-1" #:num "trn1" #:memo "memo-3")
|
||||
(env-transfer env 31 12 1969 income bank 10 #:description "desc-2" #:num "trn2" #:void-reason "void" #:notes "notes3")
|
||||
(env-transfer env 31 12 1969 income bank 29 #:description "desc-3" #:num "trn3"
|
||||
#:reconcile (cons #\c (gnc-dmy2time64 01 03 1970)))
|
||||
(env-transfer env 01 02 1970 bank expense 15 #:description "desc-4" #:num "trn4" #:notes "notes2" #:memo "memo-1")
|
||||
(env-transfer env 10 01 1970 liability expense 10 #:description "desc-5" #:num "trn5" #:void-reason "any")
|
||||
(env-transfer env 10 01 1970 liability expense 11 #:description "desc-6" #:num "trn6" #:notes "notes1")
|
||||
(env-transfer env 10 02 1970 bank liability 8 #:description "desc-7" #:num "trn7" #:notes "notes1" #:memo "memo-2"
|
||||
#:reconcile (cons #\y (gnc-dmy2time64 01 03 1970)))
|
||||
(let ((txn (xaccMallocTransaction (gnc-get-current-book)))
|
||||
(split-1 (xaccMallocSplit (gnc-get-current-book)))
|
||||
(split-2 (xaccMallocSplit (gnc-get-current-book)))
|
||||
(split-3 (xaccMallocSplit (gnc-get-current-book))))
|
||||
(xaccTransBeginEdit txn)
|
||||
(xaccTransSetDescription txn "$100bank -> $80expenses + $20wallet")
|
||||
(xaccTransSetCurrency txn (xaccAccountGetCommodity bank))
|
||||
(xaccTransSetDate txn 14 02 1971)
|
||||
(xaccSplitSetParent split-1 txn)
|
||||
(xaccSplitSetParent split-2 txn)
|
||||
(xaccSplitSetParent split-3 txn)
|
||||
(xaccSplitSetAccount split-1 bank)
|
||||
(xaccSplitSetAccount split-2 expense)
|
||||
(xaccSplitSetAccount split-3 wallet)
|
||||
(xaccSplitSetValue split-1 -100)
|
||||
(xaccSplitSetValue split-2 80)
|
||||
(xaccSplitSetValue split-3 20)
|
||||
(xaccSplitSetAmount split-1 -100)
|
||||
(xaccSplitSetAmount split-2 80)
|
||||
(xaccSplitSetAmount split-3 20)
|
||||
(xaccTransSetNotes txn "multisplit")
|
||||
(xaccTransCommitEdit txn))
|
||||
(let ((closing-txn (env-transfer env 31 12 1977 expense equity 111 #:description "Closing")))
|
||||
(xaccTransSetIsClosingTxn closing-txn #t))
|
||||
(env-transfer-foreign env 15 01 2000 gbp-bank bank 10 14 #:description "GBP 10 to USD 14")
|
||||
(env-transfer-foreign env 15 02 2000 bank gbp-bank 9 6 #:description "USD 9 to GBP 6")
|
||||
(for-each (lambda (m)
|
||||
(env-transfer env 08 (1+ m) 1978 gbp-income gbp-bank 51 #:description "#51 income")
|
||||
(env-transfer env 03 (1+ m) 1978 income bank 103 #:description "$103 income")
|
||||
(env-transfer env 15 (1+ m) 1978 bank expense 22 #:description "$22 expense")
|
||||
(env-transfer env 09 (1+ m) 1978 income bank 109 #:description "$109 income"))
|
||||
(iota 12))
|
||||
(let ((mid (floor (/ (+ (gnc-accounting-period-fiscal-start)
|
||||
(gnc-accounting-period-fiscal-end)) 2))))
|
||||
(env-create-transaction env mid bank income 200))))
|
||||
|
||||
(define (run-tests prefix)
|
||||
(for-each
|
||||
(lambda (option-set)
|
||||
@ -292,15 +254,6 @@
|
||||
"Receipt"
|
||||
"Australian Tax Invoice"
|
||||
"Balance Sheet (eguile)"
|
||||
|
||||
;; tax-schedule - locale-dependent?
|
||||
"Tax Schedule Report/TXF Export"
|
||||
|
||||
;; unusual reports
|
||||
"Welcome to GnuCash"
|
||||
"Hello, World"
|
||||
"Multicolumn View"
|
||||
"General Journal"
|
||||
))
|
||||
(format #t "\nSkipping ~a ~a...\n" report-name prefix)
|
||||
(begin
|
||||
@ -311,4 +264,5 @@
|
||||
(define (tests)
|
||||
(run-tests "with empty book")
|
||||
(create-test-data)
|
||||
(create-test-invoice-data)
|
||||
(run-tests "on a populated book"))
|
||||
|
||||
@ -689,7 +689,39 @@
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary AAPL 1)
|
||||
USD
|
||||
(gnc-dmy2time64-neutral 20 02 2014)))))
|
||||
(gnc-dmy2time64-neutral 20 02 2014))))
|
||||
|
||||
(test-equal "gnc:case-exchange-time-fn weighted-average 09/09/2013"
|
||||
307/5
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary AAPL 1)
|
||||
USD
|
||||
(gnc-dmy2time64-neutral 09 09 2013))))
|
||||
|
||||
(test-equal "gnc:case-exchange-time-fn weighted-average 11/08/2014"
|
||||
9366/125
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary AAPL 1)
|
||||
USD
|
||||
(gnc-dmy2time64-neutral 11 08 2014))))
|
||||
|
||||
(test-equal "gnc:case-exchange-time-fn weighted-average 22/10/2015"
|
||||
27663/325
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary AAPL 1)
|
||||
USD
|
||||
(gnc-dmy2time64-neutral 22 10 2015))))
|
||||
|
||||
(test-equal "gnc:case-exchange-time-fn weighted-average 24/10/2015"
|
||||
27663/325
|
||||
(gnc:gnc-monetary-amount
|
||||
(exchange-fn
|
||||
(gnc:make-gnc-monetary AAPL 1)
|
||||
USD
|
||||
(gnc-dmy2time64-neutral 24 10 2015)))))
|
||||
|
||||
(let ((exchange-fn (gnc:case-exchange-time-fn
|
||||
'average-cost USD
|
||||
|
||||
@ -226,12 +226,12 @@
|
||||
(export gnc:reldate-get-string)
|
||||
(export gnc:reldate-get-desc)
|
||||
(export gnc:reldate-get-fn)
|
||||
(export gnc:make-reldate-hash)
|
||||
(export gnc:reldate-string-db)
|
||||
(export gnc:relative-date-values)
|
||||
(export gnc:relative-date-hash)
|
||||
(export gnc:make-reldate-hash) ;deprecate
|
||||
(export gnc:reldate-string-db) ;deprecate
|
||||
(export gnc:relative-date-values) ;deprecate
|
||||
(export gnc:relative-date-hash) ;deprecate
|
||||
(export gnc:get-absolute-from-relative-date)
|
||||
(export gnc:get-relative-date-strings)
|
||||
(export gnc:get-relative-date-strings) ;deprecate
|
||||
(export gnc:get-relative-date-string)
|
||||
(export gnc:get-relative-date-desc)
|
||||
(export gnc:get-start-cal-year)
|
||||
|
||||
@ -24,8 +24,6 @@
|
||||
(use-modules (gnucash core-utils)
|
||||
(gnucash gettext))
|
||||
|
||||
(define gnc:reldate-list '())
|
||||
|
||||
;; get stuff from localtime date vector
|
||||
(define (gnc:date-get-year datevec)
|
||||
(+ 1900 (tm:year datevec)))
|
||||
@ -153,9 +151,10 @@
|
||||
(let ((lt (gnc-localtime caltime)))
|
||||
(+ (* 12 (- (gnc:date-get-year lt) 1970.0))
|
||||
(gnc:date-get-month lt) -1
|
||||
(/ (- (gnc:date-get-month-day lt) 1.0) (gnc:days-in-month
|
||||
(gnc:date-get-month lt)
|
||||
(gnc:date-get-year lt))))))
|
||||
(/ (- (gnc:date-get-month-day lt) 1.0)
|
||||
(gnc:days-in-month
|
||||
(gnc:date-get-month lt)
|
||||
(gnc:date-get-year lt))))))
|
||||
|
||||
;; convert a date in seconds since 1970 into # of two-week periods since
|
||||
;; Jan 4, 1970 ignoring leap-seconds (just halfing date-to-week-fraction)
|
||||
@ -209,10 +208,12 @@
|
||||
;; date-granularity comparison functions.
|
||||
|
||||
(define (gnc:time64-le-date t1 t2)
|
||||
(issue-deprecation-warning "gnc:time64-le-date is unused")
|
||||
(<= (time64CanonicalDayTime t1)
|
||||
(time64CanonicalDayTime t2)))
|
||||
|
||||
(define (gnc:time64-ge-date t1 t2)
|
||||
(issue-deprecation-warning "gnc:time64-ge-date is unused")
|
||||
(gnc:time64-le-date t2 t1))
|
||||
|
||||
;; returns #t if adding 1 to mday causes a month change.
|
||||
@ -249,6 +250,8 @@
|
||||
(define (gnc:make-date-interval-list startdate enddate incr)
|
||||
(define month-delta
|
||||
(assv-ref MonthDeltas incr))
|
||||
(define (make-interval from to)
|
||||
(list from (if (< to enddate) (decdate to SecDelta) enddate)))
|
||||
(let loop ((result '())
|
||||
(date startdate)
|
||||
(idx 0))
|
||||
@ -258,20 +261,12 @@
|
||||
(month-delta
|
||||
(let* ((curr (incdate-months startdate (* month-delta idx)))
|
||||
(next (incdate-months startdate (* month-delta (1+ idx)))))
|
||||
(loop (cons (list curr
|
||||
(if (< next enddate)
|
||||
(decdate next SecDelta)
|
||||
enddate))
|
||||
result)
|
||||
(loop (cons (make-interval curr next) result)
|
||||
next
|
||||
(1+ idx))))
|
||||
(else
|
||||
(let ((next (incdate date incr)))
|
||||
(loop (cons (list date
|
||||
(if (< next enddate)
|
||||
(decdate next SecDelta)
|
||||
enddate))
|
||||
result)
|
||||
(loop (cons (make-interval date next) result)
|
||||
next
|
||||
(1+ idx)))))))
|
||||
|
||||
@ -420,6 +415,9 @@
|
||||
(define (gnc:time64-next-day t64)
|
||||
(incdate t64 DayDelta))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; relative-date functions start here
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (gnc:reldate-get-symbol x) (vector-ref x 0))
|
||||
(define (gnc:reldate-get-string x) (vector-ref x 1))
|
||||
@ -427,19 +425,24 @@
|
||||
(define (gnc:reldate-get-fn x) (vector-ref x 3))
|
||||
|
||||
(define (gnc:make-reldate-hash hash reldate-list)
|
||||
(issue-deprecation-warning "gnc:make-reldate-hash is deprecated.")
|
||||
(map (lambda (reldate) (hash-set!
|
||||
hash
|
||||
(gnc:reldate-get-symbol reldate)
|
||||
reldate))
|
||||
reldate-list))
|
||||
|
||||
(define gnc:reldate-string-db (gnc:make-string-database))
|
||||
;; the following two variables will be inlined and can be deprecated
|
||||
(define gnc:reldate-string-db (gnc:make-string-database)) ;deprecate
|
||||
(define gnc:relative-date-values '()) ;deprecate
|
||||
|
||||
(define gnc:relative-date-values '())
|
||||
|
||||
(define gnc:relative-date-hash (make-hash-table 23))
|
||||
;; the globally available hash of reldates (hash-key = reldate
|
||||
;; symbols, hash-value = a vector, reldate data). aim to deprecate it
|
||||
;; being exported.
|
||||
(define gnc:relative-date-hash (make-hash-table))
|
||||
|
||||
(define (gnc:get-absolute-from-relative-date date-symbol)
|
||||
;; used in options.scm
|
||||
(let ((rel-date-data (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
(if rel-date-data
|
||||
((gnc:reldate-get-fn rel-date-data))
|
||||
@ -452,19 +455,26 @@ Defaulting to today."))
|
||||
(current-time)))))
|
||||
|
||||
(define (gnc:get-relative-date-strings date-symbol)
|
||||
(issue-deprecation-warning "gnc:get-relative-date-strings is unused.")
|
||||
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
|
||||
(cons (gnc:reldate-get-string rel-date-info)
|
||||
(gnc:relate-get-desc rel-date-info))))
|
||||
|
||||
(define (gnc:get-relative-date-string date-symbol)
|
||||
;; used in options.scm
|
||||
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
(gnc:reldate-get-string rel-date-info)))
|
||||
|
||||
(define (gnc:get-relative-date-desc date-symbol)
|
||||
;; used in options.scm
|
||||
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
(gnc:reldate-get-desc rel-date-info)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; end relative-date functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (gnc:get-start-cal-year)
|
||||
(let ((now (gnc-localtime (current-time))))
|
||||
(set-tm:sec now 0)
|
||||
@ -814,6 +824,9 @@ Defaulting to today."))
|
||||
;;start-cur-fin-year start-prev-fin-year end-prev-fin-year
|
||||
|
||||
(define (gnc:reldate-initialize)
|
||||
(define gnc:reldate-string-db (gnc:make-string-database))
|
||||
(define gnc:relative-date-values #f)
|
||||
|
||||
(gnc:reldate-string-db
|
||||
'store 'start-cal-year-string
|
||||
(N_ "Start of this year"))
|
||||
@ -1137,7 +1150,8 @@ Defaulting to today."))
|
||||
(gnc:reldate-string-db 'lookup 'one-year-ahead-desc)
|
||||
gnc:get-one-year-ahead)))
|
||||
|
||||
|
||||
(gnc:make-reldate-hash gnc:relative-date-hash gnc:relative-date-values)
|
||||
(set! gnc:reldate-list
|
||||
(map (lambda (x) (vector-ref x 0)) gnc:relative-date-values)))
|
||||
;; initialise gnc:relative-date-hash
|
||||
(for-each
|
||||
(lambda (reldate)
|
||||
(hash-set! gnc:relative-date-hash (gnc:reldate-get-symbol reldate) reldate))
|
||||
gnc:relative-date-values))
|
||||
|
||||
@ -1743,7 +1743,20 @@
|
||||
namespace="ISO4217"
|
||||
exchange-code="478"
|
||||
parts-per-unit="5"
|
||||
smallest-fraction="5"
|
||||
smallest-fraction="100"
|
||||
local-symbol="UM"
|
||||
/>
|
||||
<!-- "MRU" - "Ouguiya"
|
||||
-->
|
||||
<currency
|
||||
isocode="MRU"
|
||||
fullname="Ouguiya"
|
||||
unitname="ouguiya"
|
||||
partname="khoum"
|
||||
namespace="ISO4217"
|
||||
exchange-code="929"
|
||||
parts-per-unit="100"
|
||||
smallest-fraction="100"
|
||||
local-symbol="UM"
|
||||
/>
|
||||
<!-- "MTL" - "Maltese Lira"
|
||||
|
||||
@ -472,3 +472,364 @@
|
||||
income bank 109 #:description "$109 income"))
|
||||
(iota 12))
|
||||
account-alist))
|
||||
|
||||
;; creates 8 invoices. (1) customer-invoice (2) customer's job's
|
||||
;; invoice (3) vendor bill (4) employee bill (5) customer credit-note
|
||||
;; (6) vendor credit-note (7) employee credit-note (8)
|
||||
;; customer-invoice with various combinations of entries. in addition,
|
||||
;; this function will return the vector-list of invoices created.
|
||||
(define-public (create-test-invoice-data)
|
||||
(define USD (mnemonic->commodity "USD"))
|
||||
(define structure
|
||||
(list "Root" (list (cons 'type ACCT-TYPE-ASSET)
|
||||
(cons 'commodity USD))
|
||||
(list "Asset"
|
||||
(list "Bank"))
|
||||
(list "VAT"
|
||||
(list "VAT-on-Purchases")
|
||||
(list "VAT-on-Sales" (list (cons 'type ACCT-TYPE-LIABILITY))))
|
||||
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
|
||||
(list "Expense" (list (cons 'type ACCT-TYPE-EXPENSE)))
|
||||
(list "A/Receivable" (list (cons 'type ACCT-TYPE-RECEIVABLE)))
|
||||
(list "A/Payable" (list (cons 'type ACCT-TYPE-PAYABLE)))))
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-account-structure-alist env structure))
|
||||
(bank (cdr (assoc "Bank" account-alist)))
|
||||
(income (cdr (assoc "Income" account-alist)))
|
||||
(expense (cdr (assoc "Expense" account-alist)))
|
||||
(vat-sales (cdr (assoc "VAT-on-Sales" account-alist)))
|
||||
(vat-purchases (cdr (assoc "VAT-on-Purchases" account-alist)))
|
||||
(receivable (cdr (assoc "A/Receivable" account-alist)))
|
||||
(payable (cdr (assoc "A/Payable" account-alist)))
|
||||
(YEAR (gnc:time64-get-year (gnc:get-today)))
|
||||
|
||||
(cust-1 (let ((cust-1 (gncCustomerCreate (gnc-get-current-book))))
|
||||
(gncCustomerSetID cust-1 "cust-1-id")
|
||||
(gncCustomerSetName cust-1 "cust-1-name")
|
||||
(gncCustomerSetNotes cust-1 "cust-1-notes")
|
||||
(gncCustomerSetCurrency cust-1 USD)
|
||||
(gncCustomerSetTaxIncluded cust-1 1) ;1 = GNC-TAXINCLUDED-YES
|
||||
cust-1))
|
||||
|
||||
(owner-1 (let ((owner-1 (gncOwnerNew)))
|
||||
(gncOwnerInitCustomer owner-1 cust-1)
|
||||
owner-1))
|
||||
|
||||
;; inv-1 is generated for a customer
|
||||
(inv-1 (let ((inv-1 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-1 owner-1)
|
||||
(gncInvoiceSetNotes inv-1 "inv-1-notes")
|
||||
(gncInvoiceSetBillingID inv-1 "inv-1-billing-id")
|
||||
(gncInvoiceSetCurrency inv-1 USD)
|
||||
inv-1))
|
||||
|
||||
(job-1 (let ((job-1 (gncJobCreate (gnc-get-current-book))))
|
||||
(gncJobSetID job-1 "job-1-id")
|
||||
(gncJobSetName job-1 "job-1-name")
|
||||
(gncJobSetOwner job-1 owner-1)
|
||||
job-1))
|
||||
|
||||
(owner-2 (let ((owner-2 (gncOwnerNew)))
|
||||
(gncOwnerInitJob owner-2 job-1)
|
||||
owner-2))
|
||||
|
||||
;; inv-2 is generated from a customer's job
|
||||
(inv-2 (let ((inv-2 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-2 owner-2)
|
||||
(gncInvoiceSetNotes inv-2 "inv-2-notes")
|
||||
(gncInvoiceSetCurrency inv-2 USD)
|
||||
inv-2))
|
||||
|
||||
(vend-1 (let ((vend-1 (gncVendorCreate (gnc-get-current-book))))
|
||||
(gncVendorSetID vend-1 "vend-1-id")
|
||||
(gncVendorSetName vend-1 "vend-1-name")
|
||||
(gncVendorSetNotes vend-1 "vend-1-notes")
|
||||
(gncVendorSetCurrency vend-1 USD)
|
||||
(gncVendorSetTaxIncluded vend-1 1) ;1 = GNC-TAXINCLUDED-YES
|
||||
vend-1))
|
||||
|
||||
(owner-3 (let ((owner-3 (gncOwnerNew)))
|
||||
(gncOwnerInitVendor owner-3 vend-1)
|
||||
owner-3))
|
||||
|
||||
;; inv-3 is generated from a vendor
|
||||
(inv-3 (let ((inv-3 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-3 owner-3)
|
||||
(gncInvoiceSetNotes inv-3 "inv-3-notes")
|
||||
(gncInvoiceSetCurrency inv-3 USD)
|
||||
inv-3))
|
||||
|
||||
(emp-1 (let ((emp-1 (gncEmployeeCreate (gnc-get-current-book))))
|
||||
(gncEmployeeSetID emp-1 "emp-1-id")
|
||||
(gncEmployeeSetCurrency emp-1 USD)
|
||||
(gncEmployeeSetName emp-1 "emp-1-name")
|
||||
emp-1))
|
||||
|
||||
(owner-4 (let ((owner-4 (gncOwnerNew)))
|
||||
(gncOwnerInitEmployee owner-4 emp-1)
|
||||
owner-4))
|
||||
|
||||
;; inv-4 is generated for an employee
|
||||
(inv-4 (let ((inv-4 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-4 owner-4)
|
||||
(gncInvoiceSetNotes inv-4 "inv-4-notes")
|
||||
(gncInvoiceSetCurrency inv-4 USD)
|
||||
inv-4))
|
||||
|
||||
;; inv-5 cust-credit-note
|
||||
(inv-5 (let ((inv-5 (gncInvoiceCopy inv-1)))
|
||||
(gncInvoiceSetIsCreditNote inv-5 #t)
|
||||
(gncInvoiceSetCurrency inv-5 USD)
|
||||
inv-5))
|
||||
|
||||
;; inv-6 vend-credit-note
|
||||
(inv-6 (let ((inv-6 (gncInvoiceCopy inv-3)))
|
||||
(gncInvoiceSetIsCreditNote inv-6 #t)
|
||||
(gncInvoiceSetCurrency inv-6 USD)
|
||||
inv-6))
|
||||
|
||||
;; inv-7 emp-credit-note
|
||||
(inv-7 (let ((inv-7 (gncInvoiceCopy inv-4)))
|
||||
(gncInvoiceSetIsCreditNote inv-7 #t)
|
||||
(gncInvoiceSetCurrency inv-7 USD)
|
||||
inv-7))
|
||||
|
||||
(inv-8 (let ((inv-8 (gncInvoiceCreate (gnc-get-current-book))))
|
||||
(gncInvoiceSetOwner inv-8 owner-1)
|
||||
(gncInvoiceSetCurrency inv-8 USD)
|
||||
inv-8))
|
||||
|
||||
(standard-vat-sales-tt
|
||||
(let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt "10% vat on sales")
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-sales)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry 10)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt))
|
||||
|
||||
(standard-vat-purchases-tt
|
||||
(let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt "10% vat on purchases")
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-purchases)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry 10)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt)))
|
||||
|
||||
;; entry-1 2 widgets of $3 = $6
|
||||
(let ((entry-1 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-1 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-1 "entry-1-desc")
|
||||
(gncEntrySetAction entry-1 "entry-1-action")
|
||||
(gncEntrySetNotes entry-1 "entry-1-notes")
|
||||
(gncEntrySetInvAccount entry-1 income)
|
||||
(gncEntrySetDocQuantity entry-1 2 #f)
|
||||
(gncEntrySetInvPrice entry-1 3)
|
||||
(gncInvoiceAddEntry inv-1 entry-1))
|
||||
|
||||
;; entry-inv-2 2 widgets of $3 = $6
|
||||
(let ((entry-inv-2 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-2 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-2 "entry-inv-2-desc")
|
||||
(gncEntrySetAction entry-inv-2 "entry-inv-2-action")
|
||||
(gncEntrySetNotes entry-inv-2 "entry-inv-2-notes")
|
||||
(gncEntrySetInvAccount entry-inv-2 income)
|
||||
(gncEntrySetDocQuantity entry-inv-2 2 #f)
|
||||
(gncEntrySetInvPrice entry-inv-2 3)
|
||||
(gncInvoiceAddEntry inv-2 entry-inv-2))
|
||||
|
||||
;; entry-inv-3 2 widgets of $3 = $6
|
||||
(let ((entry-inv-3 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-3 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-3 "entry-inv-3-desc")
|
||||
(gncEntrySetAction entry-inv-3 "entry-inv-3-action")
|
||||
(gncEntrySetNotes entry-inv-3 "entry-inv-3-notes")
|
||||
(gncEntrySetBillAccount entry-inv-3 expense)
|
||||
(gncEntrySetDocQuantity entry-inv-3 2 #f)
|
||||
(gncEntrySetBillPrice entry-inv-3 3)
|
||||
(gncInvoiceAddEntry inv-3 entry-inv-3))
|
||||
|
||||
;; entry-inv-4 2 widgets of $3 = $6
|
||||
(let ((entry-inv-4 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-4 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-4 "entry-inv-4-desc")
|
||||
(gncEntrySetAction entry-inv-4 "entry-inv-4-action")
|
||||
(gncEntrySetNotes entry-inv-4 "entry-inv-4-notes")
|
||||
(gncEntrySetBillAccount entry-inv-4 expense)
|
||||
(gncEntrySetDocQuantity entry-inv-4 2 #f)
|
||||
(gncEntrySetBillPrice entry-inv-4 3)
|
||||
(gncInvoiceAddEntry inv-4 entry-inv-4))
|
||||
|
||||
;; entry-5 2 widgets of $3 = $6
|
||||
(let ((entry-5 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-5 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-5 "entry-5-desc")
|
||||
(gncEntrySetAction entry-5 "entry-5-action")
|
||||
(gncEntrySetNotes entry-5 "entry-5-notes")
|
||||
(gncEntrySetInvAccount entry-5 income)
|
||||
(gncEntrySetDocQuantity entry-5 2 #t)
|
||||
(gncEntrySetInvPrice entry-5 3)
|
||||
(gncInvoiceAddEntry inv-5 entry-5))
|
||||
|
||||
(let ((entry-inv-6 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-6 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-6 "entry-inv-6-desc")
|
||||
(gncEntrySetAction entry-inv-6 "entry-inv-6-action")
|
||||
(gncEntrySetNotes entry-inv-6 "entry-inv-6-notes")
|
||||
(gncEntrySetBillAccount entry-inv-6 expense)
|
||||
(gncEntrySetDocQuantity entry-inv-6 2 #t)
|
||||
(gncEntrySetBillPrice entry-inv-6 3)
|
||||
(gncInvoiceAddEntry inv-6 entry-inv-6))
|
||||
|
||||
;; entry-inv-7 2 widgets of $3 = $6
|
||||
(let ((entry-inv-7 (gncEntryCreate (gnc-get-current-book))))
|
||||
(gncEntrySetDateGDate entry-inv-7 (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription entry-inv-7 "entry-inv-7-desc")
|
||||
(gncEntrySetAction entry-inv-7 "entry-inv-7-action")
|
||||
(gncEntrySetNotes entry-inv-7 "entry-inv-7-notes")
|
||||
(gncEntrySetBillAccount entry-inv-7 expense)
|
||||
(gncEntrySetDocQuantity entry-inv-7 2 #t)
|
||||
(gncEntrySetBillPrice entry-inv-7 3)
|
||||
(gncInvoiceAddEntry inv-7 entry-inv-7))
|
||||
|
||||
(gncInvoicePostToAccount inv-1 receivable
|
||||
(gnc-dmy2time64 1 9 1980)
|
||||
(gnc-dmy2time64 1 9 1980)
|
||||
"cust-invoice"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-2 receivable
|
||||
(gnc-dmy2time64 2 9 1980)
|
||||
(gnc-dmy2time64 3 9 1980)
|
||||
"job-invoice"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-3 payable
|
||||
(gnc-dmy2time64 3 9 1980)
|
||||
(gnc-dmy2time64 3 9 1980)
|
||||
"vendor-bill"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-4 payable
|
||||
(gnc-dmy2time64 4 9 1980)
|
||||
(gnc-dmy2time64 4 9 1980)
|
||||
"emp-bill"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-5 receivable
|
||||
(gnc-dmy2time64 5 9 1980)
|
||||
(gnc-dmy2time64 5 9 1980)
|
||||
"cust-credit-note"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-6 payable
|
||||
(gnc-dmy2time64 6 9 1980)
|
||||
(gnc-dmy2time64 6 9 1980)
|
||||
"vend-credit-note"
|
||||
#t #f)
|
||||
|
||||
(gncInvoicePostToAccount inv-7 payable
|
||||
(gnc-dmy2time64 7 9 1980)
|
||||
(gnc-dmy2time64 7 9 1980)
|
||||
"emp-credit-note"
|
||||
#t #f)
|
||||
|
||||
(let* ((taxrate 109/10)
|
||||
(discount 7/2)
|
||||
(unitprice 777/4)
|
||||
(quantity 11)
|
||||
(combo-vat-sales-tt
|
||||
(let ((tt (gncTaxTableCreate (gnc-get-current-book))))
|
||||
(gncTaxTableIncRef tt)
|
||||
(gncTaxTableSetName tt (format #f "~a% vat on sales" taxrate))
|
||||
(let ((entry (gncTaxTableEntryCreate)))
|
||||
(gncTaxTableEntrySetAccount entry vat-sales)
|
||||
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
|
||||
(gncTaxTableEntrySetAmount entry taxrate)
|
||||
(gncTaxTableAddEntry tt entry))
|
||||
tt))
|
||||
(order (let ((order (gncOrderCreate (gnc-get-current-book))))
|
||||
(gncOrderSetID order "order-id")
|
||||
(gncOrderSetOwner order owner-1)
|
||||
(gncOrderSetReference order "order-ref")
|
||||
(gncOrderSetActive order #t)
|
||||
order))
|
||||
(billterm (let ((term (gncBillTermCreate (gnc-get-current-book))))
|
||||
(gncBillTermSetName term "billterm-name")
|
||||
(gncBillTermSetDescription term "billterm-desc")
|
||||
(gncBillTermSetType term 1) ;1 = GNC-TERM-TYPE-DAYS
|
||||
(gncBillTermSetDueDays term 8)
|
||||
term)))
|
||||
(gncInvoiceSetTerms inv-8 billterm)
|
||||
(for-each
|
||||
(lambda (combo)
|
||||
(let* ((each-entry (gncEntryCreate (gnc-get-current-book)))
|
||||
(taxable? (= (vector-ref combo 0) 1))
|
||||
(tax-included? (= (vector-ref combo 1) 1))
|
||||
(discount-type (vector-ref combo 2))
|
||||
(discount-how (vector-ref combo 3))
|
||||
(desc (format #f "taxable=~a tax-included=~a discount-type=~a discount-how=~a"
|
||||
(if taxable? "Y" "N")
|
||||
(if tax-included? "Y" "N")
|
||||
(gncAmountTypeToString discount-type)
|
||||
(gncEntryDiscountHowToString discount-how))))
|
||||
(gncEntrySetDateGDate each-entry (time64-to-gdate (current-time)))
|
||||
(gncEntrySetDescription each-entry desc)
|
||||
(gncEntrySetAction each-entry "action")
|
||||
(gncEntrySetInvAccount each-entry income)
|
||||
(gncEntrySetDocQuantity each-entry quantity #f)
|
||||
(gncEntrySetInvPrice each-entry unitprice)
|
||||
(gncEntrySetInvDiscount each-entry discount)
|
||||
(gncEntrySetInvDiscountType each-entry discount-type)
|
||||
(gncEntrySetInvDiscountHow each-entry discount-how)
|
||||
(gncEntrySetInvTaxable each-entry taxable?)
|
||||
(gncEntrySetInvTaxIncluded each-entry tax-included?)
|
||||
(gncEntrySetInvTaxTable each-entry combo-vat-sales-tt)
|
||||
(gncOrderAddEntry order each-entry)
|
||||
;; FIXME: Note: The following function hides a subtle
|
||||
;; bug. It aims to retrieve & dump the entry description
|
||||
;; and amount. Unfortunately the (gncEntryGetDocValue)
|
||||
;; function will subtly modify the entry amounts by a
|
||||
;; fraction; this means that the subsequent invoice payment
|
||||
;; will not make the invoice amount completely zero. If the
|
||||
;; following statement is uncommented, test-invoice will
|
||||
;; fail because the (gncInvoiceIsPaid) final test will
|
||||
;; fail.
|
||||
;; (format #t "inv-8: adding ~a to invoice, entry amount is ~a\n"
|
||||
;; desc
|
||||
;; (exact->inexact (gncEntryGetDocValue each-entry #f #t #f)))
|
||||
(gncInvoiceAddEntry inv-8 each-entry)))
|
||||
(list
|
||||
;; the following list specifies combinations to test gncEntry options
|
||||
;; thanks to rgmerk and to jenny for idea how to generate list of options
|
||||
;; (vector Taxable?(1=#t) Tax-included?(1=#t) DiscountType DiscountHow)
|
||||
(vector 1 2 1 1)
|
||||
(vector 2 1 2 2)
|
||||
(vector 1 1 2 3)
|
||||
(vector 2 2 1 3)
|
||||
(vector 2 1 1 1)
|
||||
(vector 1 2 2 2)
|
||||
(vector 1 2 1 2)
|
||||
(vector 1 1 2 1)))
|
||||
|
||||
(gncInvoiceSetNotes
|
||||
inv-8 (format #f "tax=~a%, discount=~a, qty=~a, price=~a"
|
||||
taxrate discount quantity unitprice))
|
||||
|
||||
(gncInvoicePostToAccount inv-8 receivable
|
||||
(gnc-dmy2time64 8 9 1980)
|
||||
(gnc-dmy2time64 8 9 1980)
|
||||
"trans-posting-memo"
|
||||
#t #f)
|
||||
|
||||
(gncInvoiceApplyPayment inv-8 '() bank 1747918/100 1
|
||||
(gnc-dmy2time64 10 9 1980)
|
||||
"trans-payment-memo-1"
|
||||
"trans-payment-num-1"))
|
||||
|
||||
(vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8)))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user