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

Merge branch 'maint'

Browse Source
This commit is contained in:
Christopher Lam 2019-07-25 20:30:32 +08:00
commit 720f176417
14 changed files with 821 additions and 680 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
CMakeLists.txt
View File

@ -325,7 +325,7 @@ else(GUILE22_FOUND)
message(STATUS "Using guile-2.0.x") message(STATUS "Using guile-2.0.x")
find_program (GUILE_EXECUTABLE NAMES guile2.0 guile) find_program (GUILE_EXECUTABLE NAMES guile2.0 guile)
else(GUILE2_FOUND) 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(GUILE2_FOUND)
endif(GUILE22_FOUND) endif(GUILE22_FOUND)

2
common/cmake_modules/GncAddTest.cmake
View File

@ -140,7 +140,7 @@ function(gnc_gtest_configure)
find_package(Threads REQUIRED) find_package(Threads REQUIRED)
set(GTEST_FOUND YES CACHE INTERNAL "Found GTest") set(GTEST_FOUND YES CACHE INTERNAL "Found GTest")
if(GTEST_SHARED_LIB) 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) unset(GTEST_SRC_DIR CACHE)
else() else()
set(GTEST_SRC "${GTEST_SRC_DIR}/src/gtest_main.cc" PARENT_SCOPE) set(GTEST_SRC "${GTEST_SRC_DIR}/src/gtest_main.cc" PARENT_SCOPE)

5
gnucash/gnome-utils/dialog-options.c
View File

@ -2694,9 +2694,8 @@ gnc_option_set_ui_widget_account_sel (GNCOption *option, GtkBox *page_box,
G_CALLBACK(gnc_option_changed_widget_cb), option); G_CALLBACK(gnc_option_changed_widget_cb), option);
gnc_option_set_widget (option, value); 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, FALSE);
gnc_option_set_ui_value(option, TRUE);
*enclosing = gtk_box_new (GTK_ORIENTATION_HORIZONTAL, 5); *enclosing = gtk_box_new (GTK_ORIENTATION_HORIZONTAL, 5);
gtk_box_set_homogeneous (GTK_BOX (*enclosing), FALSE); gtk_box_set_homogeneous (GTK_BOX (*enclosing), FALSE);

48
gnucash/report/commodity-utilities.scm
View File

