gnucash maint: Multiple changes pushed
Geert Janssens
gjanssens at code.gnucash.org
Sun Nov 15 09:17:15 EST 2015
Updated via https://github.com/Gnucash/gnucash/commit/3e7c8fa4 (commit)
via https://github.com/Gnucash/gnucash/commit/13c7abc9 (commit)
via https://github.com/Gnucash/gnucash/commit/c26b81bf (commit)
via https://github.com/Gnucash/gnucash/commit/eb600c79 (commit)
via https://github.com/Gnucash/gnucash/commit/cca9cc7c (commit)
via https://github.com/Gnucash/gnucash/commit/5ff205d4 (commit)
via https://github.com/Gnucash/gnucash/commit/526fd82c (commit)
via https://github.com/Gnucash/gnucash/commit/8d123382 (commit)
via https://github.com/Gnucash/gnucash/commit/516b3025 (commit)
via https://github.com/Gnucash/gnucash/commit/6a8e9760 (commit)
via https://github.com/Gnucash/gnucash/commit/5d98d4af (commit)
via https://github.com/Gnucash/gnucash/commit/b47f0453 (commit)
via https://github.com/Gnucash/gnucash/commit/8dfea02d (commit)
via https://github.com/Gnucash/gnucash/commit/f9ab945c (commit)
from https://github.com/Gnucash/gnucash/commit/fa4532b6 (commit)
commit 3e7c8fa45afe99c56f53b3a0bdc67a51ae86d48d
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Fri Nov 13 21:12:48 2015 +0000
Move test-account and test-split into engine/test directory
diff --git a/src/engine/test/Makefile.am b/src/engine/test/Makefile.am
index d01969a..56e3ade 100644
--- a/src/engine/test/Makefile.am
+++ b/src/engine/test/Makefile.am
@@ -53,7 +53,11 @@ TESTS = \
test-vendor \
$(SCM_TESTS)
-SCM_TESTS = test-test-extras
+SCM_TESTS = \
+ test-test-extras \
+ test-account \
+ test-split
+
SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
GNC_TEST_DEPS = \
diff --git a/src/engine/test/test-account.scm b/src/engine/test/test-account.scm
index b30c0d0..8b90395 100644
--- a/src/engine/test/test-account.scm
+++ b/src/engine/test/test-account.scm
@@ -1,6 +1,6 @@
(use-modules (gnucash engine))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(use-modules (sw_engine))
(define (run-test)
diff --git a/src/engine/test/test-split.scm b/src/engine/test/test-split.scm
index 92bd571..d45f077 100644
--- a/src/engine/test/test-split.scm
+++ b/src/engine/test/test-split.scm
@@ -4,9 +4,9 @@
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (gnucash engine))
-(use-modules (gnucash report report-system test test-extras))
-
-(use-modules (gnucash report report-system))
+(use-modules (sw_engine))
+(use-modules (gnucash engine test test-extras))
+(use-modules (gnucash app-utils))
(define (run-test)
(test test-split-in-list?))
diff --git a/src/engine/test/test-test-extras.scm b/src/engine/test/test-test-extras.scm
new file mode 100644
index 0000000..241b247
--- /dev/null
+++ b/src/engine/test/test-test-extras.scm
@@ -0,0 +1,46 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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 at gnu.org
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(debug-set! stack 50000)
+(use-modules (gnucash engine test test-extras))
+(use-modules (ice-9 streams))
+(use-modules (gnucash engine))
+(use-modules (sw_engine))
+
+(define (run-test)
+ (and (logging-and #t)
+ (logging-and)
+ (not (logging-and #t #f))
+ (test-create-account-structure)))
+
+(define (test-create-account-structure)
+ (let ((env (create-test-env)))
+ (let ((accounts (env-create-account-structure env (list "Assets"
+ (list (cons 'type ACCT-TYPE-ASSET))
+ (list "Bank Account")
+ (list "Savings"
+ (list "Instant")
+ (list "30 day notice"))))))
+ (and (= 3 (length accounts))
+ (equal? "Assets" (xaccAccountGetName (car accounts)))
+ ))))
+
+
+
+
diff --git a/src/report/report-system/account.scm b/src/report/report-system/account.scm
deleted file mode 100644
index 6540329..0000000
--- a/src/report/report-system/account.scm
+++ /dev/null
@@ -1,5 +0,0 @@
-(define-module (gnucash report report-system account))
-(use-modules (gnucash gnc-module))
-
-
-
diff --git a/src/report/report-system/split.scm b/src/report/report-system/split.scm
deleted file mode 100644
index 07313bc..0000000
--- a/src/report/report-system/split.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-(define-module (gnucash report report-system split))
-(use-modules (gnucash gnc-module))
-
-(gnc:module-begin-syntax (gnc:module-load "gnucash/engine" 0))
-
-(use-modules (sw_engine))
-
diff --git a/src/report/report-system/test/Makefile.am b/src/report/report-system/test/Makefile.am
index 09be5cf..d1ed938 100644
--- a/src/report/report-system/test/Makefile.am
+++ b/src/report/report-system/test/Makefile.am
@@ -22,8 +22,6 @@ SCM_TESTS = \
test-collectors \
test-list-extras \
test-test-extras \
- test-account \
- test-split \
test-report-utilities
SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
diff --git a/src/report/report-system/test/test-account.scm b/src/report/report-system/test/test-account.scm
deleted file mode 100644
index 8b90395..0000000
--- a/src/report/report-system/test/test-account.scm
+++ /dev/null
@@ -1,47 +0,0 @@
-(use-modules (gnucash engine))
-
-(use-modules (gnucash engine test test-extras))
-(use-modules (sw_engine))
-
-(define (run-test)
- (test test-account-same?)
- (test test-account-in-list?)
- (test test-account-in-alist?)
- (test test-account-list-predicate))
-
-(define (test-account-same?)
- (let* ((env (create-test-env))
- (account-alist (env-create-test-accounts env))
- (bank-account (cdr (assoc "Bank" account-alist)))
- (expense-account (cdr (assoc "Expenses" account-alist))))
- (and (account-same? bank-account bank-account)
- (not (account-same? bank-account expense-account)))))
-
-(define (test-account-in-alist?)
- (let* ((env (create-test-env))
- (account-alist (env-create-test-accounts env))
- (bank-account (cdr (assoc "Bank" account-alist)))
- (wallet-account (cdr (assoc "Wallet" account-alist)))
- (expense-account (cdr (assoc "Expenses" account-alist))))
- (let ((alist (list (cons bank-account "Bank") (cons expense-account "Expenses"))))
- (and (account-in-alist bank-account alist)
- (account-in-alist expense-account alist)
- (not (account-in-alist wallet-account alist))))))
-
-(define (test-account-in-list?)
- (test-account-list-predicate-generic
- (lambda (accounts) (lambda (account) (account-in-list? account accounts)))))
-
-(define (test-account-list-predicate)
- (test-account-list-predicate-generic account-in-list-pred))
-
-(define (test-account-list-predicate-generic predicate)
- (let* ((env (create-test-env))
- (account-alist (env-create-test-accounts env))
- (bank-account (cdr (assoc "Bank" account-alist)))
- (wallet-account (cdr (assoc "Wallet" account-alist)))
- (other-account (cdr (assoc "Other" account-alist)))
- (bank-or-wallet? (predicate (list bank-account wallet-account))))
- (and (bank-or-wallet? bank-account)
- (bank-or-wallet? wallet-account)
- (not (bank-or-wallet? other-account)))))
diff --git a/src/report/report-system/test/test-split.scm b/src/report/report-system/test/test-split.scm
deleted file mode 100644
index b3e5a05..0000000
--- a/src/report/report-system/test/test-split.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-(use-modules (gnucash gnc-module))
-(use-modules (srfi srfi-1))
-
-(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
-
-(use-modules (gnucash engine))
-(use-modules (gnucash engine test test-extras))
-
-(use-modules (gnucash report report-system))
-
-(define (run-test)
- (test test-split-in-list?))
-
-(define (test-split-in-list?)
- (let* ((env (create-test-env))
- (today (gnc:date->timepair (localtime (current-time))))
- (account-alist (env-create-test-accounts env))
- (bank-account (cdr (assoc "Bank" account-alist)))
- (expense-account (cdr (assoc "Expenses" account-alist)))
- (wallet-account (cdr (assoc "Wallet" account-alist)))
- (tx1 (env-create-transaction env today bank-account wallet-account (gnc:make-gnc-numeric 20 1)))
- (tx2 (env-create-transaction env today bank-account expense-account (gnc:make-gnc-numeric 10 1)))
- (splits-tx1 (xaccTransGetSplitList tx1))
- (splits-tx2 (xaccTransGetSplitList tx2)))
- (and (split-in-list? (first splits-tx1) splits-tx1)
- (split-in-list? (second splits-tx1) splits-tx1)
- (not (split-in-list? (first splits-tx1) splits-tx2))
- (not (split-in-list? (second splits-tx1) splits-tx2))
- (not (split-in-list? (first splits-tx1) '())))))
-
-
-
-
commit 13c7abc978a4956a860b52f6aad1ad4a836966b2
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Fri Nov 13 20:33:20 2015 +0000
Moved test-extras.scm to engine directory.
diff --git a/src/engine/test/Makefile.am b/src/engine/test/Makefile.am
index 98d7d24..d01969a 100644
--- a/src/engine/test/Makefile.am
+++ b/src/engine/test/Makefile.am
@@ -50,19 +50,32 @@ TESTS = \
test-customer \
test-employee \
test-job \
- test-vendor
+ test-vendor \
+ $(SCM_TESTS)
+
+SCM_TESTS = test-test-extras
+SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
GNC_TEST_DEPS = \
--gnc-module-dir ${top_builddir}/src/engine \
+ --gnc-module-dir ${top_builddir}/src/engine/test \
--guile-load-dir ${top_builddir}/src/gnc-module \
--guile-load-dir ${top_builddir}/src/engine \
+ --guile-load-dir ${top_builddir}/src/app-utils \
+ --guile-load-dir ${top_builddir}/src/core-utils \
+ --guile-load-dir ${top_builddir}/src/scm \
--library-dir ${top_builddir}/src/libqof/qof \
--library-dir ${top_builddir}/src/core-utils \
--library-dir ${top_builddir}/src/gnc-module \
--library-dir ${top_builddir}/src/engine \
+ --library-dir ${top_builddir}/src/app-utils \
--library-dir ${top_builddir}/src/backend/xml \
--library-dir ${top_builddir}/src/backend/sql
+$(SCM_TESTS): %: $(srcdir)/%.scm Makefile .scm-links
+ echo '${GUILE} --debug -l $(srcdir)/$*.scm -c "(exit (run-test))"' > $@
+ chmod a+x $@
+
TESTS_ENVIRONMENT = \
GUILE_WARN_DEPRECATED=no \
GUILE="${GUILE}" \
@@ -101,16 +114,31 @@ test_link_LDADD = ../libgncmod-engine.la \
${top_builddir}/src/libqof/qof/libgnc-qof.la \
${top_builddir}/src/core-utils/libgnc-core-utils.la
+SCM_TEST_HELPERS = test-extras.scm
+
EXTRA_DIST += \
test-create-account \
test-create-account.scm \
test-scm-query-import \
- test-scm-query-import.scm
+ test-scm-query-import.scm \
+ $(SCM_TEST_HELPERS) \
+ $(SCM_TEST_SRCS)
TEST_PROGS += test-engine
+.scm-links:
+ $(RM) -rf gnucash
+ mkdir -p gnucash/engine/test
+ ( cd gnucash/engine/test; for A in $(SCM_TEST_HELPERS) ; do $(LN_S) -f $(abs_srcdir)/$$A . ; done )
+if ! OS_WIN32
+# Windows knows no "ln -s" but uses "cp": must copy every time (see bug #566567).
+ touch .scm-links
+endif
+
noinst_PROGRAMS = ${TEST_PROGS} ${CHECK_PROGS}
+noinst_DATA: .scm-links
+
test_engine_SOURCES = \
test-engine.c \
utest-Account.c \
@@ -144,6 +172,8 @@ libutest_Trans_la_SOURCES = \
libutest_Trans_la_LIBADD = $(LDADD)
+CLEANFILES = .scm-links
+DISTCLEANFILES = $(SCM_TESTS)
clean-local:
rm -f translog.*
diff --git a/src/report/report-system/test/test-account.scm b/src/engine/test/test-account.scm
similarity index 100%
copy from src/report/report-system/test/test-account.scm
copy to src/engine/test/test-account.scm
diff --git a/src/report/report-system/test/test-extras.scm b/src/engine/test/test-extras.scm
similarity index 81%
copy from src/report/report-system/test/test-extras.scm
copy to src/engine/test/test-extras.scm
index 52506d4..0541ce5 100644
--- a/src/report/report-system/test/test-extras.scm
+++ b/src/engine/test/test-extras.scm
@@ -17,19 +17,16 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define-module (gnucash report report-system test test-extras))
+(define-module (gnucash engine test test-extras))
(use-modules (gnucash gnc-module))
-(gnc:module-load "gnucash/report/report-system" 0)
-(use-modules (sw_engine))
-
-(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (gnucash printf))
-(use-modules (gnucash report report-system))
(use-modules (gnucash app-utils))
(use-modules (gnucash engine))
(use-modules (srfi srfi-1))
+(use-modules (sw_app_utils))
+(use-modules (sw_engine))
(export logging-and)
(export test)
@@ -60,17 +57,6 @@
(export env-create-account-structure-alist)
(export env-expense-account-structure)
-(export pattern-streamer)
-
-(export create-option-set)
-(export option-set-setter)
-(export option-set-getter)
-
-(export tbl-column-count)
-(export tbl-row-count)
-(export tbl-ref)
-(export tbl-ref->number)
-
;;
;; Random test related syntax and the like
;;
@@ -267,61 +253,6 @@
(list "Other")
(list "Expenses"
(list (cons 'type ACCT-TYPE-EXPENSE))))))
-;; Date sequences
-;;
-
-
-;;
-;; Table parsing
-;;
-(use-modules (ice-9 regex))
-(use-modules (ice-9 streams))
-
-(define (values-for-keywords pos regex-list text)
- (make-stream (lambda (pos-keywords-pair)
- (let ((current-pos (car pos-keywords-pair))
- (regex-list (cdr pos-keywords-pair)))
- (if (null? regex-list)
- '()
- (let ((match (string-match (caar regex-list) text current-pos)))
- (if (not match)
- '()
- (let ((new-state (cons (match:end match)
- (cdr regex-list)))
- (next-value (cons (match:end match)
- (map (lambda (item)
- (match:substring match item))
- (cdar regex-list)))))
- (cons next-value new-state)))))))
- (cons pos regex-list)))
-
-(define (pattern-streamer start-text regex-list text)
- (define (stream-next index)
- ;;(format #t "Next. Index: ~a\n" index)
- (let ((head-index (string-contains text start-text index)))
- ;; (format #t "head index ~a ~a --> ~a\n" start-text index head-index)
- (if (not head-index) '()
- (let ((values (stream->list (values-for-keywords head-index regex-list text))))
- (if (null? values) '()
- (let ((new-state (car (car (last-pair values))))
- (next-value (map cdr values)))
- (cons next-value new-state)))))))
- ;;(format #t "Stream ~a\n" text)
- (make-stream stream-next 0))
-
-;; silly table functions
-(define (tbl-column-count tbl)
- (length (car tbl)))
-
-(define (tbl-row-count tbl)
- (length tbl))
-
-(define (tbl-ref tbl row-index column-index)
- (list-ref (list-ref tbl row-index) column-index))
-
-(define (tbl-ref->number tbl row-index column-index)
- (string->number (car (tbl-ref tbl row-index column-index))))
-
;;
;; Test sinks
;;
diff --git a/src/report/report-system/test/test-split.scm b/src/engine/test/test-split.scm
similarity index 98%
copy from src/report/report-system/test/test-split.scm
copy to src/engine/test/test-split.scm
index b835a57..92bd571 100644
--- a/src/report/report-system/test/test-split.scm
+++ b/src/engine/test/test-split.scm
@@ -27,7 +27,3 @@
(not (split-in-list? (first splits-tx1) splits-tx2))
(not (split-in-list? (second splits-tx1) splits-tx2))
(not (split-in-list? (first splits-tx1) '())))))
-
-
-
-
diff --git a/src/report/report-system/test/Makefile.am b/src/report/report-system/test/Makefile.am
index 03c001f..09be5cf 100644
--- a/src/report/report-system/test/Makefile.am
+++ b/src/report/report-system/test/Makefile.am
@@ -34,10 +34,12 @@ GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \
--gnc-module-dir ${top_builddir}/src/html \
--gnc-module-dir ${top_builddir}/src/report/report-system \
--gnc-module-dir ${top_builddir}/src/report/report-system/test \
+ --gnc-module-dir ${top_builddir}/src/engine/test \
\
--guile-load-dir ${top_builddir}/src/gnc-module \
--guile-load-dir ${top_builddir}/src/scm \
--guile-load-dir ${top_builddir}/src/engine \
+ --guile-load-dir ${top_builddir}/src/engine/test \
--guile-load-dir ${top_builddir}/src/core-utils \
--guile-load-dir ${top_builddir}/src/app-utils \
--guile-load-dir ${top_builddir}/src/gnome-utils \
diff --git a/src/report/report-system/test/test-account.scm b/src/report/report-system/test/test-account.scm
index b30c0d0..8b90395 100644
--- a/src/report/report-system/test/test-account.scm
+++ b/src/report/report-system/test/test-account.scm
@@ -1,6 +1,6 @@
(use-modules (gnucash engine))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(use-modules (sw_engine))
(define (run-test)
diff --git a/src/report/report-system/test/test-collectors.scm b/src/report/report-system/test/test-collectors.scm
index c00402b..82cbd38 100644
--- a/src/report/report-system/test/test-collectors.scm
+++ b/src/report/report-system/test/test-collectors.scm
@@ -21,7 +21,7 @@
(use-modules (srfi srfi-1))
(use-modules (gnucash report report-system collectors))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(define (run-test)
(and (test test-empty)
diff --git a/src/report/report-system/test/test-extras.scm b/src/report/report-system/test/test-extras.scm
index 52506d4..a150f38 100644
--- a/src/report/report-system/test/test-extras.scm
+++ b/src/report/report-system/test/test-extras.scm
@@ -20,45 +20,7 @@
(define-module (gnucash report report-system test test-extras))
(use-modules (gnucash gnc-module))
-
-(gnc:module-load "gnucash/report/report-system" 0)
-(use-modules (sw_engine))
-
-(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
-(use-modules (gnucash printf))
-(use-modules (gnucash report report-system))
-(use-modules (gnucash app-utils))
-(use-modules (gnucash engine))
-(use-modules (srfi srfi-1))
-
-(export logging-and)
-(export test)
-(export make-test-sink)
-(export env-test-sink)
-(export test-sink-report)
-(export test-sink-check)
-
-(export delayed-format)
-(export delayed-format-render)
-
-(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-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)
+(use-modules (gnucash engine test test-extras))
(export pattern-streamer)
@@ -72,205 +34,9 @@
(export tbl-ref->number)
;;
-;; Random test related syntax and the like
-;;
-
-;; logging-and is mostly for debugging tests
-(define-macro (logging-and . args)
- (cons 'and (map (lambda (arg)
- (list 'begin
- (list 'format #t "Test: ~a\n" (list 'quote arg))
- arg))
- args)))
-
-;; ..and 'test' gives nicer output
-(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))
- (cons 'sink (make-test-sink))))
-
-(define (env-random-amount env n)
- (gnc:make-gnc-numeric (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-test-sink env)
- (assoc-ref env 'sink))
-
-(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)))
- (localtime (gnc:timepair->date date)))
- (with-transaction txn
- (lambda ()
- (xaccTransSetDescription txn (env-string env "ponies"))
- (xaccTransSetCurrency txn (gnc-default-report-currency))
- (xaccTransSetDate txn
- (gnc:date-get-month-day localtime)
- (gnc:date-get-month localtime)
- (gnc:date-get-year localtime))
- (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 (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:make-gnc-numeric
- (gnc:date-get-month-day (gnc:timepair->date 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))))))
-;; Date sequences
+;; Random report test related syntax and the like
;;
-
;;
;; Table parsing
;;
diff --git a/src/report/report-system/test/test-list-extras.scm b/src/report/report-system/test/test-list-extras.scm
index 8e3b973..1855883 100644
--- a/src/report/report-system/test/test-list-extras.scm
+++ b/src/report/report-system/test/test-list-extras.scm
@@ -19,7 +19,7 @@
(debug-set! stack 50000)
(use-modules (gnucash report report-system list-extras))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(define (run-test)
(test test-list-min-max))
diff --git a/src/report/report-system/test/test-report-utilities.scm b/src/report/report-system/test/test-report-utilities.scm
index d3aeea2..24d5d7e 100644
--- a/src/report/report-system/test/test-report-utilities.scm
+++ b/src/report/report-system/test/test-report-utilities.scm
@@ -2,6 +2,7 @@
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
+(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report report-system))
diff --git a/src/report/report-system/test/test-split.scm b/src/report/report-system/test/test-split.scm
index b835a57..b3e5a05 100644
--- a/src/report/report-system/test/test-split.scm
+++ b/src/report/report-system/test/test-split.scm
@@ -4,7 +4,7 @@
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (gnucash engine))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system))
diff --git a/src/report/report-system/test/test-test-extras.scm b/src/report/report-system/test/test-test-extras.scm
index 26a0e7b..92d4831 100644
--- a/src/report/report-system/test/test-test-extras.scm
+++ b/src/report/report-system/test/test-test-extras.scm
@@ -19,6 +19,8 @@
(debug-set! stack 50000)
(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
+
(use-modules (ice-9 streams))
(define (run-test)
@@ -97,7 +99,7 @@
;(use-modules (gnucash printf))
;(use-modules (gnucash report report-system))
;(use-modules (gnucash app-utils))
-;(use-modules (gnucash engine))
+(use-modules (gnucash engine))
(use-modules (sw_engine))
(define (test-create-account-structure)
diff --git a/src/report/standard-reports/test/Makefile.am b/src/report/standard-reports/test/Makefile.am
index c3529b2..80c78d5 100644
--- a/src/report/standard-reports/test/Makefile.am
+++ b/src/report/standard-reports/test/Makefile.am
@@ -12,6 +12,7 @@ SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
GNC_TEST_DEPS = \
--gnc-module-dir ${top_builddir}/src/engine \
+ --gnc-module-dir ${top_builddir}/src/engine/test \
--gnc-module-dir ${top_builddir}/src/app-utils \
--gnc-module-dir ${top_builddir}/src/gnome-utils \
--gnc-module-dir ${top_builddir}/src/html \
@@ -24,6 +25,7 @@ GNC_TEST_DEPS = \
--guile-load-dir ${top_builddir}/src/gnc-module \
--guile-load-dir ${top_builddir}/src/scm \
--guile-load-dir ${top_builddir}/src/engine \
+ --guile-load-dir ${top_builddir}/src/engine/test \
--guile-load-dir ${top_builddir}/src/core-utils \
--guile-load-dir ${top_builddir}/src/app-utils \
--guile-load-dir ${top_builddir}/src/gnome-utils \
diff --git a/src/report/standard-reports/test/test-cash-flow.scm b/src/report/standard-reports/test/test-cash-flow.scm
index 76a3b85..871fd15 100644
--- a/src/report/standard-reports/test/test-cash-flow.scm
+++ b/src/report/standard-reports/test/test-cash-flow.scm
@@ -2,7 +2,7 @@
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
-(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report standard-reports cash-flow))
(use-modules (gnucash report report-system))
diff --git a/src/report/standard-reports/test/test-generic-category-report.scm b/src/report/standard-reports/test/test-generic-category-report.scm
index 785542a..e5a0473 100644
--- a/src/report/standard-reports/test/test-generic-category-report.scm
+++ b/src/report/standard-reports/test/test-generic-category-report.scm
@@ -34,6 +34,7 @@
(use-modules (sw_engine))
(use-modules (gnucash report report-system collectors))
+(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system test test-extras))
(export run-category-income-expense-test)
diff --git a/src/report/standard-reports/test/test-generic-net-barchart.scm b/src/report/standard-reports/test/test-generic-net-barchart.scm
index c65d897..91a1a48 100644
--- a/src/report/standard-reports/test/test-generic-net-barchart.scm
+++ b/src/report/standard-reports/test/test-generic-net-barchart.scm
@@ -26,6 +26,7 @@
(use-modules (gnucash gnc-module))
(gnc:module-load "gnucash/report/report-system" 0)
+(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system test test-extras))
(export run-net-asset-income-test)
diff --git a/src/report/standard-reports/test/test-generic-net-linechart.scm b/src/report/standard-reports/test/test-generic-net-linechart.scm
index 963eea4..dd79472 100644
--- a/src/report/standard-reports/test/test-generic-net-linechart.scm
+++ b/src/report/standard-reports/test/test-generic-net-linechart.scm
@@ -27,6 +27,7 @@
(gnc:module-load "gnucash/report/report-system" 0)
(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash engine test test-extras))
(export run-net-asset-test)
commit c26b81bff8686927cd68c37a116ba8d4dfc36fd4
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Mon Nov 9 22:16:26 2015 +0000
cash-flow.scm: Use hashtables for accounts as well
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 460eaf0..7d857d0 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -397,12 +397,14 @@
(include-trading-accounts (cdr (assq 'include-trading-accounts settings)))
(to-report-currency (cdr (assq 'to-report-currency settings)))
+ (is-report-account? (account-in-list-pred accounts))
+
(money-in-accounts '())
- (money-in-alist '())
+ (money-in-hash (make-hash-table))
(money-in-collector (gnc:make-commodity-collector))
(money-out-accounts '())
- (money-out-alist '())
+ (money-out-hash (make-hash-table))
(money-out-collector (gnc:make-commodity-collector))
(all-splits (gnc:account-get-trans-type-splits-interval accounts '() from-date-tp to-date-tp))
@@ -446,46 +448,44 @@
(if (and ;; make sure we don't have
(not (null? s-account)) ;; any dangling splits
(or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
- (not (account-in-list? s-account accounts)))
+ (not (is-report-account? s-account)))
(if (not (split-seen? s))
(begin
(if (gnc-numeric-negative-p s-value)
- (let ((pair (account-in-alist s-account money-in-alist)))
+ (let ((s-account-in-collector (account-hashtable-ref money-in-hash s-account)))
;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
; (gnc-numeric-to-double s-amount)
; (gnc-commodity-get-printname parent-currency)
; (gnc-numeric-to-double s-value))
- (if (not pair)
+ (if (not s-account-in-collector)
(begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-in-alist (cons pair money-in-alist))
+ (set! s-account-in-collector (gnc:make-commodity-collector))
+ (account-hashtable-set! money-in-hash s-account
+ s-account-in-collector)
(set! money-in-accounts (cons s-account money-in-accounts))
- ;(gnc:debug money-in-alist)
)
)
- (let ((s-account-in-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
+ (let ((s-report-value (to-report-currency parent-currency
(gnc-numeric-neg s-value)
(gnc-transaction-get-date-posted
parent))))
(money-in-collector 'add report-currency s-report-value)
(s-account-in-collector 'add report-currency s-report-value))
)
- (let ((pair (account-in-alist s-account money-out-alist)))
+ (let ((s-account-out-collector (account-hashtable-ref money-out-hash s-account)))
;(gnc:debug "out:" (gnc-commodity-get-printname s-commodity)
; (gnc-numeric-to-double s-amount)
; (gnc-commodity-get-printname parent-currency)
; (gnc-numeric-to-double s-value))
- (if (not pair)
+ (if (not s-account-out-collector)
(begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-out-alist (cons pair money-out-alist))
+ (set! s-account-out-collector (gnc:make-commodity-collector))
+ (account-hashtable-set! money-out-hash s-account
+ s-account-out-collector)
(set! money-out-accounts (cons s-account money-out-accounts))
- ;(gnc:debug money-out-alist)
)
)
- (let ((s-account-out-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
+ (let ((s-report-value (to-report-currency parent-currency
s-value
(gnc-transaction-get-date-posted
parent))))
@@ -512,10 +512,10 @@
(calc-money-in-out-internal accounts)
;; Return an association list of results
(list (cons 'money-in-accounts money-in-accounts)
- (cons 'money-in-alist money-in-alist)
+ (cons 'money-in-alist (hash-map->list (lambda (k v) (list k v)) money-in-hash))
(cons 'money-in-collector money-in-collector)
(cons 'money-out-accounts money-out-accounts)
- (cons 'money-out-alist money-out-alist)
+ (cons 'money-out-alist (hash-map->list (lambda (k v) (list k v)) money-out-hash))
(cons 'money-out-collector money-out-collector))))
(gnc:define-report
commit eb600c79a4288c38cb414d9a3ba45607b27bf634
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Thu Nov 12 20:43:58 2015 +0000
engine-utilities.scm: Add a couple of hashtable functions.
diff --git a/src/engine/engine-utilities.scm b/src/engine/engine-utilities.scm
index 238866a..3ea6bec 100644
--- a/src/engine/engine-utilities.scm
+++ b/src/engine/engine-utilities.scm
@@ -80,6 +80,18 @@
(+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
accounts)))
+(define (account-assoc acc alist)
+ (find (lambda (pair) (account-same? acc (car pair))) alist))
+
+(define (account-hash acc size)
+ (remainder (string-hash (gncAccountGetGUID acc)) size))
+
+(define (account-hashtable-ref table account)
+ (hashx-ref account-hash account-assoc table account))
+
+(define (account-hashtable-set! table account value)
+ (hashx-set! account-hash account-assoc table account value))
+
;; Splits
(export split-same?)
(export split-in-list?)
diff --git a/src/engine/engine.scm b/src/engine/engine.scm
index 14847f9..00bd61c 100644
--- a/src/engine/engine.scm
+++ b/src/engine/engine.scm
@@ -79,6 +79,8 @@
(export account-full-name<?)
(export account-list-predicate)
(export accounts-get-children-depth)
+(export account-hashtable-ref)
+(export account-hashtable-set!)
(export split-same?)
(export split-in-list?)
commit cca9cc7c22435383bae1158941a696a1301a04b0
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Mon Nov 9 20:53:19 2015 +0000
cash-flow.scm: Use a hashtable instead of a list.
This removes O(n^2) behaviour in the number of splits.
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 2f8d385..460eaf0 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -407,9 +407,15 @@
(all-splits (gnc:account-get-trans-type-splits-interval accounts '() from-date-tp to-date-tp))
(splits-to-do (length all-splits))
- (seen-split-list '())
+ (splits-seen-table (make-hash-table))
(work-done 0))
+ (define (split-seen? split)
+ (if (split-hashtable-ref splits-seen-table split) #t
+ (begin
+ (split-hashtable-set! splits-seen-table split #t)
+ #f)))
+
(define (work-per-split split)
(set! work-done (+ 1 work-done))
(if (= (modulo work-done 100) 0)
@@ -441,9 +447,8 @@
(not (null? s-account)) ;; any dangling splits
(or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
(not (account-in-list? s-account accounts)))
- (if (not (split-in-list? s seen-split-list))
+ (if (not (split-seen? s))
(begin
- (set! seen-split-list (cons s seen-split-list))
(if (gnc-numeric-negative-p s-value)
(let ((pair (account-in-alist s-account money-in-alist)))
;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
commit 5ff205d41fee190673d3a88517b09fd1591e3462
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Thu Nov 12 20:38:49 2015 +0000
engine-utilities.scm: Add a specialised hashtable.
diff --git a/src/engine/engine-utilities.scm b/src/engine/engine-utilities.scm
index 1310ff9..238866a 100644
--- a/src/engine/engine-utilities.scm
+++ b/src/engine/engine-utilities.scm
@@ -95,3 +95,19 @@
((split-same? (car splits) split) #t)
(else (split-in-list? split (cdr splits))))))
+;; Split hashtable. Because we do gncSplitGetGUID so often, it
+;; turns out to be a bit quicker to store a (hash, split) pair
+;; instead of just the split.
+(define (split-assoc split alist)
+ (find (lambda (pair) (split-same? (cdr split) (cdr (car pair)))) alist))
+(define (split-hash split size)
+ (remainder (car split) size))
+
+(define (split-hashtable-ref table split)
+ (hashx-ref split-hash split-assoc table
+ (cons (string-hash (gncSplitGetGUID split)) split)))
+
+(define (split-hashtable-set! table split value)
+ (hashx-set! split-hash split-assoc table
+ (cons (string-hash (gncSplitGetGUID split)) split) value))
+
diff --git a/src/engine/engine.scm b/src/engine/engine.scm
index 5c52b14..14847f9 100644
--- a/src/engine/engine.scm
+++ b/src/engine/engine.scm
@@ -83,6 +83,11 @@
(export split-same?)
(export split-in-list?)
+(export split-same?)
+(export split-in-list?)
+(export split-hashtable-ref)
+(export split-hashtable-set!)
+
(export gnc:split-structure)
(export gnc:make-split-scm)
(export gnc:split-scm?)
commit 526fd82ca8bc5b2e05c40233c147ddd2c4e1a97a
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Mon Nov 9 20:42:43 2015 +0000
cashflow: use the much faster gnc:account-get-trans-type-splits-interval
This retrieves all the splits we need, and much faster.
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index f2fb9c6..2f8d385 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -405,7 +405,8 @@
(money-out-alist '())
(money-out-collector (gnc:make-commodity-collector))
- (splits-to-do (gnc:accounts-count-splits accounts))
+ (all-splits (gnc:account-get-trans-type-splits-interval accounts '() from-date-tp to-date-tp))
+ (splits-to-do (length all-splits))
(seen-split-list '())
(work-done 0))
@@ -499,12 +500,8 @@
)
)
- (define (calc-money-in-out-internal accounts-internal)
- (if (not (null? accounts-internal))
- (let* ((current (car accounts-internal))
- (rest (cdr accounts-internal)))
- (for-each work-per-split (xaccAccountGetSplitList current))
- (calc-money-in-out-internal rest))))
+ (define (calc-money-in-out-internal accounts)
+ (for-each work-per-split all-splits))
;; And calculate
(calc-money-in-out-internal accounts)
commit 8d123382442afae25003ed4295992237ff76be47
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Sun Nov 8 22:37:08 2015 +0000
Add cashflow test
diff --git a/src/report/standard-reports/test/Makefile.am b/src/report/standard-reports/test/Makefile.am
index 6f89e4d..c3529b2 100644
--- a/src/report/standard-reports/test/Makefile.am
+++ b/src/report/standard-reports/test/Makefile.am
@@ -3,6 +3,7 @@ MODULE_TESTS=test-load-module
TESTS = $(SCM_TESTS) $(MODULE_TESTS)
SCM_TESTS = \
+ test-cash-flow \
test-standard-category-report \
test-standard-net-barchart \
test-standard-net-linechart
diff --git a/src/report/standard-reports/test/test-cash-flow.scm b/src/report/standard-reports/test/test-cash-flow.scm
new file mode 100644
index 0000000..76a3b85
--- /dev/null
+++ b/src/report/standard-reports/test/test-cash-flow.scm
@@ -0,0 +1,127 @@
+(use-modules (gnucash gnc-module))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
+
+(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash report standard-reports cash-flow))
+(use-modules (gnucash report report-system))
+
+(define (run-test)
+ (and (test test-one-tx-in-cash-flow)
+ (test test-one-tx-skip-cash-flow)
+ (test test-both-way-cash-flow)))
+
+(define structure
+ (list "Root" (list (cons 'type ACCT-TYPE-ASSET))
+ (list "Asset"
+ (list "Bank")
+ (list "Wallet"))
+ (list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))))
+
+(define (NDayDelta n)
+ (let ((ddt (make-zdate)))
+ (set-tm:year ddt n)
+ ddt))
+
+(define (test-one-tx-in-cash-flow)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-account-structure-alist env structure))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist)))
+ (today (gnc:date->timepair (localtime (current-time))))
+ (exchange-fn (lambda (currency amount date) amount))
+ (report-currency (gnc-default-report-currency))
+ )
+ (env-create-transaction env today bank-account expense-account (gnc:make-gnc-numeric 100 1))
+ (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list bank-account))
+ (cons 'to-date-tp today)
+ (cons 'from-date-tp (decdate today (NDayDelta 1)))
+ (cons 'report-currency report-currency)
+ (cons 'include-trading-accounts #f)
+ (cons 'to-report-currency exchange-fn)))))
+ (let* ((money-in-collector (cdr (assq 'money-in-collector result)))
+ (money-out-collector (cdr (assq 'money-out-collector result)))
+ (money-in-alist (cdr (assq 'money-in-alist result)))
+ (money-out-alist (cdr (assq 'money-out-alist result)))
+ (expense-acc-in-collector (cadr (assoc expense-account money-in-alist))))
+ (and (null? money-out-alist)
+ (equal? (gnc:make-gnc-numeric 10000 100)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-in-collector
+ report-currency exchange-fn)))
+ (equal? (gnc:make-gnc-numeric 10000 100)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
+ report-currency exchange-fn)))
+ (equal? (gnc:make-gnc-numeric 0 1)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
+ report-currency exchange-fn)))
+ )))))
+
+(define (test-one-tx-skip-cash-flow)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-account-structure-alist env structure))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist)))
+ (today (gnc:date->timepair (localtime (current-time))))
+ (exchange-fn (lambda (currency amount date) amount))
+ (report-currency (gnc-default-report-currency))
+ )
+ (env-create-transaction env today bank-account wallet-account (gnc:make-gnc-numeric 100 1))
+ (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account))
+ (cons 'to-date-tp today)
+ (cons 'from-date-tp (decdate today (NDayDelta 1)))
+ (cons 'report-currency report-currency)
+ (cons 'include-trading-accounts #f)
+ (cons 'to-report-currency exchange-fn)))))
+ (let* ((money-in-collector (cdr (assq 'money-in-collector result)))
+ (money-out-collector (cdr (assq 'money-out-collector result)))
+ (money-in-alist (cdr (assq 'money-in-alist result)))
+ (money-out-alist (cdr (assq 'money-out-alist result))))
+ (and (null? money-in-alist)
+ (null? money-out-alist)
+ (equal? (gnc:make-gnc-numeric 0 1)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
+ report-currency exchange-fn)))
+ (equal? (gnc:make-gnc-numeric 0 1)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
+ report-currency exchange-fn))))))))
+
+(define (test-both-way-cash-flow)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-account-structure-alist env structure))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist)))
+ (today (gnc:date->timepair (localtime (current-time))))
+ (exchange-fn (lambda (currency amount date) amount))
+ (report-currency (gnc-default-report-currency))
+ )
+ (env-create-transaction env today bank-account expense-account (gnc:make-gnc-numeric 100 1))
+ (env-create-transaction env today expense-account bank-account (gnc:make-gnc-numeric 50 1))
+ (let ((result (cash-flow-calc-money-in-out (list (cons 'accounts (list wallet-account bank-account))
+ (cons 'to-date-tp today)
+ (cons 'from-date-tp (decdate today (NDayDelta 1)))
+ (cons 'report-currency report-currency)
+ (cons 'include-trading-accounts #f)
+ (cons 'to-report-currency exchange-fn)))))
+ (let* ((money-in-collector (cdr (assq 'money-in-collector result)))
+ (money-out-collector (cdr (assq 'money-out-collector result)))
+ (money-in-alist (cdr (assq 'money-in-alist result)))
+ (money-out-alist (cdr (assq 'money-out-alist result)))
+ (expense-acc-in-collector (cadr (assoc expense-account money-in-alist)))
+ (expense-acc-out-collector (cadr (assoc expense-account money-out-alist)))
+ (expenses-in-total (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-in-collector
+ report-currency
+ exchange-fn)))
+ (expenses-out-total (gnc:gnc-monetary-amount (gnc:sum-collector-commodity expense-acc-out-collector
+ report-currency
+ exchange-fn))))
+ (and (equal? (gnc:make-gnc-numeric 10000 100) expenses-in-total)
+ (equal? (gnc:make-gnc-numeric 5000 100) expenses-out-total)
+ (equal? (gnc:make-gnc-numeric 10000 100)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-in-collector
+ report-currency exchange-fn)))
+ (equal? (gnc:make-gnc-numeric 5000 100)
+ (gnc:gnc-monetary-amount (gnc:sum-collector-commodity money-out-collector
+ report-currency exchange-fn))))))))
commit 516b3025b10b9cb43f4a26b1a19e6465872444ba
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Sat Oct 31 21:01:59 2015 +0000
report-utilities: Add a very small test to show that splits are unique
for account-get-trans-type-splits-interval
diff --git a/src/report/report-system/test/Makefile.am b/src/report/report-system/test/Makefile.am
index d2a3ad6..03c001f 100644
--- a/src/report/report-system/test/Makefile.am
+++ b/src/report/report-system/test/Makefile.am
@@ -23,7 +23,8 @@ SCM_TESTS = \
test-list-extras \
test-test-extras \
test-account \
- test-split
+ test-split \
+ test-report-utilities
SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
diff --git a/src/report/report-system/test/test-report-utilities.scm b/src/report/report-system/test/test-report-utilities.scm
new file mode 100644
index 0000000..d3aeea2
--- /dev/null
+++ b/src/report/report-system/test/test-report-utilities.scm
@@ -0,0 +1,33 @@
+(use-modules (gnucash gnc-module))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
+
+(use-modules (gnucash report report-system test test-extras))
+(use-modules (gnucash report report-system))
+
+(define (run-test)
+ (test-account-get-trans-type-splits-interval))
+
+(define (NDayDelta n)
+ (let ((ddt (make-zdate)))
+ (set-tm:mday ddt n)
+ ddt))
+
+(define (test-account-get-trans-type-splits-interval)
+ (let ((env (create-test-env))
+ (end-date (gnc:date->timepair (localtime (current-time)))))
+ (let* ((accounts (env-create-account-structure-alist env (list "Assets"
+ (list (cons 'type ACCT-TYPE-ASSET))
+ (list "Bank Account")
+ (list "Wallet"))))
+ (bank-account (cdr (assoc "Bank Account" accounts)))
+ (wallet (cdr (assoc "Wallet" accounts))))
+
+ (env-create-daily-transactions env (decdate end-date (NDayDelta 10)) end-date bank-account wallet)
+
+ (let ((splits (gnc:account-get-trans-type-splits-interval (list bank-account wallet)
+ ACCT-TYPE-ASSET
+ (decdate end-date (NDayDelta 5))
+ end-date)))
+ ;; 8 is the right number (4 days, two splits per tx)
+ (and (equal? 8 (length splits)))))))
commit 6a8e97600fd61538df3c507d4474448da6dff925
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Mon Nov 9 22:31:53 2015 +0000
cashflow: Further separate work into a per-split section.
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 08a7540..f2fb9c6 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -409,113 +409,109 @@
(seen-split-list '())
(work-done 0))
- (define (calc-money-in-out-internal accounts-internal)
- (if (not (null? accounts-internal))
- (let* ((current (car accounts-internal))
- (rest (cdr accounts-internal))
- )
-
- (for-each
- (lambda (split)
- (set! work-done (+ 1 work-done))
- (if (= (modulo work-done 100) 0)
- (gnc:report-percent-done (* 85 (/ work-done splits-to-do))))
- (let ((parent (xaccSplitGetParent split)))
- (if (and (gnc:timepair-le (gnc-transaction-get-date-posted parent) to-date-tp)
- (gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp))
- (let* ((parent-description (xaccTransGetDescription parent))
- (parent-currency (xaccTransGetCurrency parent)))
+ (define (work-per-split split)
+ (set! work-done (+ 1 work-done))
+ (if (= (modulo work-done 100) 0)
+ (gnc:report-percent-done (* 85 (/ work-done splits-to-do))))
+ (let ((parent (xaccSplitGetParent split)))
+ (if (and (gnc:timepair-le (gnc-transaction-get-date-posted parent) to-date-tp)
+ (gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp))
+ (let* ((parent-description (xaccTransGetDescription parent))
+ (parent-currency (xaccTransGetCurrency parent)))
;(gnc:debug parent-description
; " - "
; (gnc-commodity-get-printname parent-currency))
- (for-each
- (lambda (s)
- (let* ((s-account (xaccSplitGetAccount s))
- (s-account-type (xaccAccountGetType s-account))
- (s-amount (xaccSplitGetAmount s))
- (s-value (xaccSplitGetValue s))
- (s-commodity (xaccAccountGetCommodity s-account)))
- ;; Check if this is a dangling split
- ;; and print a warning
- (if (null? s-account)
- (display
- (string-append
- "WARNING: s-account is NULL for split: "
- (gncSplitGetGUID s) "\n")))
-
+ (for-each
+ (lambda (s)
+ (let* ((s-account (xaccSplitGetAccount s))
+ (s-account-type (xaccAccountGetType s-account))
+ (s-amount (xaccSplitGetAmount s))
+ (s-value (xaccSplitGetValue s))
+ (s-commodity (xaccAccountGetCommodity s-account)))
+ ;; Check if this is a dangling split
+ ;; and print a warning
+ (if (null? s-account)
+ (display
+ (string-append
+ "WARNING: s-account is NULL for split: "
+ (gncSplitGetGUID s) "\n")))
;(gnc:debug (xaccAccountGetName s-account))
- (if (and ;; make sure we don't have
- (not (null? s-account)) ;; any dangling splits
- (or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
- (not (account-in-list? s-account accounts)))
- (if (not (split-in-list? s seen-split-list))
- (begin
- (set! seen-split-list (cons s seen-split-list))
- (if (gnc-numeric-negative-p s-value)
- (let ((pair (account-in-alist s-account money-in-alist)))
+ (if (and ;; make sure we don't have
+ (not (null? s-account)) ;; any dangling splits
+ (or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
+ (not (account-in-list? s-account accounts)))
+ (if (not (split-in-list? s seen-split-list))
+ (begin
+ (set! seen-split-list (cons s seen-split-list))
+ (if (gnc-numeric-negative-p s-value)
+ (let ((pair (account-in-alist s-account money-in-alist)))
;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
; (gnc-numeric-to-double s-amount)
; (gnc-commodity-get-printname parent-currency)
; (gnc-numeric-to-double s-value))
- (if (not pair)
- (begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-in-alist (cons pair money-in-alist))
- (set! money-in-accounts (cons s-account money-in-accounts))
+ (if (not pair)
+ (begin
+ (set! pair (list s-account (gnc:make-commodity-collector)))
+ (set! money-in-alist (cons pair money-in-alist))
+ (set! money-in-accounts (cons s-account money-in-accounts))
;(gnc:debug money-in-alist)
- )
- )
- (let ((s-account-in-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
- (gnc-numeric-neg s-value)
- (gnc-transaction-get-date-posted
- parent))))
- (money-in-collector 'add report-currency s-report-value)
- (s-account-in-collector 'add report-currency s-report-value))
- )
- (let ((pair (account-in-alist s-account money-out-alist)))
+ )
+ )
+ (let ((s-account-in-collector (cadr pair))
+ (s-report-value (to-report-currency parent-currency
+ (gnc-numeric-neg s-value)
+ (gnc-transaction-get-date-posted
+ parent))))
+ (money-in-collector 'add report-currency s-report-value)
+ (s-account-in-collector 'add report-currency s-report-value))
+ )
+ (let ((pair (account-in-alist s-account money-out-alist)))
;(gnc:debug "out:" (gnc-commodity-get-printname s-commodity)
; (gnc-numeric-to-double s-amount)
; (gnc-commodity-get-printname parent-currency)
; (gnc-numeric-to-double s-value))
- (if (not pair)
- (begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-out-alist (cons pair money-out-alist))
- (set! money-out-accounts (cons s-account money-out-accounts))
+ (if (not pair)
+ (begin
+ (set! pair (list s-account (gnc:make-commodity-collector)))
+ (set! money-out-alist (cons pair money-out-alist))
+ (set! money-out-accounts (cons s-account money-out-accounts))
;(gnc:debug money-out-alist)
- )
- )
- (let ((s-account-out-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
- s-value
- (gnc-transaction-get-date-posted
- parent))))
- (money-out-collector 'add report-currency s-report-value)
- (s-account-out-collector 'add report-currency s-report-value))
- )
- )
- )
- )
- )
- )
- )
- (xaccTransGetSplitList parent)
- )
+ )
+ )
+ (let ((s-account-out-collector (cadr pair))
+ (s-report-value (to-report-currency parent-currency
+ s-value
+ (gnc-transaction-get-date-posted
+ parent))))
+ (money-out-collector 'add report-currency s-report-value)
+ (s-account-out-collector 'add report-currency s-report-value))
+ )
+ )
+ )
+ )
)
- )
+ )
)
+ (xaccTransGetSplitList parent)
)
- (xaccAccountGetSplitList current)
- )
+ )
+ )
+ )
+ )
+ (define (calc-money-in-out-internal accounts-internal)
+ (if (not (null? accounts-internal))
+ (let* ((current (car accounts-internal))
+ (rest (cdr accounts-internal)))
+ (for-each work-per-split (xaccAccountGetSplitList current))
(calc-money-in-out-internal rest))))
+ ;; And calculate
(calc-money-in-out-internal accounts)
+ ;; Return an association list of results
(list (cons 'money-in-accounts money-in-accounts)
(cons 'money-in-alist money-in-alist)
(cons 'money-in-collector money-in-collector)
-
(cons 'money-out-accounts money-out-accounts)
(cons 'money-out-alist money-out-alist)
(cons 'money-out-collector money-out-collector))))
commit 5d98d4af9d44968d8e4cf000a7f0367893d3a581
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Thu Nov 12 20:29:23 2015 +0000
standard-reports/cash-flow.scm: break out main calculation part
This adds a function cash-flow-calc which does most of the donkey work and
can be tested independently of report generation.
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 7bd3f0f..08a7540 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -32,12 +32,13 @@
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
(use-modules (gnucash engine))
-
(use-modules (gnucash printf))
(gnc:module-load "gnucash/report/report-system" 0)
(gnc:module-load "gnucash/gnome-utils" 0) ;for gnc-build-url
+(export cash-flow-calc-money-in-out)
+
(define reportname (N_ "Cash Flow"))
;; define all option's names so that they are properly defined
@@ -182,21 +183,20 @@
(let* ((tree-depth (if (equal? display-depth 'all)
(accounts-get-children-depth accounts)
display-depth))
- (account-disp-list '())
-
- (money-in-accounts '())
- (money-in-alist '())
- (money-in-collector (gnc:make-commodity-collector))
-
- (money-out-accounts '())
- (money-out-alist '())
- (money-out-collector (gnc:make-commodity-collector))
(money-diff-collector (gnc:make-commodity-collector))
- (splits-to-do (gnc:accounts-count-splits accounts))
- (seen-split-list '())
+ (account-disp-list '())
+
(time-exchange-fn #f)
- (commodity-list #f))
+ (commodity-list (gnc:accounts-get-commodities
+ accounts
+ report-currency))
+ ;; Get an exchange function that will convert each transaction using the
+ ;; nearest available exchange rate if that is what is specified
+ (time-exchange-fn (gnc:case-exchange-time-fn
+ price-source report-currency
+ commodity-list to-date-tp
+ 0 0)))
;; Helper function to convert currencies
(define (to-report-currency currency amount date)
@@ -205,296 +205,320 @@
report-currency
date)))
- ;; function to add inflow and outflow of money
- (define (calc-money-in-out accounts)
- (define (calc-money-in-out-internal accounts-internal)
- (if (not (null? accounts-internal))
- (let* ((current (car accounts-internal))
- (rest (cdr accounts-internal))
- (name (xaccAccountGetName current))
- (curr-commodity (xaccAccountGetCommodity current))
- )
-
- ;(gnc:debug "calc-money-in-out-internal---" name "---" (gnc-commodity-get-printname curr-commodity))
-
- (for-each
- (lambda (split)
- (set! work-done (+ 1 work-done))
- (if (= (modulo work-done 100) 0)
- (gnc:report-percent-done (* 85 (/ work-done splits-to-do))))
- (let ((parent (xaccSplitGetParent split)))
- (if (and (gnc:timepair-le (gnc-transaction-get-date-posted parent) to-date-tp)
- (gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp))
- (let* ((parent-description (xaccTransGetDescription parent))
- (parent-currency (xaccTransGetCurrency parent)))
- ;(gnc:debug parent-description
- ; " - "
- ; (gnc-commodity-get-printname parent-currency))
- (for-each
- (lambda (s)
- (let* ((s-account (xaccSplitGetAccount s))
- (s-account-type (xaccAccountGetType s-account))
- (s-amount (xaccSplitGetAmount s))
- (s-value (xaccSplitGetValue s))
- (s-commodity (xaccAccountGetCommodity s-account)))
- ;; Check if this is a dangling split
- ;; and print a warning
- (if (null? s-account)
- (display
- (string-append
- "WARNING: s-account is NULL for split: "
- (gncSplitGetGUID s) "\n")))
-
- ;(gnc:debug (xaccAccountGetName s-account))
- (if (and ;; make sure we don't have
- (not (null? s-account)) ;; any dangling splits
- (or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
- (not (account-in-list? s-account accounts)))
- (if (not (split-in-list? s seen-split-list))
- (begin
- (set! seen-split-list (cons s seen-split-list))
- (if (gnc-numeric-negative-p s-value)
- (let ((pair (account-in-alist s-account money-in-alist)))
- ;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
- ; (gnc-numeric-to-double s-amount)
- ; (gnc-commodity-get-printname parent-currency)
- ; (gnc-numeric-to-double s-value))
- (if (not pair)
- (begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-in-alist (cons pair money-in-alist))
- (set! money-in-accounts (cons s-account money-in-accounts))
- ;(gnc:debug money-in-alist)
- )
- )
- (let ((s-account-in-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
- (gnc-numeric-neg s-value)
- (gnc-transaction-get-date-posted
- parent))))
- (money-in-collector 'add report-currency s-report-value)
- (s-account-in-collector 'add report-currency s-report-value))
+
+ (let ((result (cash-flow-calc-money-in-out
+ (list (cons 'accounts accounts)
+ (cons 'to-date-tp to-date-tp)
+ (cons 'from-date-tp from-date-tp)
+ (cons 'report-currency report-currency)
+ (cons 'include-trading-accounts include-trading-accounts)
+ (cons 'to-report-currency to-report-currency)))))
+ (let ((money-in-accounts (cdr (assq 'money-in-accounts result)))
+ (money-in-alist (cdr (assq 'money-in-alist result)))
+ (money-in-collector (cdr (assq 'money-in-collector result)))
+ (money-out-accounts (cdr (assq 'money-out-accounts result)))
+ (money-out-alist (cdr (assq 'money-out-alist result)))
+ (money-out-collector (cdr (assq 'money-out-collector result))))
+ (money-diff-collector 'merge money-in-collector #f)
+ (money-diff-collector 'minusmerge money-out-collector #f)
+
+ (set! accounts (sort accounts account-full-name<?))
+ (set! money-in-accounts (sort money-in-accounts account-full-name<?))
+ (set! money-out-accounts (sort money-out-accounts account-full-name<?))
+
+
+ (set! work-done 0)
+ (set! work-to-do (length accounts))
+ (for-each
+ (lambda (account)
+ (set! work-done (+ 1 work-done))
+ (gnc:report-percent-done (+ 85 (* 5 (/ work-done work-to-do))))
+ (if (<= (gnc-account-get-current-depth account) tree-depth)
+ (let* ((anchor (gnc:html-markup/format
+ (if (and (= (gnc-account-get-current-depth account) tree-depth)
+ (not (eq? (gnc-account-get-children account) '())))
+ (if show-subaccts?
+ (_ "%s and subaccounts")
+ (_ "%s and selected subaccounts"))
+ "%s")
+ (gnc:html-markup-anchor
+ (gnc:account-anchor-text account)
+ (if show-full-names?
+ (gnc-account-get-full-name account)
+ (xaccAccountGetName account))))))
+
+ (set! account-disp-list (cons anchor account-disp-list))
+ )
+ )
+ )
+ accounts
+ )
+
+
+ (gnc:html-document-add-object!
+ doc
+ (gnc:make-html-text (_ "Selected Accounts")))
+
+ (gnc:html-document-add-object!
+ doc
+ (gnc:make-html-text
+ (gnc:html-markup-ul
+ (reverse account-disp-list))))
+
+ (gnc:html-table-append-ruler! table 2)
+
+ (gnc:html-table-append-row/markup!
+ table
+ "primary-subheading"
+ (list
+ (_ "Money into selected accounts comes from")
+ ""))
+
+ (set! row-num 0)
+ (set! work-done 0)
+ (set! work-to-do (length money-in-alist))
+ (for-each
+ (lambda (account)
+ (set! row-num (+ 1 row-num))
+ (set! work-done (+ 1 work-done))
+ (gnc:report-percent-done (+ 90 (* 5 (/ work-done work-to-do))))
+ (let* ((pair (account-in-alist account money-in-alist))
+ (acct (car pair)))
+ (gnc:html-table-append-row/markup!
+ table
+ (if (odd? row-num) "normal-row" "alternate-row")
+ (list
+ ;(gnc:html-account-anchor acct)
+ (gnc:make-html-text
+ (gnc:html-markup-anchor
+ (gnc:account-anchor-text acct)
+ (if show-full-names?
+ (gnc-account-get-full-name acct)
+ (xaccAccountGetName acct))))
+ (gnc:make-html-table-header-cell/markup
+ "number-cell" (gnc:sum-collector-commodity (cadr pair) report-currency exchange-fn))))
+ )
+ )
+ money-in-accounts
+ )
+
+ (gnc:html-table-append-row/markup!
+ table
+ "grand-total"
+ (list
+ (gnc:make-html-table-header-cell/markup "text-cell" (_ "Money In"))
+ (gnc:make-html-table-header-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity money-in-collector report-currency exchange-fn))))
+
+ (gnc:html-table-append-ruler! table 2)
+
+ (gnc:html-table-append-row/markup!
+ table
+ "primary-subheading"
+ (list
+ (_ "Money out of selected accounts goes to")
+ ""))
+
+ (set! row-num 0)
+ (set! work-done 0)
+ (set! work-to-do (length money-out-alist))
+ (for-each
+ (lambda (account)
+ (set! row-num (+ 1 row-num))
+ (set! work-done (+ 1 work-done))
+ (gnc:report-percent-done (+ 95 (* 5 (/ work-done work-to-do))))
+ (let* ((pair (account-in-alist account money-out-alist))
+ (acct (car pair)))
+ (gnc:html-table-append-row/markup!
+ table
+ (if (odd? row-num) "normal-row" "alternate-row")
+ (list
+ ;(gnc:html-account-anchor acct)
+ (gnc:make-html-text
+ (gnc:html-markup-anchor
+ (gnc:account-anchor-text acct)
+ (if show-full-names?
+ (gnc-account-get-full-name acct)
+ (xaccAccountGetName acct))))
+ (gnc:make-html-table-header-cell/markup
+ "number-cell" (gnc:sum-collector-commodity (cadr pair) report-currency exchange-fn))))
+ )
+ )
+ money-out-accounts
+ )
+
+ (gnc:html-table-append-row/markup!
+ table
+ "grand-total"
+ (list
+ (gnc:make-html-table-header-cell/markup "text-cell" (_ "Money Out"))
+ (gnc:make-html-table-header-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity money-out-collector report-currency exchange-fn))))
+
+ (gnc:html-table-append-ruler! table 2)
+
+ (gnc:html-table-append-row/markup!
+ table
+ "grand-total"
+ (list
+ (gnc:make-html-table-header-cell/markup "text-cell" (_ "Difference"))
+ (gnc:make-html-table-header-cell/markup
+ "total-number-cell" (gnc:sum-collector-commodity money-diff-collector report-currency exchange-fn))))
+
+ (gnc:html-document-add-object! doc table)
+
+
+ ;; add currency information
+ (if show-rates?
+ (gnc:html-document-add-object!
+ doc ;;(gnc:html-markup-p
+ (gnc:html-make-exchangerates
+ report-currency exchange-fn accounts))))
+
+ ))
+
+ ;; error condition: no accounts specified
+
+ (gnc:html-document-add-object!
+ doc
+ (gnc:html-make-no-account-warning
+ reportname (gnc:report-id report-obj))))
+
+ (gnc:report-finished)
+ doc))
+
+
+;; function to add inflow and outflow of money
+(define (cash-flow-calc-money-in-out settings)
+ (let* ((accounts (cdr (assq 'accounts settings)))
+ (to-date-tp (cdr (assq 'to-date-tp settings)))
+ (from-date-tp (cdr (assq 'from-date-tp settings)))
+ (report-currency (cdr (assq 'report-currency settings)))
+ (include-trading-accounts (cdr (assq 'include-trading-accounts settings)))
+ (to-report-currency (cdr (assq 'to-report-currency settings)))
+
+ (money-in-accounts '())
+ (money-in-alist '())
+ (money-in-collector (gnc:make-commodity-collector))
+
+ (money-out-accounts '())
+ (money-out-alist '())
+ (money-out-collector (gnc:make-commodity-collector))
+
+ (splits-to-do (gnc:accounts-count-splits accounts))
+ (seen-split-list '())
+ (work-done 0))
+
+ (define (calc-money-in-out-internal accounts-internal)
+ (if (not (null? accounts-internal))
+ (let* ((current (car accounts-internal))
+ (rest (cdr accounts-internal))
+ )
+
+ (for-each
+ (lambda (split)
+ (set! work-done (+ 1 work-done))
+ (if (= (modulo work-done 100) 0)
+ (gnc:report-percent-done (* 85 (/ work-done splits-to-do))))
+ (let ((parent (xaccSplitGetParent split)))
+ (if (and (gnc:timepair-le (gnc-transaction-get-date-posted parent) to-date-tp)
+ (gnc:timepair-ge (gnc-transaction-get-date-posted parent) from-date-tp))
+ (let* ((parent-description (xaccTransGetDescription parent))
+ (parent-currency (xaccTransGetCurrency parent)))
+ ;(gnc:debug parent-description
+ ; " - "
+ ; (gnc-commodity-get-printname parent-currency))
+ (for-each
+ (lambda (s)
+ (let* ((s-account (xaccSplitGetAccount s))
+ (s-account-type (xaccAccountGetType s-account))
+ (s-amount (xaccSplitGetAmount s))
+ (s-value (xaccSplitGetValue s))
+ (s-commodity (xaccAccountGetCommodity s-account)))
+ ;; Check if this is a dangling split
+ ;; and print a warning
+ (if (null? s-account)
+ (display
+ (string-append
+ "WARNING: s-account is NULL for split: "
+ (gncSplitGetGUID s) "\n")))
+
+ ;(gnc:debug (xaccAccountGetName s-account))
+ (if (and ;; make sure we don't have
+ (not (null? s-account)) ;; any dangling splits
+ (or include-trading-accounts (not (eq? s-account-type ACCT-TYPE-TRADING)))
+ (not (account-in-list? s-account accounts)))
+ (if (not (split-in-list? s seen-split-list))
+ (begin
+ (set! seen-split-list (cons s seen-split-list))
+ (if (gnc-numeric-negative-p s-value)
+ (let ((pair (account-in-alist s-account money-in-alist)))
+ ;(gnc:debug "in:" (gnc-commodity-get-printname s-commodity)
+ ; (gnc-numeric-to-double s-amount)
+ ; (gnc-commodity-get-printname parent-currency)
+ ; (gnc-numeric-to-double s-value))
+ (if (not pair)
+ (begin
+ (set! pair (list s-account (gnc:make-commodity-collector)))
+ (set! money-in-alist (cons pair money-in-alist))
+ (set! money-in-accounts (cons s-account money-in-accounts))
+ ;(gnc:debug money-in-alist)
)
- (let ((pair (account-in-alist s-account money-out-alist)))
- ;(gnc:debug "out:" (gnc-commodity-get-printname s-commodity)
- ; (gnc-numeric-to-double s-amount)
- ; (gnc-commodity-get-printname parent-currency)
- ; (gnc-numeric-to-double s-value))
- (if (not pair)
- (begin
- (set! pair (list s-account (gnc:make-commodity-collector)))
- (set! money-out-alist (cons pair money-out-alist))
- (set! money-out-accounts (cons s-account money-out-accounts))
- ;(gnc:debug money-out-alist)
- )
- )
- (let ((s-account-out-collector (cadr pair))
- (s-report-value (to-report-currency parent-currency
- s-value
- (gnc-transaction-get-date-posted
- parent))))
- (money-out-collector 'add report-currency s-report-value)
- (s-account-out-collector 'add report-currency s-report-value))
+ )
+ (let ((s-account-in-collector (cadr pair))
+ (s-report-value (to-report-currency parent-currency
+ (gnc-numeric-neg s-value)
+ (gnc-transaction-get-date-posted
+ parent))))
+ (money-in-collector 'add report-currency s-report-value)
+ (s-account-in-collector 'add report-currency s-report-value))
+ )
+ (let ((pair (account-in-alist s-account money-out-alist)))
+ ;(gnc:debug "out:" (gnc-commodity-get-printname s-commodity)
+ ; (gnc-numeric-to-double s-amount)
+ ; (gnc-commodity-get-printname parent-currency)
+ ; (gnc-numeric-to-double s-value))
+ (if (not pair)
+ (begin
+ (set! pair (list s-account (gnc:make-commodity-collector)))
+ (set! money-out-alist (cons pair money-out-alist))
+ (set! money-out-accounts (cons s-account money-out-accounts))
+ ;(gnc:debug money-out-alist)
)
)
+ (let ((s-account-out-collector (cadr pair))
+ (s-report-value (to-report-currency parent-currency
+ s-value
+ (gnc-transaction-get-date-posted
+ parent))))
+ (money-out-collector 'add report-currency s-report-value)
+ (s-account-out-collector 'add report-currency s-report-value))
)
)
)
- )
+ )
)
- (xaccTransGetSplitList parent)
- )
- )
- )
- )
- )
- (xaccAccountGetSplitList current)
- )
-
- (calc-money-in-out-internal rest))))
-
- (calc-money-in-out-internal accounts))
-
- ;; Get an exchange function that will convert each transaction using the
- ;; nearest available exchange rate if that is what is specified
- (set! commodity-list (gnc:accounts-get-commodities
- accounts
- report-currency))
- (set! time-exchange-fn (gnc:case-exchange-time-fn
- price-source report-currency
- commodity-list to-date-tp
- 0 0))
-
-
- (calc-money-in-out accounts)
-
- (money-diff-collector 'merge money-in-collector #f)
- (money-diff-collector 'minusmerge money-out-collector #f)
-
- (set! accounts (sort accounts account-full-name<?))
- (set! money-in-accounts (sort money-in-accounts account-full-name<?))
- (set! money-out-accounts (sort money-out-accounts account-full-name<?))
-
-
- (set! work-done 0)
- (set! work-to-do (length accounts))
- (for-each
- (lambda (account)
- (set! work-done (+ 1 work-done))
- (gnc:report-percent-done (+ 85 (* 5 (/ work-done work-to-do))))
- (if (<= (gnc-account-get-current-depth account) tree-depth)
- (let* ((anchor (gnc:html-markup/format
- (if (and (= (gnc-account-get-current-depth account) tree-depth)
- (not (eq? (gnc-account-get-children account) '())))
- (if show-subaccts?
- (_ "%s and subaccounts")
- (_ "%s and selected subaccounts"))
- "%s")
- (gnc:html-markup-anchor
- (gnc:account-anchor-text account)
- (if show-full-names?
- (gnc-account-get-full-name account)
- (xaccAccountGetName account))))))
-
- (set! account-disp-list (cons anchor account-disp-list))
- )
- )
- )
- accounts
- )
-
-
- (gnc:html-document-add-object!
- doc
- (gnc:make-html-text (_ "Selected Accounts")))
-
- (gnc:html-document-add-object!
- doc
- (gnc:make-html-text
- (gnc:html-markup-ul
- (reverse account-disp-list))))
-
- (gnc:html-table-append-ruler! table 2)
-
- (gnc:html-table-append-row/markup!
- table
- "primary-subheading"
- (list
- (_ "Money into selected accounts comes from")
- ""))
-
- (set! row-num 0)
- (set! work-done 0)
- (set! work-to-do (length money-in-alist))
- (for-each
- (lambda (account)
- (set! row-num (+ 1 row-num))
- (set! work-done (+ 1 work-done))
- (gnc:report-percent-done (+ 90 (* 5 (/ work-done work-to-do))))
- (let* ((pair (account-in-alist account money-in-alist))
- (acct (car pair)))
- (gnc:html-table-append-row/markup!
- table
- (if (odd? row-num) "normal-row" "alternate-row")
- (list
- ;(gnc:html-account-anchor acct)
- (gnc:make-html-text
- (gnc:html-markup-anchor
- (gnc:account-anchor-text acct)
- (if show-full-names?
- (gnc-account-get-full-name acct)
- (xaccAccountGetName acct))))
- (gnc:make-html-table-header-cell/markup
- "number-cell" (gnc:sum-collector-commodity (cadr pair) report-currency exchange-fn))))
- )
- )
- money-in-accounts
- )
-
- (gnc:html-table-append-row/markup!
- table
- "grand-total"
- (list
- (gnc:make-html-table-header-cell/markup "text-cell" (_ "Money In"))
- (gnc:make-html-table-header-cell/markup
- "total-number-cell" (gnc:sum-collector-commodity money-in-collector report-currency exchange-fn))))
-
- (gnc:html-table-append-ruler! table 2)
-
- (gnc:html-table-append-row/markup!
- table
- "primary-subheading"
- (list
- (_ "Money out of selected accounts goes to")
- ""))
-
- (set! row-num 0)
- (set! work-done 0)
- (set! work-to-do (length money-out-alist))
- (for-each
- (lambda (account)
- (set! row-num (+ 1 row-num))
- (set! work-done (+ 1 work-done))
- (gnc:report-percent-done (+ 95 (* 5 (/ work-done work-to-do))))
- (let* ((pair (account-in-alist account money-out-alist))
- (acct (car pair)))
- (gnc:html-table-append-row/markup!
- table
- (if (odd? row-num) "normal-row" "alternate-row")
- (list
- ;(gnc:html-account-anchor acct)
- (gnc:make-html-text
- (gnc:html-markup-anchor
- (gnc:account-anchor-text acct)
- (if show-full-names?
- (gnc-account-get-full-name acct)
- (xaccAccountGetName acct))))
- (gnc:make-html-table-header-cell/markup
- "number-cell" (gnc:sum-collector-commodity (cadr pair) report-currency exchange-fn))))
- )
- )
- money-out-accounts
- )
-
- (gnc:html-table-append-row/markup!
- table
- "grand-total"
- (list
- (gnc:make-html-table-header-cell/markup "text-cell" (_ "Money Out"))
- (gnc:make-html-table-header-cell/markup
- "total-number-cell" (gnc:sum-collector-commodity money-out-collector report-currency exchange-fn))))
-
- (gnc:html-table-append-ruler! table 2)
-
- (gnc:html-table-append-row/markup!
- table
- "grand-total"
- (list
- (gnc:make-html-table-header-cell/markup "text-cell" (_ "Difference"))
- (gnc:make-html-table-header-cell/markup
- "total-number-cell" (gnc:sum-collector-commodity money-diff-collector report-currency exchange-fn))))
-
- (gnc:html-document-add-object! doc table)
-
-
- ;; add currency information
- (if show-rates?
- (gnc:html-document-add-object!
- doc ;;(gnc:html-markup-p
- (gnc:html-make-exchangerates
- report-currency exchange-fn accounts))))
-
-
-
- ;; error condition: no accounts specified
-
- (gnc:html-document-add-object!
- doc
- (gnc:html-make-no-account-warning
- reportname (gnc:report-id report-obj))))
-
- (gnc:report-finished)
- doc))
+ )
+ )
+ (xaccTransGetSplitList parent)
+ )
+ )
+ )
+ )
+ )
+ (xaccAccountGetSplitList current)
+ )
+
+ (calc-money-in-out-internal rest))))
+
+ (calc-money-in-out-internal accounts)
+ (list (cons 'money-in-accounts money-in-accounts)
+ (cons 'money-in-alist money-in-alist)
+ (cons 'money-in-collector money-in-collector)
+
+ (cons 'money-out-accounts money-out-accounts)
+ (cons 'money-out-alist money-out-alist)
+ (cons 'money-out-collector money-out-collector))))
(gnc:define-report
'version 1
commit b47f04539ef20e409b7516a5886c1b6c459df874
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Thu Nov 12 20:26:18 2015 +0000
Move account & split.scm to engine-utilities
diff --git a/src/engine/engine-utilities.scm b/src/engine/engine-utilities.scm
index 6838f66..1310ff9 100644
--- a/src/engine/engine-utilities.scm
+++ b/src/engine/engine-utilities.scm
@@ -20,6 +20,12 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;; Copyright 2000 Rob Browning <rlb at cs.utexas.edu>
+(use-modules (gnucash gnc-module))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/engine" 0))
+
+(use-modules (srfi srfi-1)
+ (srfi srfi-13))
(define (gnc:account-map-descendants thunk account)
(let ((descendants (or (gnc-account-get-descendants-sorted account) '())))
@@ -28,3 +34,64 @@
(define (gnc:account-map-children thunk account)
(let ((children (or (gnc-account-get-children-sorted account) '())))
(map thunk children)))
+
+;; account related functions
+;; is account in list of accounts?
+(define (account-same? a1 a2)
+ (or (eq? a1 a2)
+ (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2))))
+
+(define account-in-list?
+ (lambda (account accounts)
+ (cond
+ ((null? accounts) #f)
+ ((account-same? (car accounts) account) #t)
+ (else (account-in-list? account (cdr accounts))))))
+
+;; Optimized version of accout-in-list if we know
+;; the list in advance.
+(define (account-in-list-pred accounts)
+ (define (my-assoc str alist)
+ (find (lambda (pair) (account-same? str (car pair))) alist))
+ (define (my-hash acc size)
+ (remainder (string-hash (gncAccountGetGUID acc)) size))
+ (let ((hash-table (make-hash-table)))
+ (for-each (lambda (acc) (hashx-set! my-hash my-assoc hash-table acc #t))
+ accounts)
+ (lambda (account)
+ (hashx-ref my-hash my-assoc hash-table account))))
+
+(define account-in-alist
+ (lambda (account alist)
+ (cond
+ ((null? alist) #f)
+ ((account-same? (caar alist) account) (car alist))
+ (else (account-in-alist account (cdr alist))))))
+
+;; helper for sorting of account list
+(define (account-full-name<? a b)
+ (string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
+
+;; return maximum depth over accounts and their children, if any
+(define (accounts-get-children-depth accounts)
+ (apply max
+ (map (lambda (acct)
+ (let ((acct-depth (gnc-account-get-current-depth acct)))
+ (+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
+ accounts)))
+
+;; Splits
+(export split-same?)
+(export split-in-list?)
+
+(define (split-same? s1 s2)
+ (or (eq? s1 s2)
+ (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2))))
+
+(define split-in-list?
+ (lambda (split splits)
+ (cond
+ ((null? splits) #f)
+ ((split-same? (car splits) split) #t)
+ (else (split-in-list? split (cdr splits))))))
+
diff --git a/src/engine/engine.scm b/src/engine/engine.scm
index c049886..5c52b14 100644
--- a/src/engine/engine.scm
+++ b/src/engine/engine.scm
@@ -67,9 +67,22 @@
(export GNC_COMMODITY_NS_MUTUAL)
(export gnc:url->loaded-session)
+
+;; engine-utilities.scm
(export gnc:account-map-descendants)
(export gnc:account-map-children)
+(export account-same?)
+(export account-in-list?)
+(export account-in-list-pred)
+(export account-in-alist)
+(export account-full-name<?)
+(export account-list-predicate)
+(export accounts-get-children-depth)
+
+(export split-same?)
+(export split-in-list?)
+
(export gnc:split-structure)
(export gnc:make-split-scm)
(export gnc:split-scm?)
diff --git a/src/report/report-system/Makefile.am b/src/report/report-system/Makefile.am
index a6e49a9..4ce4cd7 100644
--- a/src/report/report-system/Makefile.am
+++ b/src/report/report-system/Makefile.am
@@ -69,11 +69,9 @@ gncscm_DATA = \
gncmodscmdir = ${GNC_SCM_INSTALL_DIR}/gnucash/report/report-system
gncmodscm_DATA = \
- account.scm \
collectors.scm \
list-extras.scm \
- report-collectors.scm \
- split.scm
+ report-collectors.scm
gncscmmoddir = ${GNC_SCM_INSTALL_DIR}/gnucash/report/
gncscmmod_DATA = \
diff --git a/src/report/report-system/account.scm b/src/report/report-system/account.scm
index 787e5f1..6540329 100644
--- a/src/report/report-system/account.scm
+++ b/src/report/report-system/account.scm
@@ -1,62 +1,5 @@
(define-module (gnucash report report-system account))
(use-modules (gnucash gnc-module))
-(use-modules (gnucash gnc-module))
-
-(use-modules (srfi srfi-1)
- (srfi srfi-13))
-
-(gnc:module-begin-syntax (gnc:module-load "gnucash/engine" 0))
-
-(export account-same?)
-(export account-in-list?)
-(export account-in-list-pred)
-(export account-in-alist)
-(export account-full-name<?)
-(export account-list-predicate)
-(export accounts-get-children-depth)
-
-;; is account in list of accounts?
-(define (account-same? a1 a2)
- (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
-
-(define account-in-list?
- (lambda (account accounts)
- (cond
- ((null? accounts) #f)
- ((account-same? (car accounts) account) #t)
- (else (account-in-list? account (cdr accounts))))))
-
-;; Optimized version of accout-in-list if we know
-;; the list in advance.
-(define (account-in-list-pred accounts)
- (define (my-assoc str alist)
- (find (lambda (pair) (account-same? str (car pair))) alist))
- (define (my-hash acc size)
- (remainder (string-hash (gncAccountGetGUID acc)) size))
- (let ((hash-table (make-hash-table)))
- (for-each (lambda (acc) (hashx-set! my-hash my-assoc hash-table acc #t))
- accounts)
- (lambda (account)
- (hashx-ref my-hash my-assoc hash-table account))))
-
-(define account-in-alist
- (lambda (account alist)
- (cond
- ((null? alist) #f)
- ((account-same? (caar alist) account) (car alist))
- (else (account-in-alist account (cdr alist))))))
-
-;; helper for sorting of account list
-(define (account-full-name<? a b)
- (string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
-
-;; return maximum depth over accounts and their children, if any
-(define (accounts-get-children-depth accounts)
- (apply max
- (map (lambda (acct)
- (let ((acct-depth (gnc-account-get-current-depth acct)))
- (+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
- accounts)))
diff --git a/src/report/report-system/split.scm b/src/report/report-system/split.scm
index cce15c1..07313bc 100644
--- a/src/report/report-system/split.scm
+++ b/src/report/report-system/split.scm
@@ -5,16 +5,3 @@
(use-modules (sw_engine))
-(export split-same?)
-(export split-in-list?)
-
-(define (split-same? s1 s2)
- (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
-
-(define split-in-list?
- (lambda (split splits)
- (cond
- ((null? splits) #f)
- ((split-same? (car splits) split) #t)
- (else (split-in-list? split (cdr splits))))))
-
diff --git a/src/report/report-system/test/test-account.scm b/src/report/report-system/test/test-account.scm
index fa310d6..b30c0d0 100644
--- a/src/report/report-system/test/test-account.scm
+++ b/src/report/report-system/test/test-account.scm
@@ -1,4 +1,4 @@
-(use-modules (gnucash report report-system account))
+(use-modules (gnucash engine))
(use-modules (gnucash report report-system test test-extras))
(use-modules (sw_engine))
diff --git a/src/report/report-system/test/test-split.scm b/src/report/report-system/test/test-split.scm
index 286864b..b835a57 100644
--- a/src/report/report-system/test/test-split.scm
+++ b/src/report/report-system/test/test-split.scm
@@ -3,7 +3,7 @@
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
-(use-modules (gnucash report report-system split))
+(use-modules (gnucash engine))
(use-modules (gnucash report report-system test test-extras))
(use-modules (gnucash report report-system))
diff --git a/src/report/standard-reports/budget.scm b/src/report/standard-reports/budget.scm
index 00d2d27..c12a07b 100644
--- a/src/report/standard-reports/budget.scm
+++ b/src/report/standard-reports/budget.scm
@@ -31,8 +31,7 @@
(use-modules (gnucash gettext))
(use-modules (gnucash printf))
-(use-modules (gnucash report report-system account))
-(use-modules (gnucash report report-system split))
+(use-modules (gnucash engine))
(gnc:module-load "gnucash/report/report-system" 0)
(gnc:module-load "gnucash/gnome-utils" 0) ;for gnc-build-url
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 6ba919f..7bd3f0f 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -31,8 +31,7 @@
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
-(use-modules (gnucash report report-system account))
-(use-modules (gnucash report report-system split))
+(use-modules (gnucash engine))
(use-modules (gnucash printf))
commit 8dfea02da79ecefd290be928c5b25a9e765764d1
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Mon Nov 9 22:47:57 2015 +0000
reports: Add account and split module, plus tests.
Remove common functions from the budget and cashflow reports.
Add into separate modules, plus some tests for these newly exposed
functions.
diff --git a/src/report/report-system/Makefile.am b/src/report/report-system/Makefile.am
index 9a79871..a6e49a9 100644
--- a/src/report/report-system/Makefile.am
+++ b/src/report/report-system/Makefile.am
@@ -69,10 +69,11 @@ gncscm_DATA = \
gncmodscmdir = ${GNC_SCM_INSTALL_DIR}/gnucash/report/report-system
gncmodscm_DATA = \
+ account.scm \
collectors.scm \
list-extras.scm \
- report-collectors.scm
-
+ report-collectors.scm \
+ split.scm
gncscmmoddir = ${GNC_SCM_INSTALL_DIR}/gnucash/report/
gncscmmod_DATA = \
diff --git a/src/report/report-system/account.scm b/src/report/report-system/account.scm
new file mode 100644
index 0000000..787e5f1
--- /dev/null
+++ b/src/report/report-system/account.scm
@@ -0,0 +1,62 @@
+(define-module (gnucash report report-system account))
+(use-modules (gnucash gnc-module))
+(use-modules (gnucash gnc-module))
+
+(use-modules (srfi srfi-1)
+ (srfi srfi-13))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/engine" 0))
+
+(export account-same?)
+(export account-in-list?)
+(export account-in-list-pred)
+(export account-in-alist)
+(export account-full-name<?)
+(export account-list-predicate)
+(export accounts-get-children-depth)
+
+;; is account in list of accounts?
+(define (account-same? a1 a2)
+ (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
+
+(define account-in-list?
+ (lambda (account accounts)
+ (cond
+ ((null? accounts) #f)
+ ((account-same? (car accounts) account) #t)
+ (else (account-in-list? account (cdr accounts))))))
+
+;; Optimized version of accout-in-list if we know
+;; the list in advance.
+(define (account-in-list-pred accounts)
+ (define (my-assoc str alist)
+ (find (lambda (pair) (account-same? str (car pair))) alist))
+ (define (my-hash acc size)
+ (remainder (string-hash (gncAccountGetGUID acc)) size))
+ (let ((hash-table (make-hash-table)))
+ (for-each (lambda (acc) (hashx-set! my-hash my-assoc hash-table acc #t))
+ accounts)
+ (lambda (account)
+ (hashx-ref my-hash my-assoc hash-table account))))
+
+(define account-in-alist
+ (lambda (account alist)
+ (cond
+ ((null? alist) #f)
+ ((account-same? (caar alist) account) (car alist))
+ (else (account-in-alist account (cdr alist))))))
+
+;; helper for sorting of account list
+(define (account-full-name<? a b)
+ (string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
+
+;; return maximum depth over accounts and their children, if any
+(define (accounts-get-children-depth accounts)
+ (apply max
+ (map (lambda (acct)
+ (let ((acct-depth (gnc-account-get-current-depth acct)))
+ (+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
+ accounts)))
+
+
+
diff --git a/src/report/report-system/split.scm b/src/report/report-system/split.scm
new file mode 100644
index 0000000..cce15c1
--- /dev/null
+++ b/src/report/report-system/split.scm
@@ -0,0 +1,20 @@
+(define-module (gnucash report report-system split))
+(use-modules (gnucash gnc-module))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/engine" 0))
+
+(use-modules (sw_engine))
+
+(export split-same?)
+(export split-in-list?)
+
+(define (split-same? s1 s2)
+ (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
+
+(define split-in-list?
+ (lambda (split splits)
+ (cond
+ ((null? splits) #f)
+ ((split-same? (car splits) split) #t)
+ (else (split-in-list? split (cdr splits))))))
+
diff --git a/src/report/report-system/test/Makefile.am b/src/report/report-system/test/Makefile.am
index a01900e..d2a3ad6 100644
--- a/src/report/report-system/test/Makefile.am
+++ b/src/report/report-system/test/Makefile.am
@@ -21,7 +21,9 @@ TESTS = \
SCM_TESTS = \
test-collectors \
test-list-extras \
- test-test-extras
+ test-test-extras \
+ test-account \
+ test-split
SCM_TEST_SRCS = $(SCM_TESTS:%=%.scm)
diff --git a/src/report/report-system/test/test-account.scm b/src/report/report-system/test/test-account.scm
new file mode 100644
index 0000000..fa310d6
--- /dev/null
+++ b/src/report/report-system/test/test-account.scm
@@ -0,0 +1,47 @@
+(use-modules (gnucash report report-system account))
+
+(use-modules (gnucash report report-system test test-extras))
+(use-modules (sw_engine))
+
+(define (run-test)
+ (test test-account-same?)
+ (test test-account-in-list?)
+ (test test-account-in-alist?)
+ (test test-account-list-predicate))
+
+(define (test-account-same?)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-test-accounts env))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist))))
+ (and (account-same? bank-account bank-account)
+ (not (account-same? bank-account expense-account)))))
+
+(define (test-account-in-alist?)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-test-accounts env))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist))))
+ (let ((alist (list (cons bank-account "Bank") (cons expense-account "Expenses"))))
+ (and (account-in-alist bank-account alist)
+ (account-in-alist expense-account alist)
+ (not (account-in-alist wallet-account alist))))))
+
+(define (test-account-in-list?)
+ (test-account-list-predicate-generic
+ (lambda (accounts) (lambda (account) (account-in-list? account accounts)))))
+
+(define (test-account-list-predicate)
+ (test-account-list-predicate-generic account-in-list-pred))
+
+(define (test-account-list-predicate-generic predicate)
+ (let* ((env (create-test-env))
+ (account-alist (env-create-test-accounts env))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (other-account (cdr (assoc "Other" account-alist)))
+ (bank-or-wallet? (predicate (list bank-account wallet-account))))
+ (and (bank-or-wallet? bank-account)
+ (bank-or-wallet? wallet-account)
+ (not (bank-or-wallet? other-account)))))
diff --git a/src/report/report-system/test/test-extras.scm b/src/report/report-system/test/test-extras.scm
index dbb409a..52506d4 100644
--- a/src/report/report-system/test/test-extras.scm
+++ b/src/report/report-system/test/test-extras.scm
@@ -54,8 +54,10 @@
(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)
(export pattern-streamer)
@@ -235,6 +237,15 @@
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
@@ -247,6 +258,15 @@
(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))))))
;; Date sequences
;;
diff --git a/src/report/report-system/test/test-split.scm b/src/report/report-system/test/test-split.scm
new file mode 100644
index 0000000..286864b
--- /dev/null
+++ b/src/report/report-system/test/test-split.scm
@@ -0,0 +1,33 @@
+(use-modules (gnucash gnc-module))
+(use-modules (srfi srfi-1))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
+
+(use-modules (gnucash report report-system split))
+(use-modules (gnucash report report-system test test-extras))
+
+(use-modules (gnucash report report-system))
+
+(define (run-test)
+ (test test-split-in-list?))
+
+(define (test-split-in-list?)
+ (let* ((env (create-test-env))
+ (today (gnc:date->timepair (localtime (current-time))))
+ (account-alist (env-create-test-accounts env))
+ (bank-account (cdr (assoc "Bank" account-alist)))
+ (expense-account (cdr (assoc "Expenses" account-alist)))
+ (wallet-account (cdr (assoc "Wallet" account-alist)))
+ (tx1 (env-create-transaction env today bank-account wallet-account (gnc:make-gnc-numeric 20 1)))
+ (tx2 (env-create-transaction env today bank-account expense-account (gnc:make-gnc-numeric 10 1)))
+ (splits-tx1 (xaccTransGetSplitList tx1))
+ (splits-tx2 (xaccTransGetSplitList tx2)))
+ (and (split-in-list? (first splits-tx1) splits-tx1)
+ (split-in-list? (second splits-tx1) splits-tx1)
+ (not (split-in-list? (first splits-tx1) splits-tx2))
+ (not (split-in-list? (second splits-tx1) splits-tx2))
+ (not (split-in-list? (first splits-tx1) '())))))
+
+
+
+
diff --git a/src/report/standard-reports/budget.scm b/src/report/standard-reports/budget.scm
index ab59e67..00d2d27 100644
--- a/src/report/standard-reports/budget.scm
+++ b/src/report/standard-reports/budget.scm
@@ -31,6 +31,8 @@
(use-modules (gnucash gettext))
(use-modules (gnucash printf))
+(use-modules (gnucash report report-system account))
+(use-modules (gnucash report report-system split))
(gnc:module-load "gnucash/report/report-system" 0)
(gnc:module-load "gnucash/gnome-utils" 0) ;for gnc-build-url
@@ -557,47 +559,6 @@
;;(txt (gnc:make-html-text))
)
- ;; is account in list of accounts?
- (define (same-account? a1 a2)
- (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
-
- (define (same-split? s1 s2)
- (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
-
- (define account-in-list?
- (lambda (account accounts)
- (cond
- ((null? accounts) #f)
- ((same-account? (car accounts) account) #t)
- (else (account-in-list? account (cdr accounts))))))
-
- (define split-in-list?
- (lambda (split splits)
- (cond
- ((null? splits) #f)
- ((same-split? (car splits) split) #t)
- (else (split-in-list? split (cdr splits))))))
-
- (define account-in-alist
- (lambda (account alist)
- (cond
- ((null? alist) #f)
- ((same-account? (caar alist) account) (car alist))
- (else (account-in-alist account (cdr alist))))))
-
- ;; helper for sorting of account list
- (define (account-full-name<? a b)
- (string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
-
- ;; helper for account depth
- (define (accounts-get-children-depth accounts)
- (apply max
- (map (lambda (acct)
- (let ((children (gnc-account-get-children acct)))
- (if (null? children)
- 1
- (+ 1 (accounts-get-children-depth children)))))
- accounts)))
;; end of defines
;; add subaccounts if requested
diff --git a/src/report/standard-reports/cash-flow.scm b/src/report/standard-reports/cash-flow.scm
index 4e8cebd..6ba919f 100644
--- a/src/report/standard-reports/cash-flow.scm
+++ b/src/report/standard-reports/cash-flow.scm
@@ -31,6 +31,8 @@
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
+(use-modules (gnucash report report-system account))
+(use-modules (gnucash report report-system split))
(use-modules (gnucash printf))
@@ -158,47 +160,6 @@
(table (gnc:make-html-table))
(txt (gnc:make-html-text)))
- ;; is account in list of accounts?
- (define (same-account? a1 a2)
- (string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2)))
-
- (define (same-split? s1 s2)
- (string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2)))
-
- (define account-in-list?
- (lambda (account accounts)
- (cond
- ((null? accounts) #f)
- ((same-account? (car accounts) account) #t)
- (else (account-in-list? account (cdr accounts))))))
-
- (define split-in-list?
- (lambda (split splits)
- (cond
- ((null? splits) #f)
- ((same-split? (car splits) split) #t)
- (else (split-in-list? split (cdr splits))))))
-
- (define account-in-alist
- (lambda (account alist)
- (cond
- ((null? alist) #f)
- ((same-account? (caar alist) account) (car alist))
- (else (account-in-alist account (cdr alist))))))
-
- ;; helper for sorting of account list
- (define (account-full-name<? a b)
- (string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
-
- ;; return maximum depth over accounts and their children, if any
- (define (accounts-get-children-depth accounts)
- (apply max
- (map (lambda (acct)
- (let ((acct-depth (gnc-account-get-current-depth acct)))
- (+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
- accounts)))
-
-
(gnc:html-document-set-title!
doc (string-append
(get-option gnc:pagename-general gnc:optname-reportname)
commit f9ab945cad3c0af7734aebdbdd383c10f4c0e2ec
Author: Peter Broadbery <p.broadbery at gmail.com>
Date: Sun Nov 8 22:43:58 2015 +0000
Add and use a macro for loading modules.
diff --git a/src/gnc-module/gnc-module.scm b/src/gnc-module/gnc-module.scm
index 20786d3..544f37c 100644
--- a/src/gnc-module/gnc-module.scm
+++ b/src/gnc-module/gnc-module.scm
@@ -49,3 +49,12 @@
(export gnc:module-load)
(export gnc:module-load-optional)
(export gnc:module-unload)
+(export gnc:module-begin-syntax)
+
+;; Guile 2 needs to load external modules at compile time
+(cond-expand
+ (guile-2
+ (define-syntax-rule (gnc:module-begin-syntax form ...)
+ (eval-when (load compile eval expand) (begin form ...))))
+ (else
+ (define gnc:module-begin-syntax begin)))
diff --git a/src/report/standard-reports/test/test-standard-category-report.scm b/src/report/standard-reports/test/test-standard-category-report.scm
index c90d13c..fcb95b7 100644
--- a/src/report/standard-reports/test/test-standard-category-report.scm
+++ b/src/report/standard-reports/test/test-standard-category-report.scm
@@ -27,14 +27,8 @@
;; otherwise the N_ syntax-rule won't be found at compile time
;; causing the test to fail
;; That's what the wrapper below is meant for:
-(cond-expand
- (guile-2
- (define-syntax-rule (begin-for-syntax form ...)
- (eval-when (load compile eval expand) (begin form ...))))
- (else
- (define begin-for-syntax begin)))
-
-(begin-for-syntax (gnc:module-load "gnucash/report/report-system" 0))
+
+(gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0))
(use-modules (gnucash main)) ;; FIXME: delete after we finish modularizing.
(use-modules (gnucash printf))
diff --git a/src/report/standard-reports/test/test-standard-net-barchart.scm b/src/report/standard-reports/test/test-standard-net-barchart.scm
index 5fd1bec..825c92c 100644
--- a/src/report/standard-reports/test/test-standard-net-barchart.scm
+++ b/src/report/standard-reports/test/test-standard-net-barchart.scm
@@ -22,18 +22,8 @@
(use-modules (gnucash gnc-module))
-;; Guile 2 needs to load external modules at compile time
-;; otherwise the N_ syntax-rule won't be found at compile time
-;; causing the test to fail
-;; That's what the wrapper below is meant for:
-(cond-expand
- (guile-2
- (define-syntax-rule (begin-for-syntax form ...)
- (eval-when (load compile eval expand) (begin form ...))))
- (else
- (define begin-for-syntax begin)))
-
-(begin-for-syntax (gnc:module-load "gnucash/report/report-system" 0))
+(gnc:module-begin-syntax (gnc:module-load "gnucash/report/report-system" 0))
+
(use-modules (gnucash engine))
(use-modules (sw_engine))
Summary of changes:
src/engine/engine-utilities.scm | 95 +++
src/engine/engine.scm | 20 +
src/engine/test/Makefile.am | 38 +-
src/engine/test/test-account.scm | 47 ++
.../report-system => engine}/test/test-extras.scm | 95 +--
src/engine/test/test-split.scm | 29 +
...est-create-account.scm => test-test-extras.scm} | 39 +-
src/gnc-module/gnc-module.scm | 9 +
src/report/report-system/Makefile.am | 1 -
src/report/report-system/test/Makefile.am | 5 +-
src/report/report-system/test/test-collectors.scm | 2 +-
src/report/report-system/test/test-extras.scm | 218 +------
src/report/report-system/test/test-list-extras.scm | 2 +-
.../report-system/test/test-report-utilities.scm | 34 ++
src/report/report-system/test/test-test-extras.scm | 4 +-
src/report/standard-reports/budget.scm | 42 +-
src/report/standard-reports/cash-flow.scm | 660 ++++++++++-----------
src/report/standard-reports/test/Makefile.am | 3 +
.../standard-reports/test/test-cash-flow.scm | 127 ++++
.../test/test-generic-category-report.scm | 1 +
.../test/test-generic-net-barchart.scm | 1 +
.../test/test-generic-net-linechart.scm | 1 +
.../test/test-standard-category-report.scm | 10 +-
.../test/test-standard-net-barchart.scm | 14 +-
24 files changed, 786 insertions(+), 711 deletions(-)
create mode 100644 src/engine/test/test-account.scm
copy src/{report/report-system => engine}/test/test-extras.scm (80%)
create mode 100644 src/engine/test/test-split.scm
copy src/engine/test/{test-create-account.scm => test-test-extras.scm} (57%)
create mode 100644 src/report/report-system/test/test-report-utilities.scm
create mode 100644 src/report/standard-reports/test/test-cash-flow.scm
More information about the gnucash-changes
mailing list