mirror of https://github.com/Gnucash/gnucash
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
328 lines
11 KiB
328 lines
11 KiB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 2 of
|
|
;; the License, or (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, contact:
|
|
;;
|
|
;; Free Software Foundation Voice: +1-617-542-5942
|
|
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
|
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-module (gnucash engine test test-extras))
|
|
|
|
(use-modules (gnucash gnc-module))
|
|
|
|
(use-modules (gnucash app-utils))
|
|
(use-modules (gnucash engine))
|
|
(use-modules (srfi srfi-1))
|
|
(use-modules (sw_app_utils))
|
|
(use-modules (sw_engine))
|
|
|
|
(export test)
|
|
|
|
(export with-account)
|
|
(export with-transaction)
|
|
|
|
(export create-test-env)
|
|
(export env-random-amount)
|
|
(export env-random)
|
|
(export env-counter-next)
|
|
(export env-string)
|
|
(export env-select-price-source)
|
|
(export env-any-date)
|
|
(export env-transfer)
|
|
(export env-transfer-foreign)
|
|
(export env-create-transaction)
|
|
(export env-create-account)
|
|
(export env-create-root-account)
|
|
(export env-create-test-accounts)
|
|
(export env-create-daily-transactions)
|
|
(export env-create-account-structure)
|
|
(export env-create-account-structure-alist)
|
|
(export env-expense-account-structure)
|
|
|
|
;;
|
|
;; Random test related syntax and the like
|
|
;;
|
|
|
|
(define (test the-test)
|
|
(format #t "(Running ~a " the-test)
|
|
(let ((result (the-test)))
|
|
(format #t "~a Completed)\n" result)
|
|
result))
|
|
|
|
;;
|
|
;; Gnucash specifics
|
|
;;
|
|
|
|
;; Really could do with generalising and making into a 'with' macro
|
|
(define (with-account account fn)
|
|
(begin (xaccAccountBeginEdit account)
|
|
(let ((result (fn)))
|
|
(xaccAccountCommitEdit account)
|
|
result)))
|
|
|
|
(define (with-accounts accounts fn)
|
|
(begin (map xaccAccountBeginEdit accounts)
|
|
(let ((result (fn)))
|
|
(map xaccAccountCommitEdit accounts)
|
|
result)))
|
|
|
|
(define (with-transaction txn fn)
|
|
(begin (xaccTransBeginEdit txn)
|
|
(let ((result (fn)))
|
|
(xaccTransCommitEdit txn)
|
|
result)))
|
|
|
|
;; Test environments.. an environment is just an alist with some well
|
|
;; known names. The idea is that we can use it to pass around
|
|
;; "suitable" sets of values for things
|
|
|
|
(define (make-counter)
|
|
(let ((x 0))
|
|
(lambda ()
|
|
(begin (set! x (+ x 1))
|
|
x))))
|
|
|
|
(define (create-test-env)
|
|
(list (cons 'random (seed->random-state (random 1000)))
|
|
(cons 'counter (make-counter))))
|
|
|
|
(define (env-random-amount env n)
|
|
(/ (env-random env n) 1))
|
|
|
|
(define (env-random env n)
|
|
(random n (assoc-ref env 'random)))
|
|
|
|
(define (env-counter-next env)
|
|
((assoc-ref env 'counter)))
|
|
|
|
(define (env-string env prefix)
|
|
(format #f "~a-~a" prefix (env-counter-next env)))
|
|
|
|
(define (env-select-price-source env)
|
|
'pricedb-nearest)
|
|
|
|
(define (env-any-date env) (gnc:get-today))
|
|
|
|
(define (env-create-transaction env date credit debit aaa)
|
|
(let ((txn (xaccMallocTransaction (gnc-get-current-book)))
|
|
(split-1 (xaccMallocSplit (gnc-get-current-book)))
|
|
(split-2 (xaccMallocSplit (gnc-get-current-book)))
|
|
(datevec (gnc-localtime date)))
|
|
(with-transaction txn
|
|
(lambda ()
|
|
(xaccTransSetDescription txn (env-string env "ponies"))
|
|
(xaccTransSetCurrency txn (gnc-default-report-currency))
|
|
(xaccTransSetDate txn
|
|
(gnc:date-get-month-day datevec)
|
|
(gnc:date-get-month datevec)
|
|
(gnc:date-get-year datevec))
|
|
(xaccSplitSetParent split-1 txn)
|
|
(xaccSplitSetParent split-2 txn)
|
|
(xaccSplitSetAccount split-1 credit)
|
|
(xaccSplitSetAccount split-2 debit)
|
|
(xaccSplitSetAmount split-1 aaa)
|
|
(xaccSplitSetAmount split-2 (gnc-numeric-neg aaa))
|
|
(xaccSplitSetValue split-1 aaa)
|
|
(xaccSplitSetValue split-2 (gnc-numeric-neg aaa))
|
|
))
|
|
;(format #t "tx ~a\n" (map xaccSplitGetAmount (list split-1 split-2)))
|
|
;(format #t "tx ~a\n" (map xaccSplitGetValue (list split-1 split-2)))
|
|
txn))
|
|
|
|
(define (gnc-pricedb-create currency commodity time64 value)
|
|
;; I think adding pricedb for a DMY date will clobber any existing
|
|
;; pricedb entry for that date.
|
|
(let ((price (gnc-price-create (gnc-get-current-book)))
|
|
(pricedb (gnc-pricedb-get-db (gnc-get-current-book))))
|
|
(gnc-price-begin-edit price)
|
|
(gnc-price-set-commodity price commodity)
|
|
(gnc-price-set-currency price currency)
|
|
(gnc-price-set-time64 price time64)
|
|
(gnc-price-set-source price PRICE-SOURCE-XFER-DLG-VAL)
|
|
(gnc-price-set-source-string price "test-price")
|
|
(gnc-price-set-typestr price "test")
|
|
(gnc-price-set-value price value)
|
|
(gnc-price-commit-edit price)
|
|
(gnc-pricedb-add-price pricedb price)))
|
|
|
|
(define* (env-transfer-foreign
|
|
env
|
|
DD MM YY ; day/month/year
|
|
debit ; account-from
|
|
credit ; account-to
|
|
amount1 ; amount-from
|
|
amount2 ; amount-to
|
|
#:key ; - the following are optional -
|
|
description ; string: description (def = "ponies")
|
|
void-reason ; string: void-reason (def = not-voided)
|
|
reconcile ; pair : (cons reconciled reconciled-date)
|
|
num ; string: num field (def = null)
|
|
notes ; string: notes (def = null)
|
|
memo ; string: memo (def = null)
|
|
)
|
|
(let ((txn (xaccMallocTransaction (gnc-get-current-book)))
|
|
(split-1 (xaccMallocSplit (gnc-get-current-book)))
|
|
(split-2 (xaccMallocSplit (gnc-get-current-book))))
|
|
(xaccTransBeginEdit txn)
|
|
(xaccTransSetDescription txn (or description "ponies"))
|
|
(xaccTransSetCurrency txn (xaccAccountGetCommodity debit))
|
|
(xaccTransSetDate txn DD MM YY)
|
|
(xaccSplitSetParent split-1 txn)
|
|
(xaccSplitSetParent split-2 txn)
|
|
(xaccSplitSetAccount split-1 debit)
|
|
(xaccSplitSetAccount split-2 credit)
|
|
(xaccSplitSetValue split-1 (- amount1))
|
|
(xaccSplitSetValue split-2 amount1)
|
|
(xaccSplitSetAmount split-1 (- amount1))
|
|
(xaccSplitSetAmount split-2 amount2)
|
|
(if reconcile
|
|
(begin
|
|
(xaccSplitSetReconcile split-1 (car reconcile))
|
|
(xaccSplitSetReconcile split-2 (car reconcile))
|
|
(xaccSplitSetDateReconciledSecs split-1 (cdr reconcile))
|
|
(xaccSplitSetDateReconciledSecs split-2 (cdr reconcile))))
|
|
(if num
|
|
(begin
|
|
(gnc-set-num-action txn split-1 num num)
|
|
(gnc-set-num-action txn split-2 num num)))
|
|
(if void-reason (xaccTransVoid txn void-reason))
|
|
(if notes (xaccTransSetNotes txn notes))
|
|
(if memo
|
|
(begin
|
|
(xaccSplitSetMemo split-1 memo)
|
|
(xaccSplitSetMemo split-2 memo)))
|
|
(gnc-pricedb-create (xaccAccountGetCommodity debit)
|
|
(xaccAccountGetCommodity credit)
|
|
(gnc-dmy2time64 DD MM YY)
|
|
(/ amount1 amount2))
|
|
(xaccTransCommitEdit txn)
|
|
txn))
|
|
|
|
(define* (env-transfer
|
|
env
|
|
DD MM YY ; day/month/year
|
|
debit ; account-from
|
|
credit ; account-to
|
|
amount ; amount
|
|
#:key ; - the following are optional -
|
|
description ; string: description (def = "ponies")
|
|
void-reason ; string: void-reason (def = not-voided)
|
|
reconcile ; char : reconciled (default = n)
|
|
num ; string: num field (def = null)
|
|
notes ; string: notes (def = null)
|
|
memo ; string: memo (def = null)
|
|
)
|
|
(env-transfer-foreign
|
|
env DD MM YY debit credit amount amount
|
|
#:description description
|
|
#:void-reason void-reason
|
|
#:reconcile reconcile
|
|
#:num num
|
|
#:memo memo
|
|
#:notes notes))
|
|
|
|
(define (env-create-root-account env type commodity)
|
|
(env-create-account env type commodity (gnc-get-current-root-account)))
|
|
|
|
(define (env-create-account env type commodity parent-account)
|
|
(let ((new-account (xaccMallocAccount (gnc-get-current-book))))
|
|
(with-accounts (list new-account parent-account)
|
|
(lambda ()
|
|
(xaccAccountSetCommodity new-account commodity)
|
|
(xaccAccountSetName new-account (env-string env "account"))
|
|
(xaccAccountSetType new-account type)
|
|
(gnc-account-append-child parent-account new-account)
|
|
new-account))))
|
|
|
|
;; Spend '1' on the 1st, '2' on the 2nd, etc. Makes for pretty graphs
|
|
(define (env-create-daily-transactions env start-date end-date to-account from-account)
|
|
(let ((dates-this-month (gnc:make-date-list start-date
|
|
end-date
|
|
DayDelta)))
|
|
(for-each (lambda (date)
|
|
(env-create-transaction env date to-account
|
|
from-account
|
|
(/
|
|
(gnc:date-get-month-day (gnc-localtime date))
|
|
1)))
|
|
(cdr (reverse dates-this-month)))))
|
|
|
|
(define (env-create-account-structure env account-structure)
|
|
(define (lookup-options list)
|
|
(if (null? list) (cons '() '())
|
|
(if (not (pair? (car list)))
|
|
(cons '() list)
|
|
(if (not (pair? (car (car list))))
|
|
(cons '() list)
|
|
list))))
|
|
|
|
(define (create-substructure parent options account-structure)
|
|
;;(format #t "Creating subaccounts for ~a ~a\n"
|
|
;; (xaccAccountGetName parent) account-structure)
|
|
(let* ((account-name (car account-structure))
|
|
(options-pair (lookup-options (cdr account-structure)))
|
|
(options (append (car options-pair) options)))
|
|
;;(format #t "New Account ~a\n" account-name)
|
|
;;(format #t "Options ~a\n" (car options-pair))
|
|
;;(format #t "Child list ~a\n" (cdr options-pair))
|
|
(let ((new-account (env-create-account env (assoc-ref options 'type)
|
|
(assoc-ref options 'commodity)
|
|
parent)))
|
|
(with-accounts (list new-account)
|
|
(lambda ()
|
|
(xaccAccountSetName new-account account-name)))
|
|
|
|
(cons new-account
|
|
(map (lambda (child)
|
|
(create-substructure new-account options child))
|
|
(cdr options-pair))))))
|
|
(let ((options (list (cons 'commodity (gnc-default-report-currency))
|
|
(cons 'type '()))))
|
|
(create-substructure (gnc-get-current-root-account)
|
|
options
|
|
account-structure)))
|
|
|
|
(define (env-create-account-structure-alist env account-structure)
|
|
(let ((accounts (env-create-account-structure env account-structure)))
|
|
(define (flatten l)
|
|
(if (null? l) '()
|
|
(if (not (pair? l)) (list l)
|
|
(append (flatten (car l)) (flatten (cdr l))))))
|
|
(map (lambda (acct) (cons (xaccAccountGetName acct) acct))
|
|
(flatten accounts))))
|
|
|
|
(define (env-expense-account-structure env)
|
|
(env-create-account-structure
|
|
env
|
|
(list "Expenses"
|
|
(list (cons 'type ACCT-TYPE-EXPENSE))
|
|
(list "Groceries")
|
|
(list "Rent")
|
|
(list "Auto"
|
|
(list "Tax")
|
|
(list "Parking")
|
|
(list "Petrol")))))
|
|
|
|
(define (env-create-test-accounts env)
|
|
(env-create-account-structure-alist env
|
|
(list "Root"
|
|
(list (cons 'type ACCT-TYPE-ASSET))
|
|
(list "Bank")
|
|
(list "Wallet")
|
|
(list "Other")
|
|
(list "Expenses"
|
|
(list (cons 'type ACCT-TYPE-EXPENSE))))))
|
|
|
|
|