1(use-modules (gnucash engine))
2(use-modules (gnucash app-utils))
3(use-modules (tests test-engine-extras))
4(use-modules (gnucash reports))
5(use-modules (gnucash report stylesheets plain))
6(use-modules (gnucash report))
7(use-modules (tests test-report-extras))
8(use-modules (srfi srfi-1))
9(use-modules (srfi srfi-64))
10(use-modules (tests srfi64-extras))
11(use-modules (sxml simple))
12(use-modules (sxml xpath))
13(use-modules (system vm coverage))
14(use-modules (system vm vm))
15
16(define uuid-list
17  (list (cons 'employee "08ae9c2e884b4f9787144f47eacd7f44-old")
18        (cons 'vendor "d7d1e53505ee4b1b82efad9eacedaea0-old")
19        (cons 'customer "c146317be32e4948a561ec7fc89d15c1-old")
20        (cons 'customer-new "c146317be32e4948a561ec7fc89d15c1")
21        (cons 'job "5518ac227e474f47a34439f2d4d049de-old")))
22
23(setlocale LC_ALL "C")
24
25(define (run-test)
26  (if #f
27      (coverage-test run-test-proper)
28      (run-test-proper)))
29
30(define (coverage-test tester)
31  (let* ((currfile (dirname (current-filename)))
32         (path (string-take currfile (string-rindex currfile #\/))))
33    (add-to-load-path path))
34  (call-with-values
35      (lambda()
36        (with-code-coverage tester))
37    (lambda (data result)
38      (let ((port (open-output-file "/tmp/lcov.info")))
39        (coverage-data->lcov data port)
40        (close port)))))
41
42(define (teardown)
43  (gnc-clear-current-session))
44
45(define (run-test-proper)
46  (let ((saved-format (qof-date-format-get)))
47    (qof-date-format-set QOF-DATE-FORMAT-ISO)
48    (test-runner-factory gnc:test-runner)
49    (test-begin "test-owner-report")
50    (test-group-with-cleanup "test-owner-report"
51      (owner-tests)
52      (teardown))
53    (qof-date-format-set saved-format)
54    (test-end "test-owner-report")))
55
56(define (sxml-get-row-col sxml row col)
57  (sxml->table-row-col sxml 3 row col))
58
59(define (set-option! options section name value)
60  (let ((option (gnc:lookup-option options section name)))
61    (if option
62        (gnc:option-set-value option value)
63        (test-assert (format #f "wrong-option ~a ~a" section name) #f))))
64
65(define (get-currency sym)
66  (gnc-commodity-table-lookup
67   (gnc-commodity-table-get-table (gnc-get-current-book))
68   (gnc-commodity-get-namespace (gnc-default-report-currency))
69   sym))
70
71(define structure
72  (list "Root" (list (cons 'type ACCT-TYPE-ASSET)
73                     (cons 'commodity (get-currency "USD")))
74        (list "Asset"
75              (list "Bank-GBP" (list (cons 'commodity (get-currency "GBP"))))
76              (list "Bank-EUR" (list (cons 'commodity (get-currency "EUR"))))
77              (list "Bank-USD"))
78        (list "VAT"
79              (list "VAT-on-Purchases")
80              (list "VAT-on-Sales" (list (cons 'type ACCT-TYPE-LIABILITY))))
81        (list "Income" (list (cons 'type ACCT-TYPE-INCOME))
82              (list "Income-USD")
83              (list "Income-GBP" (list (cons 'commodity (get-currency "GBP"))))
84              (list "Income-EUR" (list (cons 'commodity (get-currency "EUR")))))
85        (list "A/Receivable" (list (cons 'type ACCT-TYPE-RECEIVABLE))
86              (list "AR-USD")
87              (list "AR-GBP" (list (cons 'commodity (get-currency "GBP"))))
88              (list "AR-EUR" (list (cons 'commodity (get-currency "EUR")))))
89        (list "A/Payable" (list (cons 'type ACCT-TYPE-PAYABLE))
90              (list "AP-USD")
91              (list "AP-GBP" (list (cons 'commodity (get-currency "GBP"))))
92              (list "AP-EUR" (list (cons 'commodity (get-currency "EUR")))))))
93
94(define (owner-tests)
95  ;; This function will perform implementation testing on the customer report.
96  (define (options->sxml variant options test-title)
97    (define uuid (cdr (assq variant uuid-list)))
98    ;; (format #t "[~a] Options:\n~a"
99    ;;         test-title
100    ;;         (gnc:html-render-options-changed options #t))
101    (gnc:options->sxml uuid options (format #f "test-~a" variant) test-title))
102  (define (options->invoice inv)
103    (let* ((inv-uuid "5123a759ceb9483abf2182d01c140e8d") ;invoice
104           (inv-options (gnc:make-report-options inv-uuid)))
105      (set-option! inv-options "General" "Invoice Number" inv)
106      (gnc:options->sxml inv-uuid inv-options "test" "test-invoice")))
107
108  (let* ((env (create-test-env))
109         (account-alist (env-create-account-structure-alist env structure))
110         (get-acct (lambda (name)
111                     (or (assoc-ref account-alist name)
112                     (error "invalid account name" name))))
113         (YEAR (gnc:time64-get-year (gnc:get-today)))
114
115         (cust-1 (let ((cust-1 (gncCustomerCreate (gnc-get-current-book))))
116                   (gncCustomerSetID cust-1 "cust-1-id")
117                   (gncCustomerSetName cust-1 "cust-1-name")
118                   (gncCustomerSetNotes cust-1 "cust-1-notes")
119                   (gncCustomerSetCurrency cust-1 (get-currency "USD"))
120                   (gncCustomerSetTaxIncluded cust-1 1) ;1 = GNC-TAXINCLUDED-YES
121                   cust-1))
122
123         (owner-1 (let ((owner-1 (gncOwnerNew)))
124                    (gncOwnerInitCustomer owner-1 cust-1)
125                    owner-1))
126
127         ;; inv-1 is generated for a customer
128         (inv-1 (let ((inv-1 (gncInvoiceCreate (gnc-get-current-book))))
129                  (gncInvoiceSetOwner inv-1 owner-1)
130                  (gncInvoiceSetNotes inv-1 "inv-1-notes")
131                  (gncInvoiceSetBillingID inv-1 "inv-1-billing-id")
132                  (gncInvoiceSetCurrency inv-1 (get-currency "USD"))
133                  inv-1))
134
135         (job-1 (let ((job-1 (gncJobCreate (gnc-get-current-book))))
136                  (gncJobSetID job-1 "job-1-id")
137                  (gncJobSetName job-1 "job-1-name")
138                  (gncJobSetOwner job-1 owner-1)
139                  job-1))
140         (owner-2 (let ((owner-2 (gncOwnerNew)))
141                    (gncOwnerInitJob owner-2 job-1)
142                    owner-2))
143         ;; inv-2 is generated from a customer's job
144         (inv-2 (let ((inv-2 (gncInvoiceCreate (gnc-get-current-book))))
145                  (gncInvoiceSetOwner inv-2 owner-2)
146                  (gncInvoiceSetNotes inv-2 "inv-2-notes")
147                  (gncInvoiceSetCurrency inv-2 (get-currency "USD"))
148                  inv-2))
149
150         (entry (lambda (amt)
151                  (let ((entry (gncEntryCreate (gnc-get-current-book))))
152                    (gncEntrySetDateGDate entry (time64-to-gdate (current-time)))
153                    (gncEntrySetDescription entry "entry-desc")
154                    (gncEntrySetAction entry "entry-action")
155                    (gncEntrySetNotes entry "entry-notes")
156                    (gncEntrySetInvAccount entry (get-acct "Income-USD"))
157                    (gncEntrySetDocQuantity entry 1 #f)
158                    (gncEntrySetInvPrice entry amt)
159                    entry)))
160
161         ;; entry-1  1 widgets of $6 = $6
162         (entry-1 (entry 6))
163
164         ;; entry-2  3 widgets of EUR4 = EUR12
165         (entry-2 (let ((entry-2 (gncEntryCreate (gnc-get-current-book))))
166                    (gncEntrySetDateGDate entry-2 (time64-to-gdate (current-time)))
167                    (gncEntrySetDescription entry-2 "entry-2-desc")
168                    (gncEntrySetAction entry-2 "entry-2-action")
169                    (gncEntrySetNotes entry-2 "entry-2-notes")
170                    (gncEntrySetInvAccount entry-2 (get-acct "Income-EUR"))
171                    (gncEntrySetDocQuantity entry-2 3 #f)
172                    (gncEntrySetInvPrice entry-2 4)
173                    entry-2))
174
175         ;; entry-3  5 widgets of GBP7 = GBP35
176         (entry-3 (let ((entry-3 (gncEntryCreate (gnc-get-current-book))))
177                    (gncEntrySetDateGDate entry-3 (time64-to-gdate (current-time)))
178                    (gncEntrySetDescription entry-3 "entry-3-desc")
179                    (gncEntrySetAction entry-3 "entry-3-action")
180                    (gncEntrySetNotes entry-3 "entry-3-notes")
181                    (gncEntrySetInvAccount entry-3 (get-acct "Income-GBP"))
182                    (gncEntrySetDocQuantity entry-3 5 #f)
183                    (gncEntrySetInvPrice entry-3 7)
184                    entry-3))
185
186         (standard-vat-sales-tt
187          (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
188            (gncTaxTableIncRef tt)
189            (gncTaxTableSetName tt "10% vat on sales")
190            (let ((entry (gncTaxTableEntryCreate)))
191              (gncTaxTableEntrySetAccount entry (get-acct "VAT-on-Sales"))
192              (gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
193              (gncTaxTableEntrySetAmount entry 10)
194              (gncTaxTableAddEntry tt entry))
195            tt))
196
197         (standard-vat-purchases-tt
198          (let ((tt (gncTaxTableCreate (gnc-get-current-book))))
199            (gncTaxTableIncRef tt)
200            (gncTaxTableSetName tt "10% vat on purchases")
201            (let ((entry (gncTaxTableEntryCreate)))
202              (gncTaxTableEntrySetAccount entry (get-acct "VAT-on-Purchases"))
203              (gncTaxTableEntrySetType entry GNC-AMT-TYPE-PERCENT)
204              (gncTaxTableEntrySetAmount entry 10)
205              (gncTaxTableAddEntry tt entry))
206            tt)))
207
208    (define* (default-testing-options variant owner account)
209      ;; owner-report will run from 1.1.1980 to 1.7.1980
210      (let ((options (gnc:make-report-options
211                      (assq-ref uuid-list variant))))
212        (set-option! options "General"
213                     (case variant
214                       ((customer) "Customer")
215                       ((customer-new) "Customer")
216                       ((job) "Job"))
217                     owner)
218        (set-option! options "General" "From"
219                     (cons 'absolute (gnc-dmy2time64 1 1 1980)))
220        (set-option! options "General" "To"
221                     (cons 'absolute (gnc-dmy2time64 1 7 1980)))
222        (cond
223         ((eq? variant 'customer-new)
224          (set-option! options "Display Columns" "Links" 'detailed))
225         (else
226          (set-option! options "General" "Account" account)))
227        options))
228
229    ;; inv-1 $6, due 18.7.1980 after report-date i.e. "current"
230    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
231      (gncInvoiceAddEntry inv-1-copy (entry 27/4))
232      (gncInvoicePostToAccount inv-1-copy
233                               (get-acct "AR-USD")         ;post-to acc
234                               (gnc-dmy2time64 13 05 1980) ;posted
235                               (gnc-dmy2time64 18 07 1980) ;due
236                               "inv current $6.75" #t #f))
237
238    ;; inv-1-copy due 18.6.1980, <30days before report date
239    ;; amount due $12
240    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
241      (gncInvoiceAddEntry inv-1-copy (entry 4))
242      (gncInvoicePostToAccount inv-1-copy
243                               (get-acct "AR-USD")         ;post-to acc
244                               (gnc-dmy2time64 13 04 1980) ;posted
245                               (gnc-dmy2time64 18 06 1980) ;due
246                               "inv <30days $4.00" #t #f))
247
248    ;; inv-1-copy due 18.5.1980, 30-60days before report date
249    ;; amount due $6
250    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
251      (gncInvoiceAddEntry inv-1-copy (entry 17/2))
252      (gncInvoicePostToAccount inv-1-copy
253                               (get-acct "AR-USD")         ;post-to acc
254                               (gnc-dmy2time64 13 03 1980) ;posted
255                               (gnc-dmy2time64 18 05 1980) ;due
256                               "inv 30-60 $8.50" #t #f))
257
258    ;; inv-1-copy due 18.4.1980, 60-90days before report date
259    ;; amount due $6
260    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
261      (gncInvoiceAddEntry inv-1-copy (entry 15/2))
262      (gncInvoicePostToAccount inv-1-copy
263                               (get-acct "AR-USD")         ;post-to acc
264                               (gnc-dmy2time64 13 02 1980) ;posted
265                               (gnc-dmy2time64 18 04 1980) ;due
266                               "inv 60-90 $7.50" #t #f))
267
268    ;; inv-1-copy due 18.3.1980, >90days before report date
269    ;; amount due $11.50, drip-payments
270    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
271      (gncInvoiceAddEntry inv-1-copy (entry 23/2))
272      (gncInvoicePostToAccount inv-1-copy
273                               (get-acct "AR-USD")         ;post-to acc
274                               (gnc-dmy2time64 13 01 1980) ;posted
275                               (gnc-dmy2time64 18 03 1980) ;due
276                               "inv >90 $11.50" #t #f)
277      (gncInvoiceApplyPayment
278       inv-1-copy '() (get-acct "Bank-USD") 3/2 1
279       (gnc-dmy2time64 18 03 1980)
280       "inv >90 payment" "pay only $1.50")
281      (gncInvoiceApplyPayment
282       inv-1-copy '() (get-acct "Bank-USD") 2 1
283       (gnc-dmy2time64 20 03 1980)
284       "inv >90 payment" "pay only $2.00"))
285
286    ;; inv-1-copy due 18.3.1980, >90days before report date
287    ;; amount due $11.50, drip-payments
288    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
289      (gncInvoiceAddEntry inv-1-copy (entry 200))
290      (gncInvoicePostToAccount inv-1-copy
291                               (get-acct "AR-USD")         ;post-to acc
292                               (gnc-dmy2time64 18 04 1980) ;posted
293                               (gnc-dmy2time64 18 04 1980) ;due
294                               "inv $200" #t #f)
295      (gncInvoiceApplyPayment
296       inv-1-copy '() (get-acct "Bank-USD") 200 1
297       (gnc-dmy2time64 19 04 1980)
298       "inv $200" "fully paid"))
299
300    (let ((inv-1-copy (gncInvoiceCopy inv-1)))
301      (gncInvoiceAddEntry inv-1-copy (entry -3))
302      (gncInvoiceSetIsCreditNote inv-1-copy #t)
303      (gncInvoicePostToAccount inv-1-copy
304                               (get-acct "AR-USD")         ;post-to acc
305                               (gnc-dmy2time64 22 06 1980) ;posted
306                               (gnc-dmy2time64 22 06 1980) ;due
307                               "inv $3 CN" #t #f))
308
309    ;; (gnc:dump-book) (newline)
310    ;; (gnc:dump-invoices) (newline)
311    (display "customer-report tests:\n")
312    (test-begin "customer-report")
313    (let* ((options (default-testing-options 'customer owner-1 (get-acct "AR-USD")))
314           (sxml (options->sxml 'customer options "customer-report basic")))
315      (test-equal "inv-descriptions"
316        '("inv >90 $11.50" "inv 60-90 $7.50" "inv 30-60 $8.50"
317          "inv >90 payment" "inv >90 payment" "inv <30days $4.00"
318          "inv $200" "inv $200" "inv current $6.75" "inv $3 CN"
319          "$31.75" "$8.00" "$8.00")
320        (sxml-get-row-col sxml #f 5))
321      (test-equal "debit-amounts"
322        '("$11.50" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75")
323        (sxml-get-row-col sxml #f 6))
324      (test-equal "crebit-amounts"
325        '("-$1.50" "-$2.00" "-$200.00" "-$3.00")
326        (sxml-get-row-col sxml #f 7))
327      ;; from the report, find the 3rd table, last row, find embedded
328      ;; table, retrieve tr contents
329      (test-equal "aging-table"
330        '("$6.75" "$1.00" "$8.50" "$7.50" "$8.00")
331        ((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
332         sxml)))
333    (test-end "customer-report")
334
335    (display "new-owner-report tests:\n")
336    (test-begin "new-customer-report")
337    (let* ((options (default-testing-options 'customer-new
338                      owner-1 (get-acct "AR-USD")))
339           (sxml (options->sxml 'customer-new options "new-customer-report basic")))
340      (test-equal "inv-descriptions"
341        '("inv >90 $11.50" "-$2.00" "inv 60-90 $7.50" "inv 30-60 $8.50"
342          "inv >90 payment" "inv >90 payment" "inv <30days $4.00"
343          "inv $200" "inv $200" "inv current $6.75" "inv $3 CN"
344          "$31.75" "$7.50")
345        ((sxpath `(// (table 3) // tr (td 5) // *text*))
346         sxml))
347      (test-equal "credit-amounts"
348        '("$11.50" "-$2.00" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75" "$8.00")
349        ((sxpath `(// (table 3) // tr (td 6) // *text*))
350         sxml))
351      (test-equal "debit-amounts"
352        '("$1.50" "$2.00" "$200.00" "$3.00" "$31.75")
353        ((sxpath `(// (table 3) // tr (td 7) // *text*))
354         sxml))
355      (test-equal "balance-amounts"
356        '("$11.50" "$19.00" "$27.50" "$26.00" "$24.00" "$28.00"
357          "$228.00" "$28.00" "$34.75" "$31.75")
358        ((sxpath `(// (table 3) // tr (td 8) // *text*))
359         sxml))
360      (test-equal "positive-link-amounts"
361        '("-$1.50" "-$2.00" "$8.00" "$7.50" "$8.50" "$11.50" "$11.50"
362          "$4.00" "-$200.00" "$200.00" "$6.75")
363        ((sxpath `(// (table 3) // tr
364                      (td -1 (@ (equal? (class "number-cell")))) //
365                      *text*))
366         sxml))
367      (test-equal "negative-link-amounts"
368        '("-$3.00")
369        ((sxpath `(// (table 3) // tr
370                      (td -1 (@ (equal? (class "number-cell neg")))) //
371                      *text*))
372         sxml))
373      ;; from the report, find the 3rd table, last row, find embedded
374      ;; table, retrieve tr contents
375      (test-equal "aging-table"
376        '("$0.00" "$6.75" "$1.00" "$8.50" "$7.50" "$8.00" "$31.75")
377        ((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
378         sxml))
379
380      (test-equal "dr/cr headers"
381        '("Date" "Due Date" "Reference" "Type" "Description"
382          "Debits" "Credits" "Balance" "Date" "Reference" "Type"
383          "Description" "Partial Amount" "Amount")
384        ((sxpath `(// (table 3) // thead // (tr 2) // *text*))
385         sxml))
386      )
387    (test-end "new-customer-report")
388
389    (display "job-report tests:\n")
390    ;; inv for job
391    (let ((inv-2-copy (gncInvoiceCopy inv-2)))
392      (gncInvoiceAddEntry inv-2-copy (entry 25/4))
393      (gncInvoicePostToAccount inv-2-copy
394                               (get-acct "AR-USD")         ;post-to acc
395                               (gnc-dmy2time64 13 05 1980) ;posted
396                               (gnc-dmy2time64 18 06 1980) ;due
397                               "inv for job" #t #f)
398      (gncInvoiceApplyPayment
399       inv-2-copy '() (get-acct "Bank-USD") 25/4 1
400       (gnc-dmy2time64 18 06 1980)
401       "inv for job" "fully paid"))
402
403    (test-begin "job-report")
404    (let* ((options (default-testing-options 'job owner-2 (get-acct "AR-USD")))
405           (sxml (options->sxml 'job options "job-report basic")))
406      (test-equal "inv-descriptions"
407        '("inv for job" "inv for job")
408        (sxml-get-row-col sxml #f 5))
409      (test-equal "amounts"
410        '("$6.25" "-$6.25")
411        (sxml-get-row-col sxml #f 6)))
412    (test-end "job-report")))
413