@ -263,27 +263,21 @@
;; pricelist comes from ;; pricelist comes from
;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or, ;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or,
;; if pricelist was empty, #f. ;; if pricelist was empty, #f.
(define (gnc:pricelist-price-find-nearest (define (gnc:pricelist-price-find-nearest pricelist date)
pricelist date) (let lp ((pricelist pricelist))
(let* ((later (find (lambda (p) (cond
(< date (car p))) ((null? pricelist) #f)
pricelist)) ((null? (cdr pricelist)) (cadr (car pricelist)))
(earlierlist (take-while (else
(lambda (p) (let ((earlier (car pricelist))
(>= date (car p))) (later (cadr pricelist)))
pricelist)) (cond
(earlier (and (not (null? earlierlist)) ((< (car later) date)
(last earlierlist)))) (lp (cdr pricelist)))
((< (- date (car earlier)) (- (car later) date))
(if (and earlier later) (cadr earlier))
(if (< (abs (- date (car earlier))) (else
(abs (- date (car later)))) (cadr later))))))))
(cadr earlier)
(cadr later))
(or
(and earlier (cadr earlier))
(and later (cadr later))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to get one price at a given time (i.e. not time-variant). ;; 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 ;; the value of 'source-option', whose possible values are set in
;; gnc:options-add-price-source!. ;; 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. ;; 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 (define (gnc:case-exchange-time-fn
source-option report-currency commodity-list to-date-tp source-option report-currency commodity-list to-date-tp
start-percent delta-percent) start-percent delta-percent)

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

@ -939,6 +939,7 @@
;; utility function for testing. dumps the whole book contents to ;; utility function for testing. dumps the whole book contents to
;; console. ;; console.
(define (gnc:dump-book) (define (gnc:dump-book)
(display "\n(gnc:dump-book)\n")
(for-each (for-each
(lambda (acc) (lambda (acc)
(format #t "\nAccount: <~a> Comm<~a> Type<~a>\n" (format #t "\nAccount: <~a> Comm<~a> Type<~a>\n"
@ -950,7 +951,8 @@
(for-each (for-each
(lambda (s) (lambda (s)
(let ((txn (xaccSplitGetParent 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)) (qof-print-date (xaccTransGetDate txn))
(gnc:monetary->string (gnc:monetary->string
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
@ -960,13 +962,28 @@
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
(xaccTransGetCurrency txn) (xaccTransGetCurrency txn)
(xaccSplitGetValue s))) (xaccSplitGetValue s)))
(xaccTransGetDescription txn)))) (xaccTransGetDescription txn)
(xaccAccountGetSplitList acc))) (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-account-get-descendants-sorted
(gnc-get-current-root-account)))) (gnc-get-current-root-account))))
;; dump all invoices posted into an AP/AR account ;; dump all invoices posted into an AP/AR account
(define (gnc:dump-invoices) (define (gnc:dump-invoices)
(display "\n(gnc:dump-invoices)\n")
(let* ((acc-APAR (filter (compose xaccAccountIsAPARType xaccAccountGetType) (let* ((acc-APAR (filter (compose xaccAccountIsAPARType xaccAccountGetType)
(gnc-account-get-descendants-sorted (gnc-account-get-descendants-sorted
(gnc-get-current-root-account)))) (gnc-get-current-root-account))))
@ -984,7 +1001,7 @@
(gncInvoiceGetCurrency inv) amt))) (gncInvoiceGetCurrency inv) amt)))
(for-each (for-each
(lambda (inv) (lambda (inv)
(format #t "\nInvoice: ID<~a> Owner<~a> Account<~a>\n" (format #t "Invoice: ID<~a> Owner<~a> Account<~a>\n"
(gncInvoiceGetID inv) (gncInvoiceGetID inv)
(gncOwnerGetName (gncInvoiceGetOwner inv)) (gncOwnerGetName (gncInvoiceGetOwner inv))
(xaccAccountGetName (gncInvoiceGetPostedAcc inv))) (xaccAccountGetName (gncInvoiceGetPostedAcc inv)))

242
gnucash/report/reports/example/average-balance.scm
View File

@ -149,6 +149,121 @@
(_ "Loss") (_ "Profit") )) (_ "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 ;; Renderer
;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;
@ -168,7 +283,8 @@
(enddate (gnc:time64-end-day-time (enddate (gnc:time64-end-day-time
(gnc:date-option-absolute-time (gnc:date-option-absolute-time
(get-option gnc:pagename-general optname-to-date)))) (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 (report-currency (get-option gnc:pagename-general
optname-report-currency)) optname-report-currency))
(price-source (get-option gnc:pagename-general (price-source (get-option gnc:pagename-general
@ -267,128 +383,14 @@
(exchange-fn monetary target-curr date))))) (exchange-fn monetary target-curr date)))))
(iota work-to-do) (iota work-to-do)
daily-dates daily-dates
(apply zip accounts-balances))) (apply zip accounts-balances))))
;; for upcoming interval-calculators
(work-to-do (length splits)))
(qof-query-destroy query) (qof-query-destroy query)
;; this is a complicated tight loop. start with: (unless (null? splits)
;; daily-balances & daily-dates, interval-dates, and the (set! data
;; splitlist. traverse the daily balances and splitlist (analyze-splits splits balances daily-dates interval-dates
;; until we cross an interval date boundary, then internal-included exchange-fn report-currency))))
;; 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)))))
(gnc:report-percent-done 70) (gnc:report-percent-done 70)

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

@ -781,20 +781,30 @@ also show overall period profit & loss."))
price-source common-currency price-source common-currency
(map xaccAccountGetCommodity accounts) enddate (map xaccAccountGetCommodity accounts) enddate
#f #f))) #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) (convert-curr-fn (lambda (monetary col-idx)
(and common-currency (and common-currency
(not (gnc-commodity-equal (not (gnc-commodity-equal
(gnc:gnc-monetary-commodity monetary) (gnc:gnc-monetary-commodity monetary)
common-currency)) common-currency))
(has-price? (gnc:gnc-monetary-commodity monetary)) (has-price? (gnc:gnc-monetary-commodity monetary))
(let* ((date (case price-source (let ((date
((pricedb-latest) (current-time)) (cond
(else ((eq? price-source 'pricedb-latest)
(list-ref report-dates (current-time))
(case report-type ((eq? col-idx 'overall-period)
((balsheet) col-idx) (last report-dates))
((pnl) (1+ col-idx)))))))) (else
(list-ref report-dates
(case report-type
((balsheet) col-idx)
((pnl) (1+ col-idx))))))))
(exchange-fn monetary common-currency date))))) (exchange-fn monetary common-currency date)))))
;; the following function generates an gnc:html-text object ;; the following function generates an gnc:html-text object
;; to dump exchange rate for a particular column. From the ;; to dump exchange rate for a particular column. From the
;; accountlist given, obtain commodities, and convert 1 unit ;; accountlist given, obtain commodities, and convert 1 unit

331
gnucash/report/reports/standard/test/test-invoice.scm
View File

