gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Thu Jul 25 08:27:25 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/7c9d5ee7 (commit)
via https://github.com/Gnucash/gnucash/commit/e9554e39 (commit)
via https://github.com/Gnucash/gnucash/commit/54c07650 (commit)
via https://github.com/Gnucash/gnucash/commit/681e023c (commit)
via https://github.com/Gnucash/gnucash/commit/7e9ec009 (commit)
via https://github.com/Gnucash/gnucash/commit/9e3aca2e (commit)
via https://github.com/Gnucash/gnucash/commit/c3eab984 (commit)
via https://github.com/Gnucash/gnucash/commit/cf6ea4c6 (commit)
via https://github.com/Gnucash/gnucash/commit/a4811b3b (commit)
via https://github.com/Gnucash/gnucash/commit/c9cf35de (commit)
via https://github.com/Gnucash/gnucash/commit/e5b756fa (commit)
via https://github.com/Gnucash/gnucash/commit/1387c05f (commit)
from https://github.com/Gnucash/gnucash/commit/49771ee9 (commit)
commit 7c9d5ee7ee5c38015b8800daa0379c5cf812ab1b
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Jul 25 17:44:35 2019 +0800
Bug 797158 - gnc:make-account-sel-limited-option is not working
Option was being deliberately reset to default_value every time.
diff --git a/gnucash/gnome-utils/dialog-options.c b/gnucash/gnome-utils/dialog-options.c
index e3ae2a32b..f8d66fafd 100644
--- a/gnucash/gnome-utils/dialog-options.c
+++ b/gnucash/gnome-utils/dialog-options.c
@@ -2710,9 +2710,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);
commit e9554e39b448bf945fc0fa74915dd9f62e5fb150
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Jul 21 22:56:11 2019 +0800
[test-stress-options] improve coverage
* improve documentation
* reuse (create-test-data) for various regular transactions
* run (create-test-invoice-data) for business invoices
* fix max arguments which would crash for reports without options
* if report has start-date and end-date, insert valid dates to ensure
report runs on non-null book data.
* enable testing of previously disabled reports
* also dump book and invoices generated in populated book
* modify output to show full backtrace on error: In case of test
failure, previous would show a shortened exception name. Change to
display full backtrace, similar to crashing in live code. Uses
gnc:apply-with-error-handling existing API call.
Also clean up code.
diff --git a/gnucash/report/standard-reports/test/test-stress-options.scm b/gnucash/report/standard-reports/test/test-stress-options.scm
index e85cd61a8..028441bd5 100644
--- a/gnucash/report/standard-reports/test/test-stress-options.scm
+++ b/gnucash/report/standard-reports/test/test-stress-options.scm
@@ -11,49 +11,77 @@
(use-modules (gnucash report taxinvoice))
(use-modules (gnucash report report-system))
(use-modules (gnucash report report-system test test-extras))
+(use-modules (srfi srfi-9))
(use-modules (srfi srfi-64))
(use-modules (srfi srfi-98))
(use-modules (gnucash engine test 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
@@ -64,6 +92,8 @@
(test-begin "stress options")
(generate-optionslist)
(tests)
+ (gnc:dump-book)
+ (gnc:dump-invoices)
(test-end "stress options"))
(define jennypath
@@ -89,19 +119,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)))
@@ -111,108 +141,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
- (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
@@ -222,63 +242,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)
@@ -293,15 +256,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
@@ -312,4 +266,5 @@
(define (tests)
(run-tests "with empty book")
(create-test-data)
+ (create-test-invoice-data)
(run-tests "on a populated book"))
commit 54c076504430677d38beca09cbf6c6665f9c14d7
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Jul 22 21:24:28 2019 +0800
[test-invoice] modified to call (create-test-invoice-data)
test-invoice will call (create-business-test-data) to create the 8
sample invoices as previously generated.
diff --git a/gnucash/report/business-reports/test/test-invoice.scm b/gnucash/report/business-reports/test/test-invoice.scm
index 17db4d12d..d6a3588b4 100644
--- a/gnucash/report/business-reports/test/test-invoice.scm
+++ b/gnucash/report/business-reports/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")))
commit 681e023cd57f4dc77eccc6a95a58b729c5957541
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Jul 24 22:58:40 2019 +0800
[date-utilities][API] deprecate unused exports, add comments
* deprecated:
gnc:make-reldate-hash
gnc:reldate-string-db
gnc:relative-date-values
gnc:get-relative-date-strings
* remove gnc:reldate-list, unused
* comment sections
diff --git a/libgnucash/app-utils/app-utils.scm b/libgnucash/app-utils/app-utils.scm
index 325ec507e..f4437a2af 100644
--- a/libgnucash/app-utils/app-utils.scm
+++ b/libgnucash/app-utils/app-utils.scm
@@ -227,12 +227,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 7e63017b9..e2e8216ac 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.
@@ -414,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))
@@ -421,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))
-
-(define gnc:relative-date-values '())
+;; 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-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))
@@ -446,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)
@@ -808,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"))
@@ -1131,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))
commit 7e9ec00906a3100f7a8cd1a0f97df1a8eb480050
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Jul 24 23:44:24 2019 +0800
[date-utilities] tidy up gnc:make-date-interval-list
diff --git a/libgnucash/app-utils/date-utilities.scm b/libgnucash/app-utils/date-utilities.scm
index f954d13fd..7e63017b9 100644
--- a/libgnucash/app-utils/date-utilities.scm
+++ b/libgnucash/app-utils/date-utilities.scm
@@ -249,6 +249,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 +260,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)))))))
commit 9e3aca2ea9eebec58449d078590a3fd235b44678
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Jul 23 22:04:59 2019 +0800
[balsheet-pnl] fixcrash: price-conversion with 'overall-period
previously price-conversion with overall-period would fail when
considering the pricing date for the overall-period column. Use the
last date for the overall-period.
diff --git a/gnucash/report/standard-reports/balsheet-pnl.scm b/gnucash/report/standard-reports/balsheet-pnl.scm
index 6ad0a19a6..5bf1c2f98 100644
--- a/gnucash/report/standard-reports/balsheet-pnl.scm
+++ b/gnucash/report/standard-reports/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
commit c3eab984ce152a561229f42a1f9f468f4ff62de2
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Jul 23 22:04:24 2019 +0800
[average-balance] fixcrash: asset-accounts present but no splits
restore the analyze-splits function. previously it would run on an
empty splitlist (obtained via empty accounts for example) and crash
with div/0. this commit will break loop back to analyze-splits
function, and only call it if the splitlist is not null.
diff --git a/gnucash/report/standard-reports/average-balance.scm b/gnucash/report/standard-reports/average-balance.scm
index e07383491..e0308299e 100644
--- a/gnucash/report/standard-reports/average-balance.scm
+++ b/gnucash/report/standard-reports/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)
commit cf6ea4c612e7748206b018bb279b16ade903a919
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Jul 22 19:57:30 2019 +0800
[report-utilities] update gnc:dump-book
gnc:dump-book also shows
* account balances
* split memo and reconcile status
Exmaple:
Account: <Root.A/Payable> Comm<USD> Type<A/Payable>
n Split: 09/03/80 Amt<-$6.00> Val<-$6.00> Desc<vend-1-name> Memo<vendor-bill>
c Split: 09/04/80 Amt<-$6.00> Val<-$6.00> Desc<emp-1-name> Memo<emp-bill>
y Split: 09/06/80 Amt<$6.00> Val<$6.00> Desc<vend-1-name> Memo<vend-credit-note>
f Split: 09/07/80 Amt<$6.00> Val<$6.00> Desc<emp-1-name> Memo<emp-credit-note>
Balance: $0.00 Cleared: $0.00 Reconciled: $0.00
diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm
index 3d5e140b8..ef6050bbe 100644
--- a/gnucash/report/report-system/report-utilities.scm
+++ b/gnucash/report/report-system/report-utilities.scm
@@ -1173,6 +1173,7 @@ flawed. see report-utilities.scm. please update reports.")
;; 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"
@@ -1184,7 +1185,8 @@ flawed. see report-utilities.scm. please update reports.")
(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
@@ -1194,13 +1196,28 @@ flawed. see report-utilities.scm. please update reports.")
(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))))
@@ -1218,7 +1235,7 @@ flawed. see report-utilities.scm. please update reports.")
(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)))
commit a4811b3b46230e2bbc0cafda1eb93d5bd9225d9b
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Jul 21 22:55:38 2019 +0800
[test-extras] add (create-test-invoice-data) for tests
this function creates some business data. moved from test-invoice.scm
without the invoice-specific tests. verified all invoices/bills are
created correctly.
it returns a vector-list of the 8 invoices generated.
diff --git a/libgnucash/engine/test/test-extras.scm b/libgnucash/engine/test/test-extras.scm
index 6d53edd77..84e23deed 100644
--- a/libgnucash/engine/test/test-extras.scm
+++ b/libgnucash/engine/test/test-extras.scm
@@ -472,3 +472,364 @@
income bank 109 #:description "$109 income"))
(iota 12))
account-alist))
+
+;; creates 8 invoices. (1) customer-invoice (2) customer's job's
+;; invoice (3) vendor bill (4) employee bill (5) customer credit-note
+;; (6) vendor credit-note (7) employee credit-note (8)
+;; customer-invoice with various combinations of entries. in addition,
+;; this function will return the vector-list of invoices created.
+(define-public (create-test-invoice-data)
+ (define USD (mnemonic->commodity "USD"))
+ (define structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
+ (cons 'commodity USD))
+ (list "Asset"
+ (list "Bank"))
+ (list "VAT"
+ (list "VAT-on-Purchases")
+ (list "VAT-on-Sales" (list (cons 'type ACCT-TYPE-LIABILITY))))
+ (list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
+ (list "Expense" (list (cons 'type ACCT-TYPE-EXPENSE)))
+ (list "A/Receivable" (list (cons 'type ACCT-TYPE-RECEIVABLE)))
+ (list "A/Payable" (list (cons 'type ACCT-TYPE-PAYABLE)))))
+ (let* ((env (create-test-env))
+ (account-alist (env-create-account-structure-alist env structure))
+ (bank (cdr (assoc "Bank" account-alist)))
+ (income (cdr (assoc "Income" account-alist)))
+ (expense (cdr (assoc "Expense" account-alist)))
+ (vat-sales (cdr (assoc "VAT-on-Sales" account-alist)))
+ (vat-purchases (cdr (assoc "VAT-on-Purchases" account-alist)))
+ (receivable (cdr (assoc "A/Receivable" account-alist)))
+ (payable (cdr (assoc "A/Payable" account-alist)))
+ (YEAR (gnc:time64-get-year (gnc:get-today)))
+
+ (cust-1 (let ((cust-1 (gncCustomerCreate (gnc-get-current-book))))
+ (gncCustomerSetID cust-1 "cust-1-id")
+ (gncCustomerSetName cust-1 "cust-1-name")
+ (gncCustomerSetNotes cust-1 "cust-1-notes")
+ (gncCustomerSetCurrency cust-1 USD)
+ (gncCustomerSetTaxIncluded cust-1 1) ;1 = GNC-TAXINCLUDED-YES
+ cust-1))
+
+ (owner-1 (let ((owner-1 (gncOwnerNew)))
+ (gncOwnerInitCustomer owner-1 cust-1)
+ owner-1))
+
+ ;; inv-1 is generated for a customer
+ (inv-1 (let ((inv-1 (gncInvoiceCreate (gnc-get-current-book))))
+ (gncInvoiceSetOwner inv-1 owner-1)
+ (gncInvoiceSetNotes inv-1 "inv-1-notes")
+ (gncInvoiceSetBillingID inv-1 "inv-1-billing-id")
+ (gncInvoiceSetCurrency inv-1 USD)
+ inv-1))
+
+ (job-1 (let ((job-1 (gncJobCreate (gnc-get-current-book))))
+ (gncJobSetID job-1 "job-1-id")
+ (gncJobSetName job-1 "job-1-name")
+ (gncJobSetOwner job-1 owner-1)
+ job-1))
+
+ (owner-2 (let ((owner-2 (gncOwnerNew)))
+ (gncOwnerInitJob owner-2 job-1)
+ owner-2))
+
+ ;; inv-2 is generated from a customer's job
+ (inv-2 (let ((inv-2 (gncInvoiceCreate (gnc-get-current-book))))
+ (gncInvoiceSetOwner inv-2 owner-2)
+ (gncInvoiceSetNotes inv-2 "inv-2-notes")
+ (gncInvoiceSetCurrency inv-2 USD)
+ inv-2))
+
+ (vend-1 (let ((vend-1 (gncVendorCreate (gnc-get-current-book))))
+ (gncVendorSetID vend-1 "vend-1-id")
+ (gncVendorSetName vend-1 "vend-1-name")
+ (gncVendorSetNotes vend-1 "vend-1-notes")
+ (gncVendorSetCurrency vend-1 USD)
+ (gncVendorSetTaxIncluded vend-1 1) ;1 = GNC-TAXINCLUDED-YES
+ vend-1))
+
+ (owner-3 (let ((owner-3 (gncOwnerNew)))
+ (gncOwnerInitVendor owner-3 vend-1)
+ owner-3))
+
+ ;; inv-3 is generated from a vendor
+ (inv-3 (let ((inv-3 (gncInvoiceCreate (gnc-get-current-book))))
+ (gncInvoiceSetOwner inv-3 owner-3)
+ (gncInvoiceSetNotes inv-3 "inv-3-notes")
+ (gncInvoiceSetCurrency inv-3 USD)
+ inv-3))
+
+ (emp-1 (let ((emp-1 (gncEmployeeCreate (gnc-get-current-book))))
+ (gncEmployeeSetID emp-1 "emp-1-id")
+ (gncEmployeeSetCurrency emp-1 USD)
+ (gncEmployeeSetName emp-1 "emp-1-name")
+ emp-1))
+
+ (owner-4 (let ((owner-4 (gncOwnerNew)))
+ (gncOwnerInitEmployee owner-4 emp-1)
+ owner-4))
+
+ ;; inv-4 is generated for an employee
+ (inv-4 (let ((inv-4 (gncInvoiceCreate (gnc-get-current-book))))
+ (gncInvoiceSetOwner inv-4 owner-4)
+ (gncInvoiceSetNotes inv-4 "inv-4-notes")
+ (gncInvoiceSetCurrency inv-4 USD)
+ inv-4))
+
+ ;; inv-5 cust-credit-note
+ (inv-5 (let ((inv-5 (gncInvoiceCopy inv-1)))
+ (gncInvoiceSetIsCreditNote inv-5 #t)
+ (gncInvoiceSetCurrency inv-5 USD)
+ inv-5))
+
+ ;; inv-6 vend-credit-note
+ (inv-6 (let ((inv-6 (gncInvoiceCopy inv-3)))
+ (gncInvoiceSetIsCreditNote inv-6 #t)
+ (gncInvoiceSetCurrency inv-6 USD)
+ inv-6))
+
+ ;; inv-7 emp-credit-note
+ (inv-7 (let ((inv-7 (gncInvoiceCopy inv-4)))
+ (gncInvoiceSetIsCreditNote inv-7 #t)
+ (gncInvoiceSetCurrency inv-7 USD)
+ inv-7))
+
+ (inv-8 (let ((inv-8 (gncInvoiceCreate (gnc-get-current-book))))
+ (gncInvoiceSetOwner inv-8 owner-1)
+ (gncInvoiceSetCurrency inv-8 USD)
+ inv-8))
+
+ (standard-vat-sales-tt
+ (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
+ (gncTaxTableIncRef tt)
+ (gncTaxTableSetName tt "10% vat on sales")
+ (let ((entry (gncTaxTableEntryCreate)))
+ (gncTaxTableEntrySetAccount entry vat-sales)
+ (gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
+ (gncTaxTableEntrySetAmount entry 10)
+ (gncTaxTableAddEntry tt entry))
+ tt))
+
+ (standard-vat-purchases-tt
+ (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
+ (gncTaxTableIncRef tt)
+ (gncTaxTableSetName tt "10% vat on purchases")
+ (let ((entry (gncTaxTableEntryCreate)))
+ (gncTaxTableEntrySetAccount entry vat-purchases)
+ (gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
+ (gncTaxTableEntrySetAmount entry 10)
+ (gncTaxTableAddEntry tt entry))
+ tt)))
+
+ ;; entry-1 2 widgets of $3 = $6
+ (let ((entry-1 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-1 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-1 "entry-1-desc")
+ (gncEntrySetAction entry-1 "entry-1-action")
+ (gncEntrySetNotes entry-1 "entry-1-notes")
+ (gncEntrySetInvAccount entry-1 income)
+ (gncEntrySetDocQuantity entry-1 2 #f)
+ (gncEntrySetInvPrice entry-1 3)
+ (gncInvoiceAddEntry inv-1 entry-1))
+
+ ;; entry-inv-2 2 widgets of $3 = $6
+ (let ((entry-inv-2 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-inv-2 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-inv-2 "entry-inv-2-desc")
+ (gncEntrySetAction entry-inv-2 "entry-inv-2-action")
+ (gncEntrySetNotes entry-inv-2 "entry-inv-2-notes")
+ (gncEntrySetInvAccount entry-inv-2 income)
+ (gncEntrySetDocQuantity entry-inv-2 2 #f)
+ (gncEntrySetInvPrice entry-inv-2 3)
+ (gncInvoiceAddEntry inv-2 entry-inv-2))
+
+ ;; entry-inv-3 2 widgets of $3 = $6
+ (let ((entry-inv-3 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-inv-3 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-inv-3 "entry-inv-3-desc")
+ (gncEntrySetAction entry-inv-3 "entry-inv-3-action")
+ (gncEntrySetNotes entry-inv-3 "entry-inv-3-notes")
+ (gncEntrySetBillAccount entry-inv-3 expense)
+ (gncEntrySetDocQuantity entry-inv-3 2 #f)
+ (gncEntrySetBillPrice entry-inv-3 3)
+ (gncInvoiceAddEntry inv-3 entry-inv-3))
+
+ ;; entry-inv-4 2 widgets of $3 = $6
+ (let ((entry-inv-4 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-inv-4 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-inv-4 "entry-inv-4-desc")
+ (gncEntrySetAction entry-inv-4 "entry-inv-4-action")
+ (gncEntrySetNotes entry-inv-4 "entry-inv-4-notes")
+ (gncEntrySetBillAccount entry-inv-4 expense)
+ (gncEntrySetDocQuantity entry-inv-4 2 #f)
+ (gncEntrySetBillPrice entry-inv-4 3)
+ (gncInvoiceAddEntry inv-4 entry-inv-4))
+
+ ;; entry-5 2 widgets of $3 = $6
+ (let ((entry-5 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-5 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-5 "entry-5-desc")
+ (gncEntrySetAction entry-5 "entry-5-action")
+ (gncEntrySetNotes entry-5 "entry-5-notes")
+ (gncEntrySetInvAccount entry-5 income)
+ (gncEntrySetDocQuantity entry-5 2 #t)
+ (gncEntrySetInvPrice entry-5 3)
+ (gncInvoiceAddEntry inv-5 entry-5))
+
+ (let ((entry-inv-6 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-inv-6 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-inv-6 "entry-inv-6-desc")
+ (gncEntrySetAction entry-inv-6 "entry-inv-6-action")
+ (gncEntrySetNotes entry-inv-6 "entry-inv-6-notes")
+ (gncEntrySetBillAccount entry-inv-6 expense)
+ (gncEntrySetDocQuantity entry-inv-6 2 #t)
+ (gncEntrySetBillPrice entry-inv-6 3)
+ (gncInvoiceAddEntry inv-6 entry-inv-6))
+
+ ;; entry-inv-7 2 widgets of $3 = $6
+ (let ((entry-inv-7 (gncEntryCreate (gnc-get-current-book))))
+ (gncEntrySetDateGDate entry-inv-7 (time64-to-gdate (current-time)))
+ (gncEntrySetDescription entry-inv-7 "entry-inv-7-desc")
+ (gncEntrySetAction entry-inv-7 "entry-inv-7-action")
+ (gncEntrySetNotes entry-inv-7 "entry-inv-7-notes")
+ (gncEntrySetBillAccount entry-inv-7 expense)
+ (gncEntrySetDocQuantity entry-inv-7 2 #t)
+ (gncEntrySetBillPrice entry-inv-7 3)
+ (gncInvoiceAddEntry inv-7 entry-inv-7))
+
+ (gncInvoicePostToAccount inv-1 receivable
+ (gnc-dmy2time64 1 9 1980)
+ (gnc-dmy2time64 1 9 1980)
+ "cust-invoice"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-2 receivable
+ (gnc-dmy2time64 2 9 1980)
+ (gnc-dmy2time64 3 9 1980)
+ "job-invoice"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-3 payable
+ (gnc-dmy2time64 3 9 1980)
+ (gnc-dmy2time64 3 9 1980)
+ "vendor-bill"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-4 payable
+ (gnc-dmy2time64 4 9 1980)
+ (gnc-dmy2time64 4 9 1980)
+ "emp-bill"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-5 receivable
+ (gnc-dmy2time64 5 9 1980)
+ (gnc-dmy2time64 5 9 1980)
+ "cust-credit-note"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-6 payable
+ (gnc-dmy2time64 6 9 1980)
+ (gnc-dmy2time64 6 9 1980)
+ "vend-credit-note"
+ #t #f)
+
+ (gncInvoicePostToAccount inv-7 payable
+ (gnc-dmy2time64 7 9 1980)
+ (gnc-dmy2time64 7 9 1980)
+ "emp-credit-note"
+ #t #f)
+
+ (let* ((taxrate 109/10)
+ (discount 7/2)
+ (unitprice 777/4)
+ (quantity 11)
+ (combo-vat-sales-tt
+ (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
+ (gncTaxTableIncRef tt)
+ (gncTaxTableSetName tt (format #f "~a% vat on sales" taxrate))
+ (let ((entry (gncTaxTableEntryCreate)))
+ (gncTaxTableEntrySetAccount entry vat-sales)
+ (gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
+ (gncTaxTableEntrySetAmount entry taxrate)
+ (gncTaxTableAddEntry tt entry))
+ tt))
+ (order (let ((order (gncOrderCreate (gnc-get-current-book))))
+ (gncOrderSetID order "order-id")
+ (gncOrderSetOwner order owner-1)
+ (gncOrderSetReference order "order-ref")
+ (gncOrderSetActive order #t)
+ order))
+ (billterm (let ((term (gncBillTermCreate (gnc-get-current-book))))
+ (gncBillTermSetName term "billterm-name")
+ (gncBillTermSetDescription term "billterm-desc")
+ (gncBillTermSetType term 1) ;1 = GNC-TERM-TYPE-DAYS
+ (gncBillTermSetDueDays term 8)
+ term)))
+ (gncInvoiceSetTerms inv-8 billterm)
+ (for-each
+ (lambda (combo)
+ (let* ((each-entry (gncEntryCreate (gnc-get-current-book)))
+ (taxable? (= (vector-ref combo 0) 1))
+ (tax-included? (= (vector-ref combo 1) 1))
+ (discount-type (vector-ref combo 2))
+ (discount-how (vector-ref combo 3))
+ (desc (format #f "taxable=~a tax-included=~a discount-type=~a discount-how=~a"
+ (if taxable? "Y" "N")
+ (if tax-included? "Y" "N")
+ (gncAmountTypeToString discount-type)
+ (gncEntryDiscountHowToString discount-how))))
+ (gncEntrySetDateGDate each-entry (time64-to-gdate (current-time)))
+ (gncEntrySetDescription each-entry desc)
+ (gncEntrySetAction each-entry "action")
+ (gncEntrySetInvAccount each-entry income)
+ (gncEntrySetDocQuantity each-entry quantity #f)
+ (gncEntrySetInvPrice each-entry unitprice)
+ (gncEntrySetInvDiscount each-entry discount)
+ (gncEntrySetInvDiscountType each-entry discount-type)
+ (gncEntrySetInvDiscountHow each-entry discount-how)
+ (gncEntrySetInvTaxable each-entry taxable?)
+ (gncEntrySetInvTaxIncluded each-entry tax-included?)
+ (gncEntrySetInvTaxTable each-entry combo-vat-sales-tt)
+ (gncOrderAddEntry order each-entry)
+ ;; FIXME: Note: The following function hides a subtle
+ ;; bug. It aims to retrieve & dump the entry description
+ ;; and amount. Unfortunately the (gncEntryGetDocValue)
+ ;; function will subtly modify the entry amounts by a
+ ;; fraction; this means that the subsequent invoice payment
+ ;; will not make the invoice amount completely zero. If the
+ ;; following statement is uncommented, test-invoice will
+ ;; fail because the (gncInvoiceIsPaid) final test will
+ ;; fail.
+ ;; (format #t "inv-8: adding ~a to invoice, entry amount is ~a\n"
+ ;; desc
+ ;; (exact->inexact (gncEntryGetDocValue each-entry #f #t #f)))
+ (gncInvoiceAddEntry inv-8 each-entry)))
+ (list
+ ;; the following list specifies combinations to test gncEntry options
+ ;; thanks to rgmerk and to jenny for idea how to generate list of options
+ ;; (vector Taxable?(1=#t) Tax-included?(1=#t) DiscountType DiscountHow)
+ (vector 1 2 1 1)
+ (vector 2 1 2 2)
+ (vector 1 1 2 3)
+ (vector 2 2 1 3)
+ (vector 2 1 1 1)
+ (vector 1 2 2 2)
+ (vector 1 2 1 2)
+ (vector 1 1 2 1)))
+
+ (gncInvoiceSetNotes
+ inv-8 (format #f "tax=~a%, discount=~a, qty=~a, price=~a"
+ taxrate discount quantity unitprice))
+
+ (gncInvoicePostToAccount inv-8 receivable
+ (gnc-dmy2time64 8 9 1980)
+ (gnc-dmy2time64 8 9 1980)
+ "trans-posting-memo"
+ #t #f)
+
+ (gncInvoiceApplyPayment inv-8 '() bank 1747918/100 1
+ (gnc-dmy2time64 10 9 1980)
+ "trans-payment-memo-1"
+ "trans-payment-num-1"))
+
+ (vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8)))
commit c9cf35de5de765f7769a5ac21b106e96495e9ef4
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Jul 21 20:45:43 2019 +0800
[commodity-utils] document gnc:case-exchange-time-fn
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 8360a6793..3e1ab68f2 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -849,9 +849,19 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; the value of 'source-option', whose possible values are set in
;; gnc:options-add-price-source!.
;;
-;; <int> start-percent, delta-percent: Fill in the [start:start+delta]
+;; arguments:
+;; source-option: symbol 'average-cost 'weighted-average
+;; 'pricedb-nearest 'pricedb-latest
+;; report-currency: the target currency
+;; commodity-list: the list of commodities to generate an exchange-fn for
+;; to-date-tp (time64): last date to analyse transactions
+;; start-percent, delta-percent: Fill in the [start:start+delta]
;; section of the progress bar while running this function.
;;
+;; returns: a function which takes 3 arguments, and returns a gnc-monetary
+;; foreign - foreign commodity/currency
+;; domestic - a gnc-monetary pair
+;; date - time64 price
(define (gnc:case-exchange-time-fn
source-option report-currency commodity-list to-date-tp
start-percent delta-percent)
commit e5b756fada5464a6c81ca1445523f4b5e6f8739d
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Jul 21 20:35:28 2019 +0800
[commodity-utils] refactor gnc:pricelist-price-find-nearest
instead of O(3n), this implementation is O(n)
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 592da3648..8360a6793 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -295,27 +295,21 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; pricelist comes from
;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or,
;; if pricelist was empty, #f.
-(define (gnc:pricelist-price-find-nearest
- pricelist date)
- (let* ((later (find (lambda (p)
- (< date (car p)))
- pricelist))
- (earlierlist (take-while
- (lambda (p)
- (>= date (car p)))
- pricelist))
- (earlier (and (not (null? earlierlist))
- (last earlierlist))))
-
- (if (and earlier later)
- (if (< (abs (- date (car earlier)))
- (abs (- date (car later))))
- (cadr earlier)
- (cadr later))
- (or
- (and earlier (cadr earlier))
- (and later (cadr later))))))
-
+(define (gnc:pricelist-price-find-nearest pricelist date)
+ (let lp ((pricelist pricelist))
+ (cond
+ ((null? pricelist) #f)
+ ((null? (cdr pricelist)) (cadr (car pricelist)))
+ (else
+ (let ((earlier (car pricelist))
+ (later (cadr pricelist)))
+ (cond
+ ((< (car later) date)
+ (lp (cdr pricelist)))
+ ((< (- date (car earlier)) (- (car later) date))
+ (cadr earlier))
+ (else
+ (cadr later))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to get one price at a given time (i.e. not time-variant).
commit 1387c05f4d172898429b470da362178712faf992
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sun Jul 21 20:34:04 2019 +0800
[test-commodity-utils] augment weighted-average tests
this is to increase 100% coverage pricealist-nearest finder
diff --git a/gnucash/report/report-system/test/test-commodity-utils.scm b/gnucash/report/report-system/test/test-commodity-utils.scm
index 97d104d05..3add3ead2 100644
--- a/gnucash/report/report-system/test/test-commodity-utils.scm
+++ b/gnucash/report/report-system/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
Summary of changes:
gnucash/gnome-utils/dialog-options.c | 5 +-
.../report/business-reports/test/test-invoice.scm | 331 ++-----------------
.../report/report-system/commodity-utilities.scm | 48 +--
gnucash/report/report-system/report-utilities.scm | 25 +-
.../report-system/test/test-commodity-utils.scm | 34 +-
.../report/standard-reports/average-balance.scm | 242 +++++++-------
gnucash/report/standard-reports/balsheet-pnl.scm | 24 +-
.../standard-reports/test/test-stress-options.scm | 341 +++++++++----------
libgnucash/app-utils/app-utils.scm | 10 +-
libgnucash/app-utils/date-utilities.scm | 60 ++--
libgnucash/engine/test/test-extras.scm | 361 +++++++++++++++++++++
11 files changed, 805 insertions(+), 676 deletions(-)
More information about the gnucash-changes
mailing list