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