@ -84,110 +84,15 @@
(vat-purchases (cdr (assoc "VAT-on-Purchases" account-alist))) (vat-purchases (cdr (assoc "VAT-on-Purchases" account-alist)))
(receivable (cdr (assoc "A/Receivable" account-alist))) (receivable (cdr (assoc "A/Receivable" account-alist)))
(YEAR (gnc:time64-get-year (gnc:get-today))) (YEAR (gnc:time64-get-year (gnc:get-today)))
(invoices (create-test-invoice-data))
(cust-1 (let ((cust-1 (gncCustomerCreate (gnc-get-current-book)))) (inv-1 (vector-ref invoices 0))
(gncCustomerSetID cust-1 "cust-1-id") (inv-2 (vector-ref invoices 1))
(gncCustomerSetName cust-1 "cust-1-name") (inv-3 (vector-ref invoices 2))
(gncCustomerSetNotes cust-1 "cust-1-notes") (inv-4 (vector-ref invoices 3))
(gncCustomerSetCurrency cust-1 (gnc-default-report-currency)) (inv-5 (vector-ref invoices 4))
(gncCustomerSetTaxIncluded cust-1 1) ;1 = GNC-TAXINCLUDED-YES (inv-6 (vector-ref invoices 5))
cust-1)) (inv-7 (vector-ref invoices 6))
(inv-8 (vector-ref invoices 7)))
(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)))
(define* (default-testing-options inv #:optional (setting #t)) (define* (default-testing-options inv #:optional (setting #t))
(let ((options (gnc:make-report-options uuid))) (let ((options (gnc:make-report-options uuid)))
@ -196,7 +101,7 @@
(lambda (disp-col-name) (lambda (disp-col-name)
(set-option! options "Display Columns" disp-col-name setting)) (set-option! options "Display Columns" disp-col-name setting))
'("Date" "Description" "Action" "Quantity" "Price" "Discount" '("Date" "Description" "Action" "Quantity" "Price" "Discount"
"Taxable" "Tax Amount" "Total")) "Taxable" "Tax Amount" "Total"))
(for-each (for-each
(lambda (disp-col-name) (lambda (disp-col-name)
(set-option! options "Display" disp-col-name setting)) (set-option! options "Display" disp-col-name setting))
@ -206,17 +111,6 @@
"Payments" "Job Details")) "Payments" "Job Details"))
options)) 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") (test-begin "inv-1 simple entry")
(let* ((options (default-testing-options inv-1)) (let* ((options (default-testing-options inv-1))
(sxml (options->sxml options "inv-1 simple entry"))) (sxml (options->sxml options "inv-1 simple entry")))
@ -251,27 +145,6 @@
(test-end "inv-1 simple entry, sparse options") (test-end "inv-1 simple entry, sparse options")
(test-begin "inv-2") (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)) (let* ((options (default-testing-options inv-2))
(sxml (options->sxml options "inv-2 simple entry"))) (sxml (options->sxml options "inv-2 simple entry")))
(test-equal "inv-2 simple entry amounts are correct" (test-equal "inv-2 simple entry amounts are correct"
@ -298,16 +171,6 @@
(test-end "inv-2") (test-end "inv-2")
(test-begin "inv-3") (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)) (let* ((options (default-testing-options inv-3))
(sxml (options->sxml options "inv-3 simple entry"))) (sxml (options->sxml options "inv-3 simple entry")))
(test-equal "inv-3 simple entry amounts are correct" (test-equal "inv-3 simple entry amounts are correct"
@ -325,18 +188,7 @@
((sxpath '(// body // *text*)) sxml)))) ((sxpath '(// body // *text*)) sxml))))
(test-end "inv-3") (test-end "inv-3")
(test-begin "inv-4") (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)) (let* ((options (default-testing-options inv-4))
(sxml (options->sxml options "inv-4 simple entry"))) (sxml (options->sxml options "inv-4 simple entry")))
(test-equal "inv-4 simple entry amounts are correct" (test-equal "inv-4 simple entry amounts are correct"
@ -355,16 +207,6 @@
(test-end "inv-4") (test-end "inv-4")
(test-begin "inv-5 simple entry") (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)) (let* ((options (default-testing-options inv-5))
(sxml (options->sxml options "inv-5 simple entry"))) (sxml (options->sxml options "inv-5 simple entry")))
(test-equal "inv-5 simple entry amounts are correct" (test-equal "inv-5 simple entry amounts are correct"
@ -379,15 +221,6 @@
(test-end "inv-5 simple entry") (test-end "inv-5 simple entry")
(test-begin "inv-6") (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)) (let* ((options (default-testing-options inv-6))
(sxml (options->sxml options "inv-6 simple entry"))) (sxml (options->sxml options "inv-6 simple entry")))
(test-equal "inv-6 simple entry amounts are correct" (test-equal "inv-6 simple entry amounts are correct"
@ -406,16 +239,6 @@
(test-end "inv-6") (test-end "inv-6")
(test-begin "inv-7") (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)) (let* ((options (default-testing-options inv-7))
(sxml (options->sxml options "inv-7 simple entry"))) (sxml (options->sxml options "inv-7 simple entry")))
(test-equal "inv-7 simple entry amounts are correct" (test-equal "inv-7 simple entry amounts are correct"
@ -434,115 +257,27 @@
(test-end "inv-7") (test-end "inv-7")
(test-begin "combinations of gncEntry options") (test-begin "combinations of gncEntry options")
(let* ((inv-8 (gncInvoiceCreate (gnc-get-current-book))) (let* ((options (default-testing-options inv-8))
(taxrate 109/10) (sxml (options->sxml options "inv-8 combinatorics")))
(discount 7/2) (test-assert "inv-8 billterm-desc is in invoice body"
(unitprice 777/4) (member
(quantity 11) "billterm-desc"
(combo-vat-sales-tt (let ((tt (gncTaxTableCreate (gnc-get-current-book)))) ((sxpath '(// body // *text*)) sxml)))
(gncTaxTableIncRef tt) (test-assert "inv-8 gncOrder reference is in invoice body"
(gncTaxTableSetName tt (format #f "~a% vat on sales" taxrate)) (member
(let ((entry (gncTaxTableEntryCreate))) "REF order-ref"
(gncTaxTableEntrySetAccount entry vat-sales) ((sxpath '(// body // *text*)) sxml)))
(gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT) (test-equal "inv-8 invoice date is in invoice body"
(gncTaxTableEntrySetAmount entry taxrate) '("Date:")
(gncTaxTableAddEntry tt entry)) (sxml-get-row-col "invoice-details-table" sxml 1 1))
tt)) (test-equal "inv-8 due date is in invoice body"
(order (let ((order (gncOrderCreate (gnc-get-current-book)))) '("Due Date:")
(gncOrderSetID order "order-id") (sxml-get-row-col "invoice-details-table" sxml 2 1))
(gncOrderSetOwner order owner-1) (test-equal "inv-8 combo amounts are correct"
(gncOrderSetReference order "order-ref") '("$2,133.25" "$2,061.96" "$2,133.25" "$2,061.96" "$2,133.25" "$2,133.25"
(gncOrderSetActive order #t) "$1,851.95" "$1,859.30" "$16,368.17" "$1,111.01" "$17,479.18"
order)) "-$17,479.18" "$0.00")
(billterm (let ((term (gncBillTermCreate (gnc-get-current-book)))) (sxml-get-row-col "entries-table" sxml #f -1))
(gncBillTermSetName term "billterm-name") (test-assert "inv-8 is fully paid up!"
(gncBillTermSetDescription term "billterm-desc") (gncInvoiceIsPaid inv-8)))
(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))))
(test-end "combinations of gncEntry options"))) (test-end "combinations of gncEntry options")))

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

@ -9,49 +9,77 @@
(use-modules (gnucash reports standard taxinvoice)) (use-modules (gnucash reports standard taxinvoice))
(use-modules (gnucash report)) (use-modules (gnucash report))
(use-modules (tests test-report-extras)) (use-modules (tests test-report-extras))
(use-modules (srfi srfi-9))
(use-modules (srfi srfi-64)) (use-modules (srfi srfi-64))
(use-modules (srfi srfi-98)) (use-modules (srfi srfi-98))
(use-modules (tests srfi64-extras)) (use-modules (tests srfi64-extras))
(use-modules (sxml simple)) (use-modules (sxml simple))
(use-modules (sxml xpath)) (use-modules (sxml xpath))
;; NOTE ;; 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
;; SIMPLE stress tests by default ;; 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 ;; PAIRWISE testing will improve test coverage. From the above
;; to the fullpath for the compiled jenny from http://burtleburtle.net/bob/math/jenny.html ;; 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 ;; e.g. COMBINATORICS=/home/user/jenny/jenny ninja check
;; the following is the N-tuple
(define N-TUPLE 2)
(define optionslist '()) (define optionslist '())
(define-record-type :combo
(make-combo section name combos)
combo?
(section get-section)
(name get-name)
(combos get-combos))
(define (generate-optionslist) (define (generate-optionslist)
(gnc:report-templates-for-each (gnc:report-templates-for-each
(lambda (report-id template) (lambda (report-id template)
(let* ((options-generator (gnc:report-template-options-generator 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 (set! optionslist
(cons (list (cons 'report-id report-id) (cons (list (cons 'report-id report-id)
(cons 'report-name (gnc:report-template-name template)) (cons 'report-name (gnc:report-template-name template))
(cons 'options (let ((report-options-tested '())) (cons 'options 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)))
optionslist)))))) optionslist))))))
;; Explicitly set locale to make the report output predictable ;; Explicitly set locale to make the report output predictable
@ -62,6 +90,8 @@
(test-begin "stress options") (test-begin "stress options")
(generate-optionslist) (generate-optionslist)
(tests) (tests)
(gnc:dump-book)
(gnc:dump-invoices)
(test-end "stress options")) (test-end "stress options"))
(define jennypath (define jennypath
@ -87,19 +117,19 @@
(gnc-commodity-get-namespace (gnc-default-report-currency)) (gnc-commodity-get-namespace (gnc-default-report-currency))
sym)) sym))
(define structure ;; code snippet to run report uuid, with options object
(list "Root" (list (cons 'type ACCT-TYPE-ASSET)) (define (try-run-report uuid options option-summary)
(list "Asset" (define (try proc . args) (gnc:apply-with-error-handling proc args))
(list "Bank") (let* ((res (try gnc:options->render uuid options "stress-test" "test"))
(list "GBP Bank" (list (cons 'commodity (mnemonic->commodity "GBP")))) (captured-error (cadr res)))
(list "Wallet")) (cond
(list "Income" (list (cons 'type ACCT-TYPE-INCOME))) (captured-error
(list "Income-GBP" (list (cons 'type ACCT-TYPE-INCOME) (format #t "[fail]... \noptions-list are:\n~abacktrace:\n~a\n"
(cons 'commodity (mnemonic->commodity "GBP")))) (gnc:html-render-options-changed options #t)
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE))) captured-error)
(list "Liabilities" (list (cons 'type ACCT-TYPE-LIABILITY))) (test-assert "logging test failure..." #f))
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY))) (else
)) (format #t "[pass] ~a\n" (string-join option-summary ","))))))
(define (simple-stress-test report-name uuid report-options) (define (simple-stress-test report-name uuid report-options)
(let ((options (gnc:make-report-options uuid))) (let ((options (gnc:make-report-options uuid)))
@ -109,109 +139,98 @@
(for-each (for-each
(lambda (option) (lambda (option)
(format #t ",~a/~a" (format #t ",~a/~a"
(vector-ref option 0) (get-section option)
(vector-ref option 1))) (get-name option)))
report-options) report-options)
(newline) (newline)
(for-each (for-each
(lambda (idx) (lambda (idx)
(display report-name) (when (gnc:lookup-option options "General" "Start Date")
(for-each (set-option! options "General" "Start Date"
(lambda (option) (cons 'absolute (gnc-dmy2time64 1 12 1969))))
(let* ((section (vector-ref option 0)) (when (gnc:lookup-option options "General" "End Date")
(name (vector-ref option 1)) (set-option! options "General" "End Date"
(value (list-ref (vector-ref option 3) (cons 'absolute (gnc-dmy2time64 1 1 1972))))
(modulo idx (length (vector-ref option 3)))))) (let loop ((report-options report-options)
(set-option! options section name value) (option-summary '()))
(format #t ",~a" (if (null? report-options)
(cond (try-run-report uuid options option-summary)
((boolean? value) (if value 't 'f)) (let* ((option (car report-options))
(else value))))) (section (get-section option))
report-options) (name (get-name option))
(catch #t (value (list-ref (get-combos option)
(lambda () (modulo idx (length (get-combos option))))))
(gnc:options->render uuid options "stress-test" "test") (set-option! options section name value)
(display "[pass]\n")) (loop (cdr report-options)
(lambda (k . args) (cons (cond
(format #t "[fail]... error: (~s . ~s) options-list are:\n~a" ((boolean? value) (if value "t" "f"))
k args (else (object->string value)))
(gnc:html-render-options-changed options #t)) option-summary))))))
(test-assert "logging test failure as above..." (iota (apply max (cons 0 (map (lambda (opt) (length (get-combos opt)))
#f)))) report-options)))))))
(iota
(apply max
(cons 0
(map (lambda (opt) (length (vector-ref opt 3)))
report-options))))
)))
(define (combinatorial-stress-test report-name uuid report-options) (define (combinatorial-stress-test report-name uuid report-options)
(let* ((options (gnc:make-report-options uuid)) (let* ((options (gnc:make-report-options uuid))
(render #f)) (render #f))
(test-assert (format #f "basic test ~a" report-name) (test-assert (format #f "basic test ~a" report-name)
(set! render (set! render
(gnc:options->render (gnc:options->render
uuid options (string-append "stress-" report-name) "test"))) uuid options (string-append "stress-" report-name) "test")))
(if render
(begin (cond
(format #t "Testing n-tuple combinatorics for:\n~a" report-name) (render
(for-each (format #t "Testing n-tuple combinatorics for:\n~a" report-name)
(lambda (option) (for-each
(format #t ",~a/~a" (lambda (option)
(vector-ref option 0) (format #t ",~a/~a"
(vector-ref option 1))) (get-section option)
report-options) (get-name option)))
(newline) report-options)
;; generate combinatorics (newline)
(let* ((option-lengths (map (lambda (report-option) (when (gnc:lookup-option options "General" "Start Date")
(length (vector-ref report-option 3))) (set-option! options "General" "Start Date"
report-options)) (cons 'absolute (gnc-dmy2time64 1 12 1969))))
(jennyargs (string-join (map number->string option-lengths) " ")) (when (gnc:lookup-option options "General" "End Date")
(n-tuple (min (set-option! options "General" "End Date"
;; the following is the n-tuple (cons 'absolute (gnc-dmy2time64 1 1 1972))))
2 ;; generate combinatorics
(length report-options))) (let* ((option-lengths (map (lambda (report-option)
(cmdline (format #f "~a -n~a ~a" (length (get-combos report-option)))
jennypath n-tuple jennyargs)) report-options))
(jennyout (get-string-all (open-input-pipe cmdline))) (jennyargs (string-join (map number->string option-lengths) " "))
(test-cases (string-split jennyout #\newline))) (n-tuple (min N-TUPLE (length report-options)))
(for-each (cmdline (format #f "~a -n~a ~a" jennypath n-tuple jennyargs))
(lambda (case) (jennyout (get-string-all (open-input-pipe cmdline)))
(unless (string-null? case) (test-cases (string-split jennyout #\newline)))
(let* ((choices-str (string-filter char-alphabetic? case)) (for-each
(choices-alpha (map char->integer (string->list choices-str))) (lambda (case)
(choices (map (lambda (n) (unless (string-null? case)
(- n (if (> n 96) 97 39))) ; a-z -> 0-25, and A-Z -> 26-51 (let* ((choices-str (string-filter char-alphabetic? case))
choices-alpha))) (choices-alpha (map char->integer (string->list choices-str)))
(let loop ((option-idx (1- (length report-options))) (choices (map (lambda (n)
(option-summary '())) ;; a-z -> 0-25, and A-Z -> 26-51
(if (negative? option-idx) (- n (if (> n 96) 97 39)))
(catch #t choices-alpha)))
(lambda () (let loop ((option-idx (1- (length report-options)))
(gnc:options->render uuid options "stress-test" "test") (option-summary '()))
(format #t "[pass] ~a:~a \n" (if (negative? option-idx)
report-name (try-run-report uuid options option-summary)
(string-join option-summary ","))) (let* ((option (list-ref report-options option-idx))
(lambda (k . args) (section (get-section option))
(format #t "[fail]... error (~s . ~s) options-list are:\n~a" (name (get-name option))
k args (value (list-ref (get-combos option)
(gnc:html-render-options-changed options #t)) (list-ref choices option-idx))))
(test-assert "logging test failure as above..." (set-option! options section name value)
#f))) (loop (1- option-idx)
(let* ((option (list-ref report-options option-idx)) (cons (cond
(section (vector-ref option 0)) ((boolean? value) (if value "t" "f"))
(name (vector-ref option 1)) (else (object->string value)))
(value (list-ref (vector-ref option 3) option-summary))))))))
(list-ref choices option-idx)))) test-cases)))
(set-option! options section name value)
(loop (1- option-idx) (else
(cons (format #f "~a" (display "...aborted due to basic test failure")))))
(cond
((boolean? value) (if value 't 'f))
(else value)))
option-summary))))))))
test-cases)))
(display "...aborted due to basic test failure"))))
(define test (define test
;; what strategy are we using here? simple stress test (ie tests as ;; what strategy are we using here? simple stress test (ie tests as
@ -221,63 +240,6 @@
combinatorial-stress-test combinatorial-stress-test
simple-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) (define (run-tests prefix)
(for-each (for-each
(lambda (option-set) (lambda (option-set)
@ -292,15 +254,6 @@
"Receipt" "Receipt"
"Australian Tax Invoice" "Australian Tax Invoice"
"Balance Sheet (eguile)" "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) (format #t "\nSkipping ~a ~a...\n" report-name prefix)
(begin (begin
@ -311,4 +264,5 @@
(define (tests) (define (tests)
(run-tests "with empty book") (run-tests "with empty book")
(create-test-data) (create-test-data)
(create-test-invoice-data)
(run-tests "on a populated book")) (run-tests "on a populated book"))

34
gnucash/report/test/test-commodity-utils.scm
View File

@ -689,7 +689,39 @@
(exchange-fn (exchange-fn
(gnc:make-gnc-monetary AAPL 1) (gnc:make-gnc-monetary AAPL 1)
USD 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 (let ((exchange-fn (gnc:case-exchange-time-fn
'average-cost USD 'average-cost USD

10
libgnucash/app-utils/app-utils.scm
View File

@ -226,12 +226,12 @@
(export gnc:reldate-get-string) (export gnc:reldate-get-string)
(export gnc:reldate-get-desc) (export gnc:reldate-get-desc)
(export gnc:reldate-get-fn) (export gnc:reldate-get-fn)
(export gnc:make-reldate-hash) (export gnc:make-reldate-hash) ;deprecate
(export gnc:reldate-string-db) (export gnc:reldate-string-db) ;deprecate
(export gnc:relative-date-values) (export gnc:relative-date-values) ;deprecate
(export gnc:relative-date-hash) (export gnc:relative-date-hash) ;deprecate
(export gnc:get-absolute-from-relative-date) (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-string)
(export gnc:get-relative-date-desc) (export gnc:get-relative-date-desc)
(export gnc:get-start-cal-year) (export gnc:get-start-cal-year)

60
libgnucash/app-utils/date-utilities.scm
View File

@ -24,8 +24,6 @@
(use-modules (gnucash core-utils) (use-modules (gnucash core-utils)
(gnucash gettext)) (gnucash gettext))
(define gnc:reldate-list '())
;; get stuff from localtime date vector ;; get stuff from localtime date vector
(define (gnc:date-get-year datevec) (define (gnc:date-get-year datevec)
(+ 1900 (tm:year datevec))) (+ 1900 (tm:year datevec)))
@ -153,9 +151,10 @@
(let ((lt (gnc-localtime caltime))) (let ((lt (gnc-localtime caltime)))
(+ (* 12 (- (gnc:date-get-year lt) 1970.0)) (+ (* 12 (- (gnc:date-get-year lt) 1970.0))
(gnc:date-get-month lt) -1 (gnc:date-get-month lt) -1
(/ (- (gnc:date-get-month-day lt) 1.0) (gnc:days-in-month (/ (- (gnc:date-get-month-day lt) 1.0)
(gnc:date-get-month lt) (gnc:days-in-month
(gnc:date-get-year lt)))))) (gnc:date-get-month lt)
(gnc:date-get-year lt))))))
;; convert a date in seconds since 1970 into # of two-week periods since ;; 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) ;; Jan 4, 1970 ignoring leap-seconds (just halfing date-to-week-fraction)
@ -209,10 +208,12 @@
;; date-granularity comparison functions. ;; date-granularity comparison functions.
(define (gnc:time64-le-date t1 t2) (define (gnc:time64-le-date t1 t2)
(issue-deprecation-warning "gnc:time64-le-date is unused")
(<= (time64CanonicalDayTime t1) (<= (time64CanonicalDayTime t1)
(time64CanonicalDayTime t2))) (time64CanonicalDayTime t2)))
(define (gnc:time64-ge-date t1 t2) (define (gnc:time64-ge-date t1 t2)
(issue-deprecation-warning "gnc:time64-ge-date is unused")
(gnc:time64-le-date t2 t1)) (gnc:time64-le-date t2 t1))
;; returns #t if adding 1 to mday causes a month change. ;; 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 (gnc:make-date-interval-list startdate enddate incr)
(define month-delta (define month-delta
(assv-ref MonthDeltas incr)) (assv-ref MonthDeltas incr))
(define (make-interval from to)
(list from (if (< to enddate) (decdate to SecDelta) enddate)))
(let loop ((result '()) (let loop ((result '())
(date startdate) (date startdate)
(idx 0)) (idx 0))
@ -258,20 +261,12 @@
(month-delta (month-delta
(let* ((curr (incdate-months startdate (* month-delta idx))) (let* ((curr (incdate-months startdate (* month-delta idx)))
(next (incdate-months startdate (* month-delta (1+ idx))))) (next (incdate-months startdate (* month-delta (1+ idx)))))
(loop (cons (list curr (loop (cons (make-interval curr next) result)
(if (< next enddate)
(decdate next SecDelta)
enddate))
result)
next next
(1+ idx)))) (1+ idx))))
(else (else
(let ((next (incdate date incr))) (let ((next (incdate date incr)))
(loop (cons (list date (loop (cons (make-interval date next) result)
(if (< next enddate)
(decdate next SecDelta)
enddate))
result)
next next
(1+ idx))))))) (1+ idx)))))))
@ -420,6 +415,9 @@
(define (gnc:time64-next-day t64) (define (gnc:time64-next-day t64)
(incdate t64 DayDelta)) (incdate t64 DayDelta))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; relative-date functions start here
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:reldate-get-symbol x) (vector-ref x 0)) (define (gnc:reldate-get-symbol x) (vector-ref x 0))
(define (gnc:reldate-get-string x) (vector-ref x 1)) (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:reldate-get-fn x) (vector-ref x 3))
(define (gnc:make-reldate-hash hash reldate-list) (define (gnc:make-reldate-hash hash reldate-list)
(issue-deprecation-warning "gnc:make-reldate-hash is deprecated.")
(map (lambda (reldate) (hash-set! (map (lambda (reldate) (hash-set!
hash hash
(gnc:reldate-get-symbol reldate) (gnc:reldate-get-symbol reldate)
reldate)) reldate))
reldate-list)) 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 '()) ;; the globally available hash of reldates (hash-key = reldate
;; symbols, hash-value = a vector, reldate data). aim to deprecate it
(define gnc:relative-date-hash (make-hash-table 23)) ;; being exported.
(define gnc:relative-date-hash (make-hash-table))
(define (gnc:get-absolute-from-relative-date date-symbol) (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))) (let ((rel-date-data (hash-ref gnc:relative-date-hash date-symbol)))
(if rel-date-data (if rel-date-data
((gnc:reldate-get-fn rel-date-data)) ((gnc:reldate-get-fn rel-date-data))
@ -452,19 +455,26 @@ Defaulting to today."))
(current-time))))) (current-time)))))
(define (gnc:get-relative-date-strings date-symbol) (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))) (let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(cons (gnc:reldate-get-string rel-date-info) (cons (gnc:reldate-get-string rel-date-info)
(gnc:relate-get-desc rel-date-info)))) (gnc:relate-get-desc rel-date-info))))
(define (gnc:get-relative-date-string date-symbol) (define (gnc:get-relative-date-string date-symbol)
;; used in options.scm
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol))) (let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(gnc:reldate-get-string rel-date-info))) (gnc:reldate-get-string rel-date-info)))
(define (gnc:get-relative-date-desc date-symbol) (define (gnc:get-relative-date-desc date-symbol)
;; used in options.scm
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol))) (let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(gnc:reldate-get-desc rel-date-info))) (gnc:reldate-get-desc rel-date-info)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; end relative-date functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:get-start-cal-year) (define (gnc:get-start-cal-year)
(let ((now (gnc-localtime (current-time)))) (let ((now (gnc-localtime (current-time))))
(set-tm:sec now 0) (set-tm:sec now 0)
@ -814,6 +824,9 @@ Defaulting to today."))
;;start-cur-fin-year start-prev-fin-year end-prev-fin-year ;;start-cur-fin-year start-prev-fin-year end-prev-fin-year
(define (gnc:reldate-initialize) (define (gnc:reldate-initialize)
(define gnc:reldate-string-db (gnc:make-string-database))
(define gnc:relative-date-values #f)
(gnc:reldate-string-db (gnc:reldate-string-db
'store 'start-cal-year-string 'store 'start-cal-year-string
(N_ "Start of this year")) (N_ "Start of this year"))
@ -1137,7 +1150,8 @@ Defaulting to today."))
(gnc:reldate-string-db 'lookup 'one-year-ahead-desc) (gnc:reldate-string-db 'lookup 'one-year-ahead-desc)
gnc:get-one-year-ahead))) gnc:get-one-year-ahead)))
;; initialise gnc:relative-date-hash
(gnc:make-reldate-hash gnc:relative-date-hash gnc:relative-date-values) (for-each
(set! gnc:reldate-list (lambda (reldate)
(map (lambda (x) (vector-ref x 0)) gnc:relative-date-values))) (hash-set! gnc:relative-date-hash (gnc:reldate-get-symbol reldate) reldate))
gnc:relative-date-values))

15
libgnucash/engine/iso-4217-currencies.xml
View File

@ -1743,7 +1743,20 @@
namespace="ISO4217" namespace="ISO4217"
exchange-code="478" exchange-code="478"
parts-per-unit="5" 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" local-symbol="UM"
/> />
<!-- "MTL" - "Maltese Lira" <!-- "MTL" - "Maltese Lira"

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

@ -472,3 +472,364 @@
income bank 109 #:description "$109 income")) income bank 109 #:description "$109 income"))
(iota 12)) (iota 12))
account-alist)) 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)))