diff --git a/CMakeLists.txt b/CMakeLists.txt index d9c08ebf5f..2b5871454e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -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) diff --git a/common/cmake_modules/GncAddTest.cmake b/common/cmake_modules/GncAddTest.cmake index c00c8292ef..bb47af9670 100644 --- a/common/cmake_modules/GncAddTest.cmake +++ b/common/cmake_modules/GncAddTest.cmake @@ -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) diff --git a/gnucash/gnome-utils/dialog-options.c b/gnucash/gnome-utils/dialog-options.c index 4e0807c721..ff8a86a641 100644 --- a/gnucash/gnome-utils/dialog-options.c +++ b/gnucash/gnome-utils/dialog-options.c @@ -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); diff --git a/gnucash/report/commodity-utilities.scm b/gnucash/report/commodity-utilities.scm index 5e0ab93c19..bb12560f25 100644 --- a/gnucash/report/commodity-utilities.scm +++ b/gnucash/report/commodity-utilities.scm @@ -263,27 +263,21 @@ ;; pricelist comes from ;; e.g. gnc:get-commodity-totalavg-prices. Returns a 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!. ;; -;; 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) diff --git a/gnucash/report/report-utilities.scm b/gnucash/report/report-utilities.scm index 5e15e5f194..a9dfdd133b 100644 --- a/gnucash/report/report-utilities.scm +++ b/gnucash/report/report-utilities.scm @@ -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))) diff --git a/gnucash/report/reports/example/average-balance.scm b/gnucash/report/reports/example/average-balance.scm index f3513355e0..f706af945c 100644 --- a/gnucash/report/reports/example/average-balance.scm +++ b/gnucash/report/reports/example/average-balance.scm @@ -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) diff --git a/gnucash/report/reports/standard/balsheet-pnl.scm b/gnucash/report/reports/standard/balsheet-pnl.scm index 639d036cc3..dcdd835ce4 100644 --- a/gnucash/report/reports/standard/balsheet-pnl.scm +++ b/gnucash/report/reports/standard/balsheet-pnl.scm @@ -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 diff --git a/gnucash/report/reports/standard/test/test-invoice.scm b/gnucash/report/reports/standard/test/test-invoice.scm index f5a5ac6997..15c98d8ce5 100644 --- a/gnucash/report/reports/standard/test/test-invoice.scm +++ b/gnucash/report/reports/standard/test/test-invoice.scm @@ -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"))) diff --git a/gnucash/report/reports/standard/test/test-stress-options.scm b/gnucash/report/reports/standard/test/test-stress-options.scm index 7e73076ed9..0f1861551d 100644 --- a/gnucash/report/reports/standard/test/test-stress-options.scm +++ b/gnucash/report/reports/standard/test/test-stress-options.scm @@ -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")) diff --git a/gnucash/report/test/test-commodity-utils.scm b/gnucash/report/test/test-commodity-utils.scm index cb31104c6d..42f75fc592 100644 --- a/gnucash/report/test/test-commodity-utils.scm +++ b/gnucash/report/test/test-commodity-utils.scm @@ -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 diff --git a/libgnucash/app-utils/app-utils.scm b/libgnucash/app-utils/app-utils.scm index bcfd9ad140..1f47907b14 100644 --- a/libgnucash/app-utils/app-utils.scm +++ b/libgnucash/app-utils/app-utils.scm @@ -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) diff --git a/libgnucash/app-utils/date-utilities.scm b/libgnucash/app-utils/date-utilities.scm index f954d13fdd..e2e8216ac2 100644 --- a/libgnucash/app-utils/date-utilities.scm +++ b/libgnucash/app-utils/date-utilities.scm @@ -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)) diff --git a/libgnucash/engine/iso-4217-currencies.xml b/libgnucash/engine/iso-4217-currencies.xml index 2b71def0cf..a17e75fe84 100644 --- a/libgnucash/engine/iso-4217-currencies.xml +++ b/libgnucash/engine/iso-4217-currencies.xml @@ -1743,7 +1743,20 @@ namespace="ISO4217" exchange-code="478" parts-per-unit="5" - smallest-fraction="5" + smallest-fraction="100" + local-symbol="UM" +/> + +