IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

Revert "Merge Stefan Bayer's 'SepaInternalTransfer' into maint."

Browse Source 
This reverts commit 17a3f7fef2, reversing
changes made to b8458d0732.
This commit is contained in:
John Ralls 2021-12-03 13:58:07 -08:00
parent 8e67853344
commit 5c7967c4a5
61 changed files with 5328 additions and 1062 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
bindings/guile/CMakeLists.txt
View File

@ -127,6 +127,14 @@ gnc_add_scheme_targets(scm-engine-2
add_custom_target(scm-engine ALL DEPENDS scm-engine-2 scm-engine-1 scm-engine-0)
set(scm_gnc_module_DEPENDS
gnucash-guile)
gnc_add_scheme_targets(scm-gnc-module
SOURCES gnc-module.scm
OUTPUT_DIR gnucash
DEPENDS "${scm_gnc_module_DEPENDS}")
set_local_dist(guile_DIST_local
CMakeLists.txt
core-utils.scm

35
bindings/guile/business-core.scm
View File

@ -30,6 +30,7 @@
(export gnc:owner-get-address-dep)
(export gnc:owner-get-name-and-address-dep)
(export gnc:owner-get-owner-id)
(export gnc:owner-from-split)
(export gnc:split->owner)
(define (gnc:owner-get-address owner)
@ -104,9 +105,37 @@
(gnc:owner-get-owner-id (gncJobGetOwner (gncOwnerGetJob owner))))
(else ""))))
;; this function aims to find a split's owner. It will allocate and
;; memoize (cache) the owners because gncOwnerGetOwnerFromLot is
;; slow. after use, it must be called with #f to free the owners.
;; this function aims to find a split's owner. various splits are
;; supported: (1) any splits in the invoice posted transaction, in
;; APAR or income/expense accounts (2) any splits from invoice's
;; payments, in APAR or asset/liability accounts. it returns either
;; the owner or '() if not found. in addition, if owner was found, the
;; result-owner argument is mutated to it.
(define (gnc:owner-from-split split result-owner)
(define (notnull x) (and (not (null? x)) x))
(issue-deprecation-warning
"gnc:owner-from-split is deprecated in 4.x. use gnc:split->owner instead.")
(let* ((trans (xaccSplitGetParent split))
(invoice (notnull (gncInvoiceGetInvoiceFromTxn trans)))
(temp (gncOwnerNew))
(owner (or (and invoice (gncInvoiceGetOwner invoice))
(any
(lambda (split)
(let* ((lot (xaccSplitGetLot split))
(invoice (notnull (gncInvoiceGetInvoiceFromLot lot))))
(or (and invoice (gncInvoiceGetOwner invoice))
(and (gncOwnerGetOwnerFromLot lot temp) temp))))
(xaccTransGetSplitList trans)))))
(gncOwnerFree temp)
(cond (owner (gncOwnerCopy (gncOwnerGetEndOwner owner) result-owner)
result-owner)
(else '()))))
;; optimized from above, and simpler: does not search all transaction
;; splits. It will allocate and memoize (cache) the owners because
;; gncOwnerGetOwnerFromLot is slow. after use, it must be called with
;; #f to free the owners.
(define gnc:split->owner
(let ((ht (make-hash-table)))
(lambda (split)

41
bindings/guile/engine.scm
View File

@ -30,3 +30,44 @@
(gnucash engine business-core)
(gnucash engine commodity-table)
(gnucash engine gnc-numeric))
(export gnc-pricedb-lookup-latest-before-t64)
(export gnc-pricedb-lookup-latest-before-any-currency-t64)
(export gnc:account-map-descendants)
(export gnc:account-map-children)
(export account-full-name<?)
(export accounts-get-children-depth)
(define (gnc-pricedb-lookup-latest-before-t64 . args)
(issue-deprecation-warning "gnc-pricedb-lookup-latest-before-t64 has been renamed to gnc-pricedb-lookup-nearest-before-t64")
(apply gnc-pricedb-lookup-nearest-before-t64 args))
(define (gnc-pricedb-lookup-latest-before-any-currency-t64 . args)
(issue-deprecation-warning "gnc-pricedb-lookup-latest-before-any-currency-t64 has been renamed to gnc-pricedb-lookup-nearest-before-any-currency-t64")
(apply gnc-pricedb-lookup-nearest-before-any-currency-t64 args))
;; A few account related utility functions which used to be in engine-utilities.scm
(define (gnc:account-map-descendants thunk account)
(issue-deprecation-warning "gnc:account-map-descendants is deprecated.")
(map thunk (or (gnc-account-get-descendants-sorted account) '())))
(define (gnc:account-map-children thunk account)
(issue-deprecation-warning "gnc:account-map-children is deprecated.")
(map thunk (or (gnc-account-get-children-sorted account) '())))
;; account related functions
;; helper for sorting of account list
(define (account-full-name<? a b)
(issue-deprecation-warning
"account-full-name<? is deprecated. use gnc:account-full-name<? instead.")
(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)
(issue-deprecation-warning "accounts-get-children-depth is deprecated. use \
gnc:accounts-get-children-depth instead.")
(1- (apply max
(map (lambda (acct)
(+ (gnc-account-get-current-depth acct)
(gnc-account-get-tree-depth acct)))
accounts))))

88
bindings/guile/gnc-module.scm Normal file
View File

@ -0,0 +1,88 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; gnc-module.scm
;;; Guile module which allows initialization of the gnucash module
;;; system from Scheme
;;;
;;; Copyright 2001 Linux Developers Group
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash gnc-module))
(use-modules (ice-9 match))
(define (deprecate . lst)
;; 4.x deprecation. remove in 5.x
(issue-deprecation-warning (string-concatenate lst)))
(define (no-op-deprecation-warning)
(deprecate "* WARNING * Guile wrappers for the gnc module system have been \
deprecated. This particular function call is now a no-op. Please use \
equivalent (use-modules ...) calls instead."))
(define-public gnc:module-system-init no-op-deprecation-warning)
(define-public gnc:module-system-refresh no-op-deprecation-warning)
(define-public gnc:module-load-optional no-op-deprecation-warning)
(define-public gnc:module-unload no-op-deprecation-warning)
(define-public (gnc:module-load gnc-mod-name mod-sys-version)
(let* ((mod-name-split (string-split gnc-mod-name #\/))
(mod-name-str (string-join mod-name-split " "))
(scm-mod-name (map string->symbol mod-name-split)))
(match gnc-mod-name
("gnucash/app-utils"
(deprecate "* WARNING * 'gnc:module-load (\"gnucash/app-utils\" 0)' has \
been deprecated and will be removed in gnucash 5.0. Use '(use-modules (gnucash \
engine) (gnucash app-utils))' instead. Use of the '(gnucash engine)' guile \
module is optional and depends on whether or not you use functions from \
this module in your code or not.")
(use-modules (gnucash engine) (gnucash app-utils)))
((or "gnucash/tax/de_DE" "gnucash/tax/us")
(set! scm-mod-name `(gnucash locale ,(list-ref scm-mod-name 2) tax))
(set! mod-name-str (string-join (map symbol->string scm-mod-name) " "))
(deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' has \
been deprecated. Use '(use-modules (" mod-name-str "))' instead.")
(module-use! (current-module) (resolve-interface scm-mod-name)))
((or "gnucash/gnome-utils" "gnucash/report/report-system")
(when (string=? gnc-mod-name "gnucash/report/report-system")
(set! mod-name-str "gnucash report"))
(set! scm-mod-name '(gnucash report))
(deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' has \
been deprecated. Use '(use-modules (gnucash engine) (gnucash app-utils) \
(" mod-name-str "))' instead. Use of the '(gnucash engine)' or \
'(gnucash app-utils)' guile modules is optional and depends on whether \
or not you use functions from this module in your code or not.")
(use-modules (gnucash engine) (gnucash app-utils))
(module-use! (current-module) (resolve-interface scm-mod-name)))
("gnucash/html"
(deprecate "* WARNING * '(gnc:module-load \"gnucash/html\" 0)' has \
been deprecated. Use '(use-modules (gnucash html))' instead.")
(use-modules (gnucash html))
(module-use! (current-module) (resolve-interface scm-mod-name)))
(_ (deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' \
has been deprecated. Use '(use-modules (" mod-name-str "))' instead. \
Additional guile modules may have to be loaded depending on your specific code.")
(module-use! (current-module) (resolve-interface scm-mod-name))))))

15
bindings/guile/test/CMakeLists.txt
View File

@ -31,6 +31,7 @@ set(bindings_test_SCHEME
#list(APPEND engine_test_SCHEME test-scm-query-import.scm) Fails
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-core-utils
scm-engine)
@ -40,6 +41,12 @@ gnc_add_scheme_test_targets(scm-test-engine-extras
OUTPUT_DIR "tests"
DEPENDS "${GUILE_DEPENDS}")
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash engine test test-extras"
NEW_MODULE "tests test-engine-extras"
DEPENDS "scm-test-engine-extras")
gnc_add_scheme_test_targets(scm-test-engine
SOURCES "${bindings_test_SCHEME}"
OUTPUT_DIR "tests"
@ -62,6 +69,12 @@ if (HAVE_SRFI64)
OUTPUT_DIR "tests"
DEPENDS "${GUILE_DEPENDS};scm-test-engine-extras;scm-srfi64-extras")
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash engine test srfi64-extras"
NEW_MODULE "tests srfi64-extras"
DEPENDS "scm-srfi64-extras")
gnc_add_scheme_test_targets (scm-test-with-srfi64
SOURCES "${scm_tests_with_srfi64_SOURCES}"
OUTPUT_DIR "tests"
@ -78,6 +91,7 @@ set(test_scm_SCHEME
)
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-engine
scm-srfi64-extras
@ -116,7 +130,6 @@ set(test_guile_DIST
)
# Define two imaginary deprecated guile modules to test the compat file generation code
# See commit bbcffa3ec for old code using this function.
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash deprecated-module")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash superseded-module"

53
bindings/guile/test/test-business-core.scm
View File

@ -242,4 +242,57 @@
(env-transfer env 01 01 1990
(get-acct "Income-GBP") (get-acct "Bank-GBP") 10)
(let ((new-owner (gncOwnerNew)))
(test-equal "new-owner is initially empty"
""
(gncOwnerGetName new-owner))
(test-equal "gnc:owner-from-split (from AR) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "AR-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from AR) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner (gncOwnerNew))
(test-equal "gnc:owner-from-split (from inc-acct) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Income-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from inc-acct) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner (gncOwnerNew))
(test-equal "gnc:owner-from-split (from payment txn) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Bank-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from payment txn) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner 'reset)
(test-equal "gnc:owner-from-split (non-business split) return"
""
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Bank-GBP")))
new-owner)))
(test-equal "gnc:owner-from-split (non-business split) mutated"
'reset
new-owner))
))

6
bindings/guile/test/test-scm-engine.scm
View File

@ -11,4 +11,10 @@
(define (test-engine)
(test-begin "testing function availability")
(test-assert "testing gnc-pricedb-lookup-latest-before-t64"
(gnc-pricedb-lookup-latest-before-t64 '() '() '() 0))
(test-assert "testing gnc-pricedb-lookup-latest-before-any-currency-t64"
(gnc-pricedb-lookup-latest-before-any-currency-t64 '() '() 0))
(test-end "testing deprecated functions"))

42
bindings/guile/test/test-scm-utilities.scm
View File

@ -7,12 +7,25 @@
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-scm-utilities.scm")
(test-traverse-vec)
(test-substring-replace)
(test-sort-and-delete-duplicates)
(test-gnc:html-string-sanitize)
(test-gnc:list-flatten)
(test-end "test-scm-utilities.scm"))
(define (test-traverse-vec)
(test-begin "traverse-vec")
(test-equal "list->vec"
(vector 1 (vector 2 3))
(traverse-list->vec
(list 1 (list 2 3))))
(test-equal "vec->list"
(list 1 (list 2 3))
(traverse-vec->list
(vector 1 (vector 2 3))))
(test-end "traverse-vec"))
(define (test-substring-replace)
(test-begin "substring-replace")
@ -21,6 +34,35 @@
"fooxyzfooxyz"
(gnc:substring-replace "foobarfoobar" "bar" "xyz"))
;; note the following 2 tests illustrate code behaviour: start from
;; 2nd matched substring, and perform either 2 or 1 substitution.
(test-equal "gnc:substring-replace-from-to ... ... 2 2"
"foobarfooxyzfooxyz"
(gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 2))
(test-equal "gnc:substring-replace-from-to ... ... 2 1"
"foobarfooxyzfoobar"
(gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 1))
;; comprehensive test suite for gnc:substring-replace-from-to:
(test-equal "gnc:substring-replace-from-to ... ... 2 1"
"foo xxx foo foo foo foo foo foo"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 2 1))
(test-equal "gnc:substring-replace-from-to ... ... 1 1"
"xxx foo foo foo foo foo foo foo"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 1 1))
(test-equal "gnc:substring-replace-from-to ... ... 4 -1"
"foo foo foo xxx xxx xxx xxx xxx"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 4 -1))
(test-end "substring-replace"))
(define (test-sort-and-delete-duplicates)

38
bindings/guile/utilities.scm
View File

@ -32,6 +32,8 @@
(export addto!)
(export sort-and-delete-duplicates)
(export gnc:list-flatten)
(export traverse-list->vec)
(export traverse-vec->list)
(export gnc:substring-replace-from-to)
(export gnc:substring-replace)
(export gnc:html-string-sanitize)
@ -64,6 +66,22 @@
(define-syntax-rule (addto! alist element)
(set! alist (cons element alist)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pair of utility functions for use with guile-json which requires
;; lists converted vectors to save as json arrays. traverse list
;; converting into vectors, and vice versa.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (traverse-list->vec lst)
(issue-deprecation-warning "traverse-list->vec unused.")
(cond
((list? lst) (list->vector (map traverse-list->vec lst)))
(else lst)))
(define (traverse-vec->list vec)
(issue-deprecation-warning "traverse-vec->list unused.")
(cond
((vector? vec) (map traverse-vec->list (vector->list vec)))
(else vec)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general and efficient string-replace-substring function, based on
@ -108,6 +126,26 @@
(define (gnc:substring-replace s1 s2 s3)
(string-replace-substring s1 s2 s3))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:substring-replace-from-to
;; same as gnc:substring-replace extended by:
;; start: from which occurrence onwards the replacement shall start
;; end-after: max. number times the replacement should executed
;;
;; Example: (gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 1)
;; returns "foobarfooxyzfoobar".
;;
;; start=1 and end-after<=0 will call gnc:substring-replace (replace all)
;; start>1 and end-after<=0 will the replace from "start" until end of file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:substring-replace-from-to s1 s2 s3 start end-after)
(issue-deprecation-warning "gnc:substring-replace-from-to is deprecated in 4.x.")
(string-replace-substring
s1 s2 s3 0 (string-length s1) (max 0 (1- start))
(and (positive? end-after) (+ (max 0 (1- start)) (1- end-after)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; function to sanitize strings. the resulting string can be safely
;; added to html.

6
common/test-core/CMakeLists.txt
View File

@ -66,6 +66,12 @@ gnc_add_scheme_test_targets(scm-test-core
add_dependencies(check scm-test-core)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash unittest-support"
NEW_MODULE "tests unittest-support"
DEPENDS "scm-test-core")
if (GTEST_SRC_DIR)
# in contrast to GoogleTest build system libraries libgtest.a and libgtest_main.a

6
gnucash/gnome/CMakeLists.txt
View File

@ -255,6 +255,12 @@ gnc_add_scheme_targets(scm-gnome
OUTPUT_DIR gnucash
DEPENDS "${GUILE_DEPENDS}")
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report report-gnome"
NEW_MODULE"gnucash report-menus"
DEPENDS "scm-gnome")
set_dist_list(gnome_DIST
CMakeLists.txt gnome.i gnucash.appdata.xml.in.in gnucash.desktop.in.in
gnucash.releases.xml ${gnc_gnome_noinst_HEADERS} ${gnc_gnome_SOURCES} ${gnome_SCHEME})

26
gnucash/gschemas/org.gnucash.GnuCash.deprecated.gschema.xml.in
View File

@ -5,6 +5,12 @@
</schema>
<schema id="org.gnucash.general" path="/org/gnucash/general/">
<key name="migrate-prefs-done" type="b">
<default>false</default>
<summary>-Obsolete-</summary>
<description>This setting is obsolete and will be removed in the next major @PROJECT_NAME@ release series.</description>
</key>
<key name="prefs-version" type="i">
<default>0</default>
<summary>The version of these settings</summary>
@ -419,6 +425,26 @@ For example setting this to 2.0 will display reports at twice their typical size
<child name="options" schema="org.gnucash.dialogs.options"/>
</schema>
<schema id="org.gnucash.dialogs.business-assoc" path="/org/gnucash/dialogs/business-assoc/">
<key type="(iiii)" name="last-geometry">
<default>(-1,-1,-1,-1)</default>
<summary>Last window position and size</summary>
<description>This setting describes the size and position of the window when it was last closed.
The numbers are the X and Y coordinates of the top left corner of the window
followed by the width and height of the window.</description>
</key>
</schema>
<schema id="org.gnucash.dialogs.trans-assoc" path="/org/gnucash/dialogs/trans-assoc/">
<key type="(iiii)" name="last-geometry">
<default>(-1,-1,-1,-1)</default>
<summary>Last window position and size</summary>
<description>This setting describes the size and position of the window when it was last closed.
The numbers are the X and Y coordinates of the top left corner of the window
followed by the width and height of the window.</description>
</key>
</schema>
<schema id="org.gnucash.dialogs.account" path="/org/gnucash/dialogs/account/">
<key name="last-geometry" type="(iiii)">
<default>(-1,-1,-1,-1)</default>

5
gnucash/gschemas/org.gnucash.GnuCash.gschema.xml.in
View File

@ -241,6 +241,11 @@
<summary>Color the register using a gnucash specific color theme</summary>
<description>When enabled the register will use a GnuCash specific color theme (green/yellow). Otherwise it will use the system color theme. Regardless of this setting the user can always override the color theme via a gnucash specific css file to be stored in the gnucash used config directory. More information can be found in the gnucash FAQ.</description>
</key>
<key name="use-theme-colors" type="b">
<default>false</default>
<summary>Superseded by "use-gnucash-color-theme"</summary>
<description>This option is temporarily kept around for backwards compatibility. It will be removed in a future version.</description>
</key>
<key name="enter-moves-to-end" type="b">
<default>false</default>
<summary>"Enter" key moves to bottom of register</summary>

778
gnucash/gschemas/pref_transformations.xml
View File

@ -1373,783 +1373,15 @@
</release>
<release version="5000">
<release version="4009">
<obsolete old-path="org.gnucash.general"
old-key="prefs-version"/>
<obsolete old-path="org.gnucash.general"
old-key="save-window-geometry"/>
<obsolete old-path="org.gnucash.general"
old-key="account-separator"/>
<obsolete old-path="org.gnucash.general"
old-key="assoc-head"/>
<obsolete old-path="org.gnucash.general"
old-key="file-compression"/>
<obsolete old-path="org.gnucash.general"
old-key="autosave-show-explanation"/>
<obsolete old-path="org.gnucash.general"
old-key="autosave-interval-minutes"/>
<obsolete old-path="org.gnucash.general"
old-key="save-on-close-expires"/>
<obsolete old-path="org.gnucash.general"
old-key="save-on-close-wait-time"/>
<obsolete old-path="org.gnucash.general"
old-key="negative-in-red"/>
<obsolete old-path="org.gnucash.general"
old-key="auto-decimal-point"/>
<obsolete old-path="org.gnucash.general"
old-key="auto-decimal-places"/>
<obsolete old-path="org.gnucash.general"
old-key="force-price-decimal"/>
<obsolete old-path="org.gnucash.general"
old-key="retain-type-never"/>
<obsolete old-path="org.gnucash.general"
old-key="retain-type-days"/>
<obsolete old-path="org.gnucash.general"
old-key="retain-type-forever"/>
<obsolete old-path="org.gnucash.general"
old-key="retain-days"/>
<obsolete old-path="org.gnucash.general"
old-key="reversed-accounts-none"/>
<obsolete old-path="org.gnucash.general"
old-key="reversed-accounts-credit"/>
<obsolete old-path="org.gnucash.general"
old-key="reversed-accounts-incomeexpense"/>
<obsolete old-path="org.gnucash.general"
old-key="show-account-color"/>
<obsolete old-path="org.gnucash.general"
old-key="show-account-color-tabs"/>
<obsolete old-path="org.gnucash.general"
old-key="use-accounting-labels"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-close-buttons"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-width"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-open-adjacent"/>
<obsolete old-path="org.gnucash.general"
old-key="currency-choice-locale"/>
<obsolete old-path="org.gnucash.general"
old-key="currency-choice-other"/>
<obsolete old-path="org.gnucash.general"
old-key="currency-other"/>
<obsolete old-path="org.gnucash.general"
old-key="clock-24h"/>
<obsolete old-path="org.gnucash.general"
old-key="date-format"/>
<obsolete old-path="org.gnucash.general"
old-key="date-completion-thisyear"/>
<obsolete old-path="org.gnucash.general"
old-key="date-completion-sliding"/>
<obsolete old-path="org.gnucash.general"
old-key="date-backmonths"/>
<obsolete old-path="org.gnucash.general"
old-key="grid-lines-horizontal"/>
<obsolete old-path="org.gnucash.general"
old-key="grid-lines-vertical"/>
<obsolete old-path="org.gnucash.general"
old-key="show-splash-screen"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-position-top"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-position-bottom"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-position-left"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-position-right"/>
<obsolete old-path="org.gnucash.general"
old-key="summarybar-position-top"/>
<obsolete old-path="org.gnucash.general"
old-key="summarybar-position-bottom"/>
<obsolete old-path="org.gnucash.general"
old-key="tab-next-recent"/>
<obsolete old-path="org.gnucash.general"
old-key="num-source"/>
<obsolete old-path="org.gnucash.general.register"
old-key="use-gnucash-color-theme"/>
<obsolete old-path="org.gnucash.general.register"
old-key="use-theme-colors"/>
<obsolete old-path="org.gnucash.general.register"
old-key="enter-moves-to-end"/>
<obsolete old-path="org.gnucash.general.register"
old-key="auto-raise-lists"/>
<obsolete old-path="org.gnucash.general.register"
old-key="tab-to-transfer-on-memorised"/>
<obsolete old-path="org.gnucash.general.register"
old-key="use-new-window"/>
<obsolete old-path="org.gnucash.general.register"
old-key="alternate-color-by-transaction"/>
<obsolete old-path="org.gnucash.general.register"
old-key="draw-horizontal-lines"/>
<obsolete old-path="org.gnucash.general.register"
old-key="draw-vertical-lines"/>
<obsolete old-path="org.gnucash.general.register"
old-key="future-after-blank-transaction"/>
<obsolete old-path="org.gnucash.general.register"
old-key="default-style-ledger"/>
<obsolete old-path="org.gnucash.general.register"
old-key="default-style-autoledger"/>
<obsolete old-path="org.gnucash.general.register"
old-key="default-style-journal"/>
<obsolete old-path="org.gnucash.general.register"
old-key="double-line-mode"/>
<obsolete old-path="org.gnucash.general.register"
old-key="show-leaf-account-names"/>
<obsolete old-path="org.gnucash.general.register"
old-key="show-extra-dates"/>
<obsolete old-path="org.gnucash.general.register"
old-key="show-extra-dates-on-selection"/>
<obsolete old-path="org.gnucash.general.register"
old-key="show-calendar-buttons"/>
<obsolete old-path="org.gnucash.general.register"
old-key="selection-to-blank-on-expand"/>
<obsolete old-path="org.gnucash.general.register"
old-key="max-transactions"/>
<obsolete old-path="org.gnucash.general.register"
old-key="key-length"/>
<obsolete old-path="org.gnucash.general.report"
old-key="use-new-window"/>
<obsolete old-path="org.gnucash.general.report"
old-key="currency-choice-locale"/>
<obsolete old-path="org.gnucash.general.report"
old-key="currency-choice-other"/>
<obsolete old-path="org.gnucash.general.report"
old-key="currency-other"/>
<obsolete old-path="org.gnucash.general.report"
old-key="default-zoom"/>
<obsolete old-path="org.gnucash.general.report.pdf-export"
old-key="filename-format"/>
<obsolete old-path="org.gnucash.general.report.pdf-export"
old-key="filename-date-format"/>
<obsolete old-path="org.gnucash.dev"
old-key="allow-file-incompatibility"/>
<obsolete old-path="org.gnucash.dialogs.account"
<obsolete old-path="org.gnucash.dialogs.business-assoc"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.imap-editor"
<obsolete old-path="org.gnucash.dialogs.trans-assoc"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.find-account"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.preferences"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.price-editor"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.pricedb-editor"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.reset-warnings"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.tax-info"
old-key="paned-position"/>
<obsolete old-path="org.gnucash.dialogs.tax-info"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.fincalc"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.find"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.find"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.export-accounts"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.log-replay"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.open-save"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.report"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.report-saved-configs"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.lot-viewer"
old-key="hpane-position"/>
<obsolete old-path="org.gnucash.dialogs.lot-viewer"
old-key="vpane-position"/>
<obsolete old-path="org.gnucash.dialogs.lot-viewer"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.new-user"
old-key="first-startup"/>
<obsolete old-path="org.gnucash.dialogs.new-hierarchy"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.new-hierarchy"
old-key="show-on-new-file"/>
<obsolete old-path="org.gnucash.dialogs.search"
old-key="new-search-limit"/>
<obsolete old-path="org.gnucash.dialogs.transfer"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business-doclink"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.trans-doclink"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.style-sheet"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.options"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.customer-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.customer-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.employee-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.employee-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.job-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.job-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.order-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.order-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.vendor-search"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.business.vendor-search"
old-key="search-for-active-only"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="tax-included"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="auto-pay"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="notify-when-due"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="days-in-advance"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="enable-toolbuttons"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="invoice-printreport"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="use-new-window"/>
<obsolete old-path="org.gnucash.dialogs.business.invoice"
old-key="accumulate-splits"/>
<obsolete old-path="org.gnucash.dialogs.business.bill"
old-key="tax-included"/>
<obsolete old-path="org.gnucash.dialogs.business.bill"
old-key="auto-pay"/>
<obsolete old-path="org.gnucash.dialogs.business.bill"
old-key="notify-when-due"/>
<obsolete old-path="org.gnucash.dialogs.business.bill"
old-key="days-in-advance"/>
<obsolete old-path="org.gnucash.dialogs.business.tax-tables"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="check-format-guid"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="check-position"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="first-page-count"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="date-format"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="date-format-user"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-units"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-payee"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-date"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-amount-words"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-amount-number"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-address"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-notes"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-memo"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-translation"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="custom-rotation"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="splits-amount"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="splits-memo"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="splits-account"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="print-date-format"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="default-font"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="blocking-chars"/>
<obsolete old-path="org.gnucash.dialogs.checkprinting"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.commodities"
old-key="include-iso"/>
<obsolete old-path="org.gnucash.dialogs.commodities"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.export.csv"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.export.csv"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.export.csv"
old-key="paned-position"/>
<obsolete old-path="org.gnucash.dialogs.import.csv"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.csv"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="enable-skip"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="enable-update"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="use-bayes"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="match-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="match-date-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="match-date-not-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="auto-add-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="auto-clear-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="atm-fee-threshold"/>
<obsolete old-path="org.gnucash.dialogs.import.generic"
old-key="auto-create-commodity"/>
<obsolete old-path="org.gnucash.dialogs.import.generic.match-picker"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.generic.match-picker"
old-key="display-reconciled"/>
<obsolete old-path="org.gnucash.dialogs.import.generic.account-picker"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.generic.transaction-list"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="default-status-notcleared"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="default-status-cleared"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="default-status-reconciled"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.import.qif"
old-key="show-doc"/>
<obsolete old-path="org.gnucash.dialogs.import.qif.account-picker"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.reconcile"
old-key="check-cleared"/>
<obsolete old-path="org.gnucash.dialogs.reconcile"
old-key="auto-interest-transfer"/>
<obsolete old-path="org.gnucash.dialogs.reconcile"
old-key="auto-cc-payment"/>
<obsolete old-path="org.gnucash.dialogs.reconcile"
old-key="always-reconcile-to-today"/>
<obsolete old-path="org.gnucash.dialogs.reconcile"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.sxs.since-last-run"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.sxs.since-last-run"
old-key="show-at-file-open"/>
<obsolete old-path="org.gnucash.dialogs.sxs.since-last-run"
old-key="show-notify-window-at-file-open"/>
<obsolete old-path="org.gnucash.dialogs.sxs.since-last-run"
old-key="review-transactions"/>
<obsolete old-path="org.gnucash.dialogs.sxs.transaction-editor"
old-key="create-auto"/>
<obsolete old-path="org.gnucash.dialogs.sxs.transaction-editor"
old-key="create-days"/>
<obsolete old-path="org.gnucash.dialogs.sxs.transaction-editor"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.sxs.transaction-editor"
old-key="notify"/>
<obsolete old-path="org.gnucash.dialogs.sxs.transaction-editor"
old-key="remind-days"/>
<obsolete old-path="org.gnucash.dialogs.totd"
old-key="current-tip"/>
<obsolete old-path="org.gnucash.dialogs.totd"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.totd"
old-key="show-at-startup"/>
<obsolete old-path="org.gnucash.general.finance-quote"
old-key="alphavantage-api-key"/>
<obsolete old-path="org.gnucash.history"
old-key="maxfiles"/>
<obsolete old-path="org.gnucash.history"
old-key="file0"/>
<obsolete old-path="org.gnucash.history"
old-key="file1"/>
<obsolete old-path="org.gnucash.history"
old-key="file2"/>
<obsolete old-path="org.gnucash.history"
old-key="file3"/>
<obsolete old-path="org.gnucash.history"
old-key="file4"/>
<obsolete old-path="org.gnucash.history"
old-key="file5"/>
<obsolete old-path="org.gnucash.history"
old-key="file6"/>
<obsolete old-path="org.gnucash.history"
old-key="file7"/>
<obsolete old-path="org.gnucash.history"
old-key="file8"/>
<obsolete old-path="org.gnucash.history"
old-key="file9"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="checkprinting-multi-acct"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="closing-window-question"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="inv-entry-mod"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="inv-entry-dup"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="price-comm-del"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="price-comm-del-quotes"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="price-quotes-del"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="price-quotes-replace"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-is-acct-pay-rec"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-is-read-only"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-recd-split-mod"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-recd-split-unrec"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-split-del"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-split-del-recd"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-split-del-all"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-split-del-all-recd"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-trans-del"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-trans-del-recd"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-trans-dup"/>
<obsolete old-path="org.gnucash.warnings.permanent"
old-key="reg-trans-mod"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="checkprinting-multi-acct"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="closing-window-question"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="inv-entry-mod"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="inv-entry-dup"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="price-comm-del"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="price-comm-del-quotes"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="price-quotes-del"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="price-quotes-replace"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-is-acct-pay-rec"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-is-read-only"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-recd-split-mod"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-recd-split-unrec"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-split-del"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-split-del-recd"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-split-del-all"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-split-del-all-recd"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-trans-del"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-trans-del-recd"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-trans-dup"/>
<obsolete old-path="org.gnucash.warnings.temporary"
old-key="reg-trans-mod"/>
<obsolete old-path="org.gnucash.window.pages"
old-key="account-code-visible"/>
<obsolete old-path="org.gnucash.window.pages"
old-key="account-code-width"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="grand-total"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="non-currency"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="start-choice-relative"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="start-choice-absolute"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="start-date"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="start-period"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="end-choice-relative"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="end-choice-absolute"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="end-date"/>
<obsolete old-path="org.gnucash.window.pages.account-tree.summary"
old-key="end-period"/>
<obsolete old-path="org.gnucash.general"
old-key="migrate-prefs-done"/>
</release>

49
gnucash/import-export/aqb/dialog-ab-trans.c
View File

@ -153,9 +153,6 @@ gboolean gnc_ab_trans_isSEPA(GncABTransType t)
switch (t)
{
case SEPA_TRANSFER:
#if (AQBANKING_VERSION_INT >= 60400)
case SEPA_INTERNAL_TRANSFER:
#endif
case SEPA_DEBITNOTE:
return TRUE;
default:
@ -285,12 +282,6 @@ gnc_ab_trans_dialog_new(GtkWidget *parent, GNC_AB_ACCOUNT_SPEC *ab_acc,
GtkWidget *orig_bankcode_label;
GtkCellRenderer *renderer;
GtkTreeViewColumn *column;
#if (AQBANKING_VERSION_INT >= 60400)
GtkExpander *template_expander;
GtkWidget *template_label;
GtkWidget *add_templ_button;
GtkWidget *del_templ_button;
#endif
g_return_val_if_fail(ab_acc, NULL);
@ -351,12 +342,6 @@ gnc_ab_trans_dialog_new(GtkWidget *parent, GNC_AB_ACCOUNT_SPEC *ab_acc,
orig_bankcode_label = GTK_WIDGET(gtk_builder_get_object (builder, "orig_bankcode_label"));
td->template_gtktreeview =
GTK_TREE_VIEW(gtk_builder_get_object (builder, "template_list"));
#if (AQBANKING_VERSION_INT >= 60400)
template_expander = GTK_EXPANDER(gtk_builder_get_object (builder, "expander1"));
template_label = GTK_WIDGET(gtk_builder_get_object (builder, "label1"));
add_templ_button= GTK_WIDGET(gtk_builder_get_object(builder, "add_templ_button"));
del_templ_button= GTK_WIDGET(gtk_builder_get_object(builder, "del_templ_button"));
#endif
/* Amount edit */
td->amount_edit = gnc_amount_edit_new();
@ -403,35 +388,6 @@ gnc_ab_trans_dialog_new(GtkWidget *parent, GNC_AB_ACCOUNT_SPEC *ab_acc,
_("Originator BIC (Bank Code)"));
break;
#if (AQBANKING_VERSION_INT >= 60400)
case SEPA_INTERNAL_TRANSFER:
gtk_label_set_text(GTK_LABEL (heading_label),
_("Enter a SEPA Internal Transfer"));
gtk_label_set_text(GTK_LABEL(recp_account_heading),
_("Recipient IBAN (International Account Number)"));
gtk_label_set_text(GTK_LABEL(recp_bankcode_heading),
_("Recipient BIC (Bank Code)"));
gtk_label_set_text(GTK_LABEL(orig_account_heading),
_("Originator IBAN (International Account Number)"));
gtk_label_set_text(GTK_LABEL(orig_bankcode_heading),
_("Originator BIC (Bank Code)"));
/* Disable target account entry for SEPA internal transfers, but only let choose from templates */
gtk_widget_set_sensitive(td->recp_name_entry, FALSE);
gtk_widget_set_sensitive(td->recp_account_entry, FALSE);
gtk_widget_set_sensitive(td->recp_bankcode_entry, FALSE);
gtk_widget_set_sensitive(add_templ_button, FALSE);
gtk_widget_set_visible(add_templ_button, FALSE);
gtk_widget_set_can_focus(add_templ_button, FALSE);
gtk_widget_set_sensitive(del_templ_button, FALSE);
gtk_widget_set_visible(del_templ_button, FALSE);
gtk_widget_set_can_focus(del_templ_button, FALSE);
gtk_label_set_text(GTK_LABEL(template_label),
_("Target Accounts"));
gtk_expander_set_expanded(template_expander, TRUE);
break;
#endif
case SINGLE_DEBITNOTE:
/* this case is no longer in use; don't introduce extra strings */
break;
@ -869,11 +825,6 @@ gnc_ab_trans_dialog_get_available_empty_job(GNC_AB_ACCOUNT_SPEC *ab_acc, GncABTr
case SEPA_TRANSFER:
cmd=AB_Transaction_CommandSepaTransfer;
break;
#if (AQBANKING_VERSION_INT >= 60400)
case SEPA_INTERNAL_TRANSFER:
cmd=AB_Transaction_CommandSepaInternalTransfer;
break;
#endif
case SEPA_DEBITNOTE:
cmd=AB_Transaction_CommandSepaDebitNote;
break;

3
gnucash/import-export/aqb/dialog-ab-trans.h
View File

@ -56,9 +56,6 @@ enum _GncABTransType
SINGLE_INTERNAL_TRANSFER
, SEPA_TRANSFER
, SEPA_DEBITNOTE
#if (AQBANKING_VERSION_INT >= 60400)
, SEPA_INTERNAL_TRANSFER
#endif
};
/**
* Returns true if the given GncABTransType is an European (SEPA) transaction

45
gnucash/import-export/aqb/gnc-ab-transfer.c
View File

@ -114,26 +114,10 @@ gnc_ab_maketrans(GtkWidget *parent, Account *gnc_acc,
goto cleanup;
}
#if (AQBANKING_VERSION_INT >= 60400)
if (trans_type == SEPA_INTERNAL_TRANSFER)
{
/* Generate list of template transactions from the reference accounts*/
templates = gnc_ab_trans_templ_list_new_from_ref_accounts (ab_acc);
if (templates == NULL)
{
g_warning ("gnc_ab_gettrans: No reference accounts found");
gnc_error_dialog (GTK_WINDOW (parent), _("No reference accounts found."));
goto cleanup;
}
}
else
#endif
{
/* Get list of template transactions */
templates = gnc_ab_trans_templ_list_new_from_book(
gnc_account_get_book(gnc_acc));
}
templates = gnc_ab_trans_templ_list_new_from_book(
gnc_account_get_book(gnc_acc));
/* Create new ABTransDialog */
td = gnc_ab_trans_dialog_new(parent, ab_acc,
xaccAccountGetCommoditySCU(gnc_acc),
@ -171,21 +155,15 @@ gnc_ab_maketrans(GtkWidget *parent, Account *gnc_acc,
/* Let the user enter the values */
result = gnc_ab_trans_dialog_run_until_ok(td);
/* Save the templates */
templates = gnc_ab_trans_dialog_get_templ(td, &changed);
#if (AQBANKING_VERSION_INT >= 60400)
if (trans_type != SEPA_INTERNAL_TRANSFER && changed)
#else
if (changed)
#endif
{
/* Save the templates */
if (changed)
save_templates(parent, gnc_acc, templates,
(result == GNC_RESPONSE_NOW));
}
g_list_free(templates);
templates = NULL;
templates = NULL;
if (result != GNC_RESPONSE_NOW && result != GNC_RESPONSE_LATER)
{
aborted = TRUE;
@ -242,13 +220,6 @@ gnc_ab_maketrans(GtkWidget *parent, Account *gnc_acc,
xfer_dialog, _("Online Banking European (SEPA) Transfer"));
gnc_xfer_dialog_lock_from_account_tree(xfer_dialog);
break;
#if (AQBANKING_VERSION_INT >= 60400)
case SEPA_INTERNAL_TRANSFER:
gnc_xfer_dialog_set_title (
xfer_dialog, _("Online Banking European (SEPA) Internal Transfer"));
gnc_xfer_dialog_lock_from_account_tree (xfer_dialog);
break;
#endif
case SEPA_DEBITNOTE:
gnc_xfer_dialog_set_title(
xfer_dialog, _("Online Banking European (SEPA) Debit Note"));

49
gnucash/import-export/aqb/gnc-ab-utils.c
View File

@ -35,11 +35,7 @@
#include <gwenhywfar/gwenhywfar.h>
#include <aqbanking/banking.h>
#ifdef AQBANKING6
#include <aqbanking/types/balance.h>
#if (AQBANKING_VERSION_INT >= 60400)
#include <aqbanking/types/refaccount.h>
#include <gnc-aqbanking-templates.h>
#endif
# include <aqbanking/types/balance.h>
#endif
#include "window-reconcile.h"
#include "Transaction.h"
@ -1335,46 +1331,3 @@ gnc_ab_get_permanent_certs(void)
g_return_val_if_fail(rv >= 0, NULL);
return perm_certs;
}
#if (AQBANKING_VERSION_INT >= 60400)
GList*
gnc_ab_trans_templ_list_new_from_ref_accounts(GNC_AB_ACCOUNT_SPEC *ab_acc)
{
GList *retval = NULL;
AB_REFERENCE_ACCOUNT *ra;
AB_REFERENCE_ACCOUNT_LIST *ral;
GWEN_BUFFER *accNameForTemplate = GWEN_Buffer_new(0,120,0,0);
gnc_numeric zero = gnc_numeric_zero();
/* get the target account list */
ral = AB_AccountSpec_GetRefAccountList(ab_acc);
ra = AB_ReferenceAccount_List_First(ral);
/* fill the template list with the target accounts */
while (ra)
{
GncABTransTempl *new_templ = gnc_ab_trans_templ_new();
const char *iban = AB_ReferenceAccount_GetIban(ra);
const char *accName = AB_ReferenceAccount_GetAccountName(ra);
GWEN_Buffer_Reset(accNameForTemplate);
if (accName)
{
GWEN_Buffer_AppendString(accNameForTemplate, accName);
GWEN_Buffer_AppendString(accNameForTemplate, ": ");
}
GWEN_Buffer_AppendString(accNameForTemplate, iban);
gnc_ab_trans_templ_set_name(new_templ, GWEN_Buffer_GetStart(accNameForTemplate));
gnc_ab_trans_templ_set_recp_name(new_templ, AB_ReferenceAccount_GetOwnerName(ra));
gnc_ab_trans_templ_set_recp_account(new_templ, AB_ReferenceAccount_GetIban(ra));
gnc_ab_trans_templ_set_recp_bankcode(new_templ, AB_ReferenceAccount_GetBic(ra));
gnc_ab_trans_templ_set_amount(new_templ, zero);
retval = g_list_prepend (retval, new_templ);
ra = AB_ReferenceAccount_List_Next(ra);
}
retval = g_list_reverse (retval);
GWEN_Buffer_free(accNameForTemplate);
return retval;
}
#endif

12
gnucash/import-export/aqb/gnc-ab-utils.h
View File

@ -287,18 +287,6 @@ GWEN_DB_NODE *gnc_ab_get_permanent_certs(void);
*/
gchar* gnc_ab_create_online_id(const gchar *bankcode, const gchar *accountnumber);
#if (AQBANKING_VERSION_INT >= 60400)
/**
* Obtain the list of templates based on the aqbanking account spec's target accounts.
*
* @param ab_abb aqbanking account spec.
* @return A GList of newly allocated GncABTransTempls
*/
GList*
gnc_ab_trans_templ_list_new_from_ref_accounts(GNC_AB_ACCOUNT_SPEC *ab_acc);
#endif
G_END_DECLS
/** @} */

1
gnucash/import-export/aqb/gnc-plugin-aqbanking-ui.xml
View File

@ -21,7 +21,6 @@
<menuitem name="ABGetTrans" action="ABGetTransAction"/>
<separator name="OnlineActionsSep1"/>
<menuitem name="ABIssueSepaTrans" action="ABIssueSepaTransAction"/>
<menuitem name="ABIssueSepaIntTrans" action="ABIssueSepaIntTransAction"/>
<menuitem name="ABIssueIntTrans" action="ABIssueIntTransAction"/>
<!--menuitem name="ABIssueSepaDirectDebit" action="ABIssueSepaDirectDebitAction"/-->
<separator name="OnlineActionsSep2"/>

57
gnucash/import-export/aqb/gnc-plugin-aqbanking.c
View File

@ -72,7 +72,6 @@ static void gnc_plugin_ab_cmd_setup(GtkAction *action, GncMainWindowActionData *
static void gnc_plugin_ab_cmd_get_balance(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_get_transactions(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_issue_sepatransaction(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_issue_sepainternaltransaction(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_issue_inttransaction(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_issue_sepa_direct_debit(GtkAction *action, GncMainWindowActionData *data);
static void gnc_plugin_ab_cmd_view_logwindow(GtkToggleAction *action, GncMainWindow *window);
@ -115,12 +114,6 @@ static GtkActionEntry gnc_plugin_actions [] =
N_("Issue a new international European (SEPA) transaction online through Online Banking"),
G_CALLBACK(gnc_plugin_ab_cmd_issue_sepatransaction)
},
{
"ABIssueSepaIntTransAction", NULL,
N_("Issue SEPA I_nternal Transaction..."), NULL,
N_("Issue a new internal European (SEPA) transaction online through Online Banking"),
G_CALLBACK(gnc_plugin_ab_cmd_issue_sepainternaltransaction)
},
{
"ABIssueIntTransAction", NULL, N_("_Internal Transaction..."), NULL,
N_("Issue a new bank-internal transaction online through Online Banking"),
@ -186,22 +179,11 @@ static const gchar *need_account_actions[] =
"ABGetBalanceAction",
"ABGetTransAction",
"ABIssueSepaTransAction",
#if (AQBANKING_VERSION_INT >= 60400)
"ABIssueSepaIntTransAction",
#endif
"ABIssueIntTransAction",
"ABIssueSepaDirectDebitAction",
NULL
};
#if (AQBANKING_VERSION_INT < 60400)
static const gchar *inactive_account_actions[] =
{
"ABIssueSepaIntTransAction",
NULL
};
#endif
static const gchar *readonly_inactive_actions[] =
{
"OnlineActionsAction",
@ -397,12 +379,6 @@ gnc_plugin_ab_account_selected(GncPluginPage *plugin_page, Account *account,
&& accountid && *accountid));
gnc_plugin_update_actions(action_group, need_account_actions,
"visible", TRUE);
#if (AQBANKING_VERSION_INT < 60400)
gnc_plugin_update_actions(action_group, inactive_account_actions,
"sensitive", FALSE);
gnc_plugin_update_actions(action_group, inactive_account_actions,
"visible", FALSE);
#endif
}
else
{
@ -573,39 +549,6 @@ gnc_plugin_ab_cmd_issue_sepatransaction(GtkAction *action,
LEAVE(" ");
}
#if (AQBANKING_VERSION_INT >= 60400)
static void
gnc_plugin_ab_cmd_issue_sepainternaltransaction(GtkAction *action,
GncMainWindowActionData *data)
{
Account *account;
ENTER("action %p, main window data %p", action, data);
account = main_window_to_account(data->window);
if (account == NULL)
{
PINFO("No AqBanking account selected");
LEAVE("no account");
return;
}
gnc_main_window = data->window;
gnc_ab_maketrans(GTK_WIDGET(data->window), account, SEPA_INTERNAL_TRANSFER);
LEAVE(" ");
}
#else
static void
gnc_plugin_ab_cmd_issue_sepainternaltransaction(GtkAction *action,
GncMainWindowActionData *data)
{
ENTER("action %p, main window data %p", action, data);
PINFO("Sepa Internal Transfer not supported by your aqbanking version!");
LEAVE("Sepa Internal Transfer not supported!");
}
#endif
static void
gnc_plugin_ab_cmd_issue_inttransaction(GtkAction *action,
GncMainWindowActionData *data)

52
gnucash/import-export/aqb/gschemas/pref_transformations.xml
View File

@ -1,15 +1,3 @@
<!-- GSettings preference transformation rules
Refer to gnucash/gschemas/pref_transformations.xml for more information
about this file.
Note
====
Do not remove this file from the GnuCash sources even if there are
currently no active rules. Instead keep this introductory comment in
place and remove all other content.
-->
<release version="4007">
@ -74,43 +62,3 @@
new-key="last-geometry"/>
</release>
<release version="5000">
<obsolete old-path="org.gnucash.dialogs.flicker"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.ab-initial"
old-key="last-geometry"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="close-on-finish"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="remember-pin"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="use-ns-transaction-text"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="verbose-debug"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="format-dtaus"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="format-csv"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="format-swift-mt940"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="format-swift-mt942"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci"
old-key="last-path"/>
<obsolete old-path="org.gnucash.dialogs.import.hbci.connection-dialog"
old-key="last-geometry"/>
</release>

19
gnucash/import-export/ofx/gschemas/pref_transformations.xml
View File

@ -1,15 +1,3 @@
<!-- GSettings preference transformation rules
Refer to gnucash/gschemas/pref_transformations.xml for more information
about this file.
Note
====
Do not remove this file from the GnuCash sources even if there are
currently no active rules. Instead keep this introductory comment in
place and remove all other content.
-->
<release version="4007">
@ -18,10 +6,3 @@
new-path="org.gnucash.GnuCash.dialogs.import.ofx"
new-key="last-path"/>
</release>
<release version="5000">
<obsolete old-path="org.gnucash.dialogs.import.ofx"
old-key="last-path"/>
</release>

12
gnucash/import-export/qif-imp/CMakeLists.txt
View File

@ -91,6 +91,18 @@ gnc_add_scheme_targets(scm-qif-import
DEPENDS "${GUILE_DEPENDS};scm-qif-import-0"
MAKE_LINKS)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash import-export qif-import"
NEW_MODULE "gnucash qif-import"
DEPENDS "scm-qif-import-2"
MAKE_LINKS)
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash import-export string"
NEW_MODULE "gnucash string"
DEPENDS "scm-qif-import-0"
MAKE_LINKS)
set_local_dist(qif_import_DIST_local CMakeLists.txt file-format.txt ${qif_import_SOURCES} ${qif_import_noinst_HEADERS}
${qif_import_SCHEME_0} ${qif_import_SCHEME} ${qif_import_SCHEME_2})
set(qif_import_DIST ${qif_import_DIST_local} ${test_qif_import_DIST} PARENT_SCOPE)

28
gnucash/report/CMakeLists.txt
View File

@ -53,8 +53,12 @@ set (report_SCHEME_1
commodity-utilities.scm
html-acct-table.scm
html-chart.scm
html-barchart.scm
html-document.scm
html-fonts.scm
html-piechart.scm
html-scatter.scm
html-linechart.scm
html-style-info.scm
html-style-sheet.scm
html-anytag.scm
@ -112,6 +116,30 @@ gnc_add_scheme_targets(scm-report-eguile
OUTPUT_DIR "gnucash"
DEPENDS scm-report-eguile-parts)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report eguile-gnc"
NEW_MODULE "gnucash eguile"
DEPENDS "scm-report-eguile")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report eguile-html-utilities"
NEW_MODULE "gnucash eguile"
DEPENDS "scm-report-eguile")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report eguile-utilities"
NEW_MODULE "gnucash eguile"
DEPENDS "scm-report-eguile")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report report-system"
NEW_MODULE "gnucash report"
DEPENDS "scm-report-2")
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash report business-reports")
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash report report-system collectors")
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash report report-system report-collectors")
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash report stylesheets")
gnc_add_scheme_deprecated_module (OLD_MODULE "gnucash report utility-reports")
add_custom_target(scm-report ALL DEPENDS scm-report-2 scm-report-eguile)
set_local_dist(report_DIST_local CMakeLists.txt

57
gnucash/report/eguile-utilities.scm
View File

@ -41,6 +41,40 @@
(define-public fmtnumeric
(compose fmtnumber exact->inexact))
(define-public (gnc-monetary-neg? monetary)
;; return true if the monetary value is negative
(issue-deprecation-warning "gnc-monetary-neg? is deprecated")
(negative? (gnc:gnc-monetary-amount monetary)))
;; 'Safe' versions of cdr and cadr that don't crash
;; if the list is empty (is there a better way?)
(define-public safe-cdr
;; deprecate
(match-lambda
((_ . x) x)
(_ '())))
(define-public safe-cadr
;; deprecate
(match-lambda
((_ x . y) x)
(_ '())))
; deprecated - use find-stylesheet or find-template instead
(define-public (find-file fname)
;; Find the file 'fname', and return its full path.
;; First look in the user's .config/gnucash directory.
;; Then look in Gnucash's standard report directory.
;; If no file is found, returns just 'fname' for use in error messages.
(let* ((stylesheetpath (find-stylesheet fname))
(templatepath (find-template fname)))
; make sure there's a trailing delimiter
(issue-deprecation-warning "find-file is deprecated in 4.x. Please use find-stylesheet or find-template instead.")
(cond
((access? stylesheetpath R_OK) stylesheetpath)
((access? templatepath R_OK) templatepath)
(else fname))))
(define (find-internal ftype fname)
;; Find the file fname', and return its full path.
;; First look in the user's .config/gnucash directory.
@ -67,3 +101,26 @@
;; If no file is found, returns just 'fname' for use in error messages.
(find-internal "templates" fname))
;; Define syntax for more readable for loops (the built-in for-each
;; requires an explicit lambda and has the list expression all the way
;; at the end). Note: deprecated in 4.x, removal in 5.x. this syntax
;; is pythonic rather than lispy, is not recognized by code
;; highlighters, and is not necessary to seasoned schemers.
(export for)
(define-syntax for
(syntax-rules (for in do)
;; Multiple variables and equal number of lists (in
;; parenthesis). e.g.:
;; (for (a b) in (lsta lstb) do (display (+ a b)))
;; Note that this template must be defined before the
;; next one, since the template are evaluated in-order.
((for (<var> ...) in (<list> ...) do <expr> ...)
(begin
(issue-deprecation-warning "for loops are deprecated. use for-each instead.")
(for-each (lambda (<var> ...) <expr> ...) <list> ...)))
;; Single variable and list. e.g.: (for a in lst do (display a))
((for <var> in <list> do <expr> ...)
(begin
(issue-deprecation-warning "for loops are deprecated. use for-each instead.")
(for-each (lambda (<var>) <expr> ...) <list>)))))

49
gnucash/report/gnc-report.c
View File

@ -235,6 +235,55 @@ gnc_run_report_with_error_handling (gint report_id, gchar ** data, gchar **errms
}
}
static void
error_handler(const char *str)
{
g_warning("Failure running report: %s", str);
}
gboolean
gnc_run_report (gint report_id, char ** data)
{
SCM scm_text;
gchar *str;
PWARN ("gnc_run_report is deprecated. use gnc_run_report_with_error_handling instead.");
g_return_val_if_fail (data != NULL, FALSE);
*data = NULL;
str = g_strdup_printf("(gnc:report-run %d)", report_id);
scm_text = gfec_eval_string(str, error_handler);
g_free(str);
if (scm_text == SCM_UNDEFINED || !scm_is_string (scm_text))
return FALSE;
*data = gnc_scm_to_utf8_string (scm_text);
return TRUE;
}
gboolean
gnc_run_report_id_string (const char * id_string, char **data)
{
gint report_id;
PWARN ("gnc_run_report_id_string is deprecated. use gnc_run_report_id_string_with_error_handling instead.");
g_return_val_if_fail (id_string != NULL, FALSE);
g_return_val_if_fail (data != NULL, FALSE);
*data = NULL;
if (strncmp ("id=", id_string, 3) != 0)
return FALSE;
if (sscanf (id_string + 3, "%d", &report_id) != 1)
return FALSE;
return gnc_run_report (report_id, data);
}
gchar*
gnc_report_name( SCM report )
{

2
gnucash/report/gnc-report.h
View File

@ -38,9 +38,11 @@
void gnc_report_init (void);
gboolean gnc_run_report (gint report_id, char ** data);
gboolean gnc_run_report_with_error_handling (gint report_id,
gchar **data,
gchar **errmsg);
gboolean gnc_run_report_id_string (const char * id_string, char **data);
gboolean gnc_run_report_id_string_with_error_handling (const char * id_string,
char **data,
gchar **errmsg);

397
gnucash/report/html-barchart.scm Normal file
View File

@ -0,0 +1,397 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-barchart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-barchart))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-barchart>)
(export gnc:html-barchart? )
(export gnc:make-html-barchart-internal)
(export gnc:make-html-barchart)
(export gnc:html-barchart-data)
(export gnc:html-barchart-set-data!)
(export gnc:html-barchart-width)
(export gnc:html-barchart-set-width!)
(export gnc:html-barchart-height)
(export gnc:html-barchart-set-height!)
(export gnc:html-barchart-x-axis-label)
(export gnc:html-barchart-set-x-axis-label!)
(export gnc:html-barchart-y-axis-label)
(export gnc:html-barchart-set-y-axis-label!)
(export gnc:html-barchart-row-labels)
(export gnc:html-barchart-set-row-labels!)
(export gnc:html-barchart-row-labels-rotated?)
(export gnc:html-barchart-set-row-labels-rotated?!)
(export gnc:html-barchart-stacked?)
(export gnc:html-barchart-set-stacked?!)
(export gnc:html-barchart-col-labels)
(export gnc:html-barchart-set-col-labels!)
(export gnc:html-barchart-col-colors)
(export gnc:html-barchart-set-col-colors!)
(export gnc:html-barchart-legend-reversed?)
(export gnc:html-barchart-set-legend-reversed?!)
(export gnc:html-barchart-title)
(export gnc:html-barchart-set-title!)
(export gnc:html-barchart-subtitle)
(export gnc:html-barchart-set-subtitle!)
(export gnc:html-barchart-button-1-bar-urls)
(export gnc:html-barchart-set-button-1-bar-urls!)
(export gnc:html-barchart-button-2-bar-urls)
(export gnc:html-barchart-set-button-2-bar-urls!)
(export gnc:html-barchart-button-3-bar-urls)
(export gnc:html-barchart-set-button-3-bar-urls!)
(export gnc:html-barchart-button-1-legend-urls)
(export gnc:html-barchart-set-button-1-legend-urls!)
(export gnc:html-barchart-button-2-legend-urls)
(export gnc:html-barchart-set-button-2-legend-urls!)
(export gnc:html-barchart-button-3-legend-urls)
(export gnc:html-barchart-set-button-3-legend-urls!)
(export gnc:html-barchart-append-row!)
(export gnc:html-barchart-prepend-row!)
(export gnc:html-barchart-append-column!)
(export gnc:html-barchart-prepend-column!)
(export gnc:html-barchart-render barchart)
(define <html-barchart>
(make-record-type '<html-barchart>
'(width
height
title
subtitle
x-axis-label
y-axis-label
col-labels
row-labels
col-colors
legend-reversed?
row-labels-rotated?
stacked?
data
button-1-bar-urls
button-2-bar-urls
button-3-bar-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-barchart?
(record-predicate <html-barchart>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-barchart> class
;; generate the <object> form for a barchart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-barchart-internal
(record-constructor <html-barchart>))
(define (gnc:make-html-barchart)
(issue-deprecation-warning
"(gnc:make-html-barchart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-barchart-internal '(pixels . -1) '(pixels . -1) #f #f #f #f '() '() '()
#f #f #f '() #f #f #f #f #f #f))
(define gnc:html-barchart-data
(record-accessor <html-barchart> 'data))
(define gnc:html-barchart-set-data!
(record-modifier <html-barchart> 'data))
(define gnc:html-barchart-width
(record-accessor <html-barchart> 'width))
(define gnc:html-barchart-set-width!
(record-modifier <html-barchart> 'width))
(define gnc:html-barchart-height
(record-accessor <html-barchart> 'height))
(define gnc:html-barchart-set-height!
(record-modifier <html-barchart> 'height))
(define gnc:html-barchart-x-axis-label
(record-accessor <html-barchart> 'x-axis-label))
(define gnc:html-barchart-set-x-axis-label!
(record-modifier <html-barchart> 'x-axis-label))
(define gnc:html-barchart-y-axis-label
(record-accessor <html-barchart> 'y-axis-label))
(define gnc:html-barchart-set-y-axis-label!
(record-modifier <html-barchart> 'y-axis-label))
(define gnc:html-barchart-row-labels
(record-accessor <html-barchart> 'row-labels))
(define gnc:html-barchart-set-row-labels!
(record-modifier <html-barchart> 'row-labels))
(define gnc:html-barchart-row-labels-rotated?
(record-accessor <html-barchart> 'row-labels-rotated?))
(define gnc:html-barchart-set-row-labels-rotated?!
(record-modifier <html-barchart> 'row-labels-rotated?))
(define gnc:html-barchart-stacked?
(record-accessor <html-barchart> 'stacked?))
(define gnc:html-barchart-set-stacked?!
(record-modifier <html-barchart> 'stacked?))
(define gnc:html-barchart-col-labels
(record-accessor <html-barchart> 'col-labels))
(define gnc:html-barchart-set-col-labels!
(record-modifier <html-barchart> 'col-labels))
(define gnc:html-barchart-col-colors
(record-accessor <html-barchart> 'col-colors))
(define gnc:html-barchart-set-col-colors!
(record-modifier <html-barchart> 'col-colors))
(define gnc:html-barchart-legend-reversed?
(record-accessor <html-barchart> 'legend-reversed?))
(define gnc:html-barchart-set-legend-reversed?!
(record-modifier <html-barchart> 'legend-reversed?))
(define gnc:html-barchart-title
(record-accessor <html-barchart> 'title))
(define gnc:html-barchart-set-title!
(record-modifier <html-barchart> 'title))
(define gnc:html-barchart-subtitle
(record-accessor <html-barchart> 'subtitle))
(define gnc:html-barchart-set-subtitle!
(record-modifier <html-barchart> 'subtitle))
;; Note: ATM you can specify one url per column, but this url will be
;; used for all of the rows. Otherwise we could have cols*rows urls
;; (quite a lot), but this first requires fixing
;; guppi_bar_1_callback() in gnome/gnc-html-guppi.c .
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-barchart-button-1-bar-urls
(record-accessor <html-barchart> 'button-1-bar-urls))
(define gnc:html-barchart-set-button-1-bar-urls!
(record-modifier <html-barchart> 'button-1-bar-urls))
(define gnc:html-barchart-button-2-bar-urls
(record-accessor <html-barchart> 'button-2-bar-urls))
(define gnc:html-barchart-set-button-2-bar-urls!
(record-modifier <html-barchart> 'button-2-bar-urls))
(define gnc:html-barchart-button-3-bar-urls
(record-accessor <html-barchart> 'button-3-bar-urls))
(define gnc:html-barchart-set-button-3-bar-urls!
(record-modifier <html-barchart> 'button-3-bar-urls))
(define gnc:html-barchart-button-1-legend-urls
(record-accessor <html-barchart> 'button-1-legend-urls))
(define gnc:html-barchart-set-button-1-legend-urls!
(record-modifier <html-barchart> 'button-1-legend-urls))
(define gnc:html-barchart-button-2-legend-urls
(record-accessor <html-barchart> 'button-2-legend-urls))
(define gnc:html-barchart-set-button-2-legend-urls!
(record-modifier <html-barchart> 'button-2-legend-urls))
(define gnc:html-barchart-button-3-legend-urls
(record-accessor <html-barchart> 'button-3-legend-urls))
(define gnc:html-barchart-set-button-3-legend-urls!
(record-modifier <html-barchart> 'button-3-legend-urls))
(define (gnc:html-barchart-append-row! barchart newrow)
(let ((dd (gnc:html-barchart-data barchart)))
(set! dd (append dd (list newrow)))
(gnc:html-barchart-set-data! barchart dd)))
(define (gnc:html-barchart-prepend-row! barchart newrow)
(let ((dd (gnc:html-barchart-data barchart)))
(set! dd (cons newrow dd))
(gnc:html-barchart-set-data! barchart dd)))
(define (gnc:html-barchart-append-column! barchart newcol)
(let ((colnum 0)
(rownum 0)
(rows (gnc:html-barchart-data barchart))
(this-row #f)
(new-row #f))
;; find out how many cols are already there in the deepest row
(for-each
(lambda (row)
(let ((l (length row)))
(if (> l colnum)
(set! colnum l))))
rows)
;; append the elements of 'newrow' to the rowumns
(for-each
(lambda (newelt)
;; find the row, or append one
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
;; make sure the rowumn is long enough, then append the data
(let loop ((l (length this-row))
(r (reverse this-row)))
(if (< l colnum)
(loop (+ l 1) (cons #f r))
(set! this-row
(reverse (cons newelt r)))))
(if new-row
(gnc:html-barchart-append-row! barchart this-row)
(list-set! (gnc:html-barchart-data barchart) rownum this-row))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-barchart-prepend-column! barchart newcol)
(let ((rows (gnc:html-barchart-data barchart))
(this-row #f)
(new-row #f)
(rownum 0))
(for-each
(lambda (elt)
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(if new-row
(gnc:html-barchart-append-row! barchart (list elt))
(list-set! (gnc:html-barchart-data barchart) rownum
(cons elt this-row)))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-barchart-render barchart doc)
(let* ((chart (gnc:make-html-chart))
(data (gnc:html-barchart-data barchart)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'bar)
(gnc:html-chart-set-width! chart (gnc:html-barchart-width barchart))
(gnc:html-chart-set-height! chart (gnc:html-barchart-height barchart))
(gnc:html-chart-set-data-labels! chart (gnc:html-barchart-row-labels barchart))
(for-each
(lambda (label series color)
(gnc:html-chart-add-data-series! chart label series color))
(gnc:html-barchart-col-labels barchart)
data
(gnc:html-barchart-col-colors barchart))
(gnc:html-chart-set-title! chart (list
(gnc:html-barchart-title barchart)
(gnc:html-barchart-subtitle barchart)))
(gnc:html-chart-set-stacking?! chart (gnc:html-barchart-stacked? barchart))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering barchart")
""))))
(gnc:guard-html-chart gnc:html-barchart-data)
(gnc:guard-html-chart gnc:html-barchart-set-data!)
(gnc:guard-html-chart gnc:html-barchart-width)
(gnc:guard-html-chart gnc:html-barchart-set-width!)
(gnc:guard-html-chart gnc:html-barchart-height)
(gnc:guard-html-chart gnc:html-barchart-set-height!)
(gnc:guard-html-chart gnc:html-barchart-x-axis-label)
(gnc:guard-html-chart gnc:html-barchart-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-barchart-y-axis-label)
(gnc:guard-html-chart gnc:html-barchart-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-barchart-row-labels)
(gnc:guard-html-chart gnc:html-barchart-set-row-labels!)
(gnc:guard-html-chart gnc:html-barchart-row-labels-rotated?)
(gnc:guard-html-chart gnc:html-barchart-set-row-labels-rotated?!)
(gnc:guard-html-chart gnc:html-barchart-stacked?)
(gnc:guard-html-chart gnc:html-barchart-set-stacked?!)
(gnc:guard-html-chart gnc:html-barchart-col-labels)
(gnc:guard-html-chart gnc:html-barchart-set-col-labels!)
(gnc:guard-html-chart gnc:html-barchart-col-colors)
(gnc:guard-html-chart gnc:html-barchart-set-col-colors!)
(gnc:guard-html-chart gnc:html-barchart-legend-reversed?)
(gnc:guard-html-chart gnc:html-barchart-set-legend-reversed?!)
(gnc:guard-html-chart gnc:html-barchart-title)
(gnc:guard-html-chart gnc:html-barchart-set-title!)
(gnc:guard-html-chart gnc:html-barchart-subtitle)
(gnc:guard-html-chart gnc:html-barchart-set-subtitle!)
(gnc:guard-html-chart gnc:html-barchart-button-1-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-1-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-2-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-2-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-3-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-3-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-append-row!)
(gnc:guard-html-chart gnc:html-barchart-prepend-row!)
(gnc:guard-html-chart gnc:html-barchart-append-column!)
(gnc:guard-html-chart gnc:html-barchart-prepend-column!)
(gnc:guard-html-chart gnc:html-barchart-render)

16
gnucash/report/html-document.scm
View File

@ -25,7 +25,11 @@
(use-modules (gnucash html))
(use-modules (gnucash report html-anytag))
(use-modules (gnucash report html-barchart))
(use-modules (gnucash report html-chart))
(use-modules (gnucash report html-linechart))
(use-modules (gnucash report html-piechart))
(use-modules (gnucash report html-scatter))
(use-modules (gnucash report html-style-info))
(use-modules (gnucash report html-style-sheet))
(use-modules (gnucash report html-table))
@ -363,6 +367,18 @@
((gnc:html-table-cell? obj)
(gnc:make-html-object-internal gnc:html-table-cell-render obj))
((gnc:html-barchart? obj)
(gnc:make-html-object-internal gnc:html-barchart-render obj))
((gnc:html-piechart? obj)
(gnc:make-html-object-internal gnc:html-piechart-render obj))
((gnc:html-scatter? obj)
(gnc:make-html-object-internal gnc:html-scatter-render obj))
((gnc:html-linechart? obj)
(gnc:make-html-object-internal gnc:html-linechart-render obj))
((gnc:html-object? obj)
obj)

475
gnucash/report/html-linechart.scm Normal file
View File

@ -0,0 +1,475 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-linechart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2008 Sven Henkel <shenkel@gmail.com>
;;
;; Adapted from html-barchart.scm which is
;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-linechart))
(use-modules (srfi srfi-1))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-linechart>)
(export gnc:html-linechart? )
(export gnc:make-html-linechart-internal)
(export gnc:make-html-linechart)
(export gnc:html-linechart-data)
(export gnc:html-linechart-set-data!)
(export gnc:html-linechart-width)
(export gnc:html-linechart-set-width!)
(export gnc:html-linechart-height)
(export gnc:html-linechart-set-height!)
(export gnc:html-linechart-x-axis-label)
(export gnc:html-linechart-set-x-axis-label!)
(export gnc:html-linechart-y-axis-label)
(export gnc:html-linechart-set-y-axis-label!)
(export gnc:html-linechart-row-labels)
(export gnc:html-linechart-set-row-labels!)
(export gnc:html-linechart-row-labels-rotated?)
(export gnc:html-linechart-set-row-labels-rotated?!)
(export gnc:html-linechart-stacked?)
(export gnc:html-linechart-set-stacked?!)
(export gnc:html-linechart-markers?)
(export gnc:html-linechart-set-markers?!)
(export gnc:html-linechart-major-grid?)
(export gnc:html-linechart-set-major-grid?!)
(export gnc:html-linechart-minor-grid?)
(export gnc:html-linechart-set-minor-grid?!)
(export gnc:html-linechart-col-labels)
(export gnc:html-linechart-set-col-labels!)
(export gnc:html-linechart-col-colors)
(export gnc:html-linechart-set-col-colors!)
(export gnc:html-linechart-legend-reversed?)
(export gnc:html-linechart-set-legend-reversed?!)
(export gnc:html-linechart-title)
(export gnc:html-linechart-set-title!)
(export gnc:html-linechart-subtitle)
(export gnc:html-linechart-set-subtitle!)
(export gnc:html-linechart-button-1-line-urls)
(export gnc:html-linechart-set-button-1-line-urls!)
(export gnc:html-linechart-button-2-line-urls)
(export gnc:html-linechart-set-button-2-line-urls!)
(export gnc:html-linechart-button-3-line-urls)
(export gnc:html-linechart-set-button-3-line-urls!)
(export gnc:html-linechart-button-1-legend-urls)
(export gnc:html-linechart-set-button-1-legend-urls!)
(export gnc:html-linechart-button-2-legend-urls)
(export gnc:html-linechart-set-button-2-legend-urls!)
(export gnc:html-linechart-button-3-legend-urls)
(export gnc:html-linechart-set-button-3-legend-urls!)
(export gnc:html-linechart-append-row!)
(export gnc:html-linechart-prepend-row!)
(export gnc:html-linechart-append-column!)
(export gnc:html-linechart-prepend-column!)
(export gnc:html-linechart-render linechart)
(export gnc:html-linechart-set-line-width!)
(export gnc:html-linechart-line-width)
(define <html-linechart>
(make-record-type '<html-linechart>
'(width
height
title
subtitle
x-axis-label
y-axis-label
col-labels
row-labels
col-colors
legend-reversed?
row-labels-rotated?
stacked?
markers?
major-grid?
minor-grid?
data
button-1-line-urls
button-2-line-urls
button-3-line-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls
line-width)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-linechart?
(record-predicate <html-linechart>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-linechart> class
;; generate the <object> form for a linechart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-linechart-internal
(record-constructor <html-linechart>))
(define (gnc:make-html-linechart)
(issue-deprecation-warning
"(gnc:make-html-linechart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-linechart-internal
'(pixels . -1) ;;width
'(pixels . -1) ;;height
#f ;;title
#f ;;subtitle
#f ;;x-axis-label
#f ;;y-axis-label
'() ;;col-labels
'() ;;row-labels
'() ;;col-colors
#f ;;legend-reversed?
#f ;;row-labels-rotated?
#f ;;stacked?
#t ;;markers?
#t ;;major-grid?
#t ;;minor-grid?
'() ;;data
#f ;;button-1-line-urls
#f ;;button-2-line-urls
#f ;;button-3-line-urls
#f ;;button-1-legend-urls
#f ;;button-2-legend-urls
#f ;;button-3-legend-urls
1.5 ;;line-width
)
)
(define gnc:html-linechart-data
(record-accessor <html-linechart> 'data))
(define gnc:html-linechart-set-data!
(record-modifier <html-linechart> 'data))
(define gnc:html-linechart-width
(record-accessor <html-linechart> 'width))
(define gnc:html-linechart-set-width!
(record-modifier <html-linechart> 'width))
(define gnc:html-linechart-height
(record-accessor <html-linechart> 'height))
(define gnc:html-linechart-set-height!
(record-modifier <html-linechart> 'height))
(define gnc:html-linechart-x-axis-label
(record-accessor <html-linechart> 'x-axis-label))
(define gnc:html-linechart-set-x-axis-label!
(record-modifier <html-linechart> 'x-axis-label))
(define gnc:html-linechart-y-axis-label
(record-accessor <html-linechart> 'y-axis-label))
(define gnc:html-linechart-set-y-axis-label!
(record-modifier <html-linechart> 'y-axis-label))
(define gnc:html-linechart-row-labels
(record-accessor <html-linechart> 'row-labels))
(define gnc:html-linechart-set-row-labels!
(record-modifier <html-linechart> 'row-labels))
(define gnc:html-linechart-row-labels-rotated?
(record-accessor <html-linechart> 'row-labels-rotated?))
(define gnc:html-linechart-set-row-labels-rotated?!
(record-modifier <html-linechart> 'row-labels-rotated?))
(define gnc:html-linechart-stacked?
(record-accessor <html-linechart> 'stacked?))
(define gnc:html-linechart-set-stacked?!
(record-modifier <html-linechart> 'stacked?))
(define gnc:html-linechart-markers?
(record-accessor <html-linechart> 'markers?))
(define gnc:html-linechart-set-markers?!
(record-modifier <html-linechart> 'markers?))
(define gnc:html-linechart-major-grid?
(record-accessor <html-linechart> 'major-grid?))
(define gnc:html-linechart-set-major-grid?!
(record-modifier <html-linechart> 'major-grid?))
(define gnc:html-linechart-minor-grid?
(record-accessor <html-linechart> 'minor-grid?))
(define gnc:html-linechart-set-minor-grid?!
(record-modifier <html-linechart> 'minor-grid?))
(define gnc:html-linechart-col-labels
(record-accessor <html-linechart> 'col-labels))
(define gnc:html-linechart-set-col-labels!
(record-modifier <html-linechart> 'col-labels))
(define gnc:html-linechart-col-colors
(record-accessor <html-linechart> 'col-colors))
(define gnc:html-linechart-set-col-colors!
(record-modifier <html-linechart> 'col-colors))
(define gnc:html-linechart-legend-reversed?
(record-accessor <html-linechart> 'legend-reversed?))
(define gnc:html-linechart-set-legend-reversed?!
(record-modifier <html-linechart> 'legend-reversed?))
(define gnc:html-linechart-title
(record-accessor <html-linechart> 'title))
(define gnc:html-linechart-set-title!
(record-modifier <html-linechart> 'title))
(define gnc:html-linechart-subtitle
(record-accessor <html-linechart> 'subtitle))
(define gnc:html-linechart-set-subtitle!
(record-modifier <html-linechart> 'subtitle))
;; Note: ATM you can specify one url per column, but this url will be
;; used for all of the rows. Otherwise we could have cols*rows urls
;; (quite a lot), but this first requires fixing
;; guppi_line_1_callback() in gnome/gnc-html-guppi.c .
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-linechart-button-1-line-urls
(record-accessor <html-linechart> 'button-1-line-urls))
(define gnc:html-linechart-set-button-1-line-urls!
(record-modifier <html-linechart> 'button-1-line-urls))
(define gnc:html-linechart-button-2-line-urls
(record-accessor <html-linechart> 'button-2-line-urls))
(define gnc:html-linechart-set-button-2-line-urls!
(record-modifier <html-linechart> 'button-2-line-urls))
(define gnc:html-linechart-button-3-line-urls
(record-accessor <html-linechart> 'button-3-line-urls))
(define gnc:html-linechart-set-button-3-line-urls!
(record-modifier <html-linechart> 'button-3-line-urls))
(define gnc:html-linechart-button-1-legend-urls
(record-accessor <html-linechart> 'button-1-legend-urls))
(define gnc:html-linechart-set-button-1-legend-urls!
(record-modifier <html-linechart> 'button-1-legend-urls))
(define gnc:html-linechart-button-2-legend-urls
(record-accessor <html-linechart> 'button-2-legend-urls))
(define gnc:html-linechart-set-button-2-legend-urls!
(record-modifier <html-linechart> 'button-2-legend-urls))
(define gnc:html-linechart-button-3-legend-urls
(record-accessor <html-linechart> 'button-3-legend-urls))
(define gnc:html-linechart-set-button-3-legend-urls!
(record-modifier <html-linechart> 'button-3-legend-urls))
(define gnc:html-linechart-line-width
(record-accessor <html-linechart> 'line-width))
(define gnc:html-linechart-set-line-width!
(record-modifier <html-linechart> 'line-width))
(define (gnc:html-linechart-append-row! linechart newrow)
(let ((dd (gnc:html-linechart-data linechart)))
(set! dd (append dd (list newrow)))
(gnc:html-linechart-set-data! linechart dd)))
(define (gnc:html-linechart-prepend-row! linechart newrow)
(let ((dd (gnc:html-linechart-data linechart)))
(set! dd (cons newrow dd))
(gnc:html-linechart-set-data! linechart dd)))
(define (gnc:html-linechart-append-column! linechart newcol)
(let ((colnum 0)
(rownum 0)
(rows (gnc:html-linechart-data linechart))
(this-row #f)
(new-row #f))
;; find out how many cols are already there in the deepest row
(for-each
(lambda (row)
(let ((l (length row)))
(if (> l colnum)
(set! colnum l))))
rows)
;; append the elements of 'newrow' to the rowumns
(for-each
(lambda (newelt)
;; find the row, or append one
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
;; make sure the rowumn is long enough, then append the data
(let loop ((l (length this-row))
(r (reverse this-row)))
(if (< l colnum)
(loop (+ l 1) (cons #f r))
(set! this-row
(reverse (cons newelt r)))))
(if new-row
(gnc:html-linechart-append-row! linechart this-row)
(list-set! (gnc:html-linechart-data linechart) rownum this-row))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-linechart-prepend-column! linechart newcol)
(let ((rows (gnc:html-linechart-data linechart))
(this-row #f)
(new-row #f)
(rownum 0))
(for-each
(lambda (elt)
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(if new-row
(gnc:html-linechart-append-row! linechart (list elt))
(list-set! (gnc:html-linechart-data linechart) rownum
(cons elt this-row)))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-linechart-render linechart doc)
(let* ((chart (gnc:make-html-chart))
(data (gnc:html-linechart-data linechart))
(line-width (gnc:html-linechart-line-width linechart))
(radius (if (gnc:html-linechart-markers? linechart) 3 0)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'line)
(gnc:html-chart-set-width! chart (gnc:html-linechart-width linechart))
(gnc:html-chart-set-height! chart (gnc:html-linechart-height linechart))
(gnc:html-chart-set-data-labels! chart (gnc:html-linechart-row-labels linechart))
(for-each
(lambda (label series color)
(gnc:html-chart-add-data-series! chart label series color
'borderWidth line-width
'pointRadius radius
'fill #f))
(gnc:html-linechart-col-labels linechart)
(apply zip data)
(gnc:html-linechart-col-colors linechart))
(gnc:html-chart-set-title! chart (list
(gnc:html-linechart-title linechart)
(gnc:html-linechart-subtitle linechart)))
(gnc:html-chart-set-stacking?! chart (gnc:html-linechart-stacked? linechart))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering linechart")
""))))
(gnc:guard-html-chart gnc:html-linechart-data)
(gnc:guard-html-chart gnc:html-linechart-set-data!)
(gnc:guard-html-chart gnc:html-linechart-width)
(gnc:guard-html-chart gnc:html-linechart-set-width!)
(gnc:guard-html-chart gnc:html-linechart-height)
(gnc:guard-html-chart gnc:html-linechart-set-height!)
(gnc:guard-html-chart gnc:html-linechart-x-axis-label)
(gnc:guard-html-chart gnc:html-linechart-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-linechart-y-axis-label)
(gnc:guard-html-chart gnc:html-linechart-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-linechart-row-labels)
(gnc:guard-html-chart gnc:html-linechart-set-row-labels!)
(gnc:guard-html-chart gnc:html-linechart-row-labels-rotated?)
(gnc:guard-html-chart gnc:html-linechart-set-row-labels-rotated?!)
(gnc:guard-html-chart gnc:html-linechart-stacked?)
(gnc:guard-html-chart gnc:html-linechart-set-stacked?!)
(gnc:guard-html-chart gnc:html-linechart-markers?)
(gnc:guard-html-chart gnc:html-linechart-set-markers?!)
(gnc:guard-html-chart gnc:html-linechart-major-grid?)
(gnc:guard-html-chart gnc:html-linechart-set-major-grid?!)
(gnc:guard-html-chart gnc:html-linechart-minor-grid?)
(gnc:guard-html-chart gnc:html-linechart-set-minor-grid?!)
(gnc:guard-html-chart gnc:html-linechart-col-labels)
(gnc:guard-html-chart gnc:html-linechart-set-col-labels!)
(gnc:guard-html-chart gnc:html-linechart-col-colors)
(gnc:guard-html-chart gnc:html-linechart-set-col-colors!)
(gnc:guard-html-chart gnc:html-linechart-legend-reversed?)
(gnc:guard-html-chart gnc:html-linechart-set-legend-reversed?!)
(gnc:guard-html-chart gnc:html-linechart-title)
(gnc:guard-html-chart gnc:html-linechart-set-title!)
(gnc:guard-html-chart gnc:html-linechart-subtitle)
(gnc:guard-html-chart gnc:html-linechart-set-subtitle!)
(gnc:guard-html-chart gnc:html-linechart-button-1-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-1-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-2-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-2-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-3-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-3-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-append-row!)
(gnc:guard-html-chart gnc:html-linechart-prepend-row!)
(gnc:guard-html-chart gnc:html-linechart-append-column!)
(gnc:guard-html-chart gnc:html-linechart-prepend-column!)
(gnc:guard-html-chart gnc:html-linechart-render)
(gnc:guard-html-chart gnc:html-linechart-set-line-width!)
(gnc:guard-html-chart gnc:html-linechart-line-width)

239
gnucash/report/html-piechart.scm Normal file
View File

@ -0,0 +1,239 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-piechart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-piechart))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-piechart>)
(export gnc:html-piechart?)
(export gnc:make-html-piechart-internal)
(export gnc:make-html-piechart)
(export gnc:html-piechart-data)
(export gnc:html-piechart-set-data!)
(export gnc:html-piechart-width)
(export gnc:html-piechart-set-width!)
(export gnc:html-piechart-height)
(export gnc:html-piechart-set-height!)
(export gnc:html-piechart-labels)
(export gnc:html-piechart-set-labels!)
(export gnc:html-piechart-colors)
(export gnc:html-piechart-set-colors!)
(export gnc:html-piechart-title)
(export gnc:html-piechart-set-title!)
(export gnc:html-piechart-subtitle)
(export gnc:html-piechart-set-subtitle!)
(export gnc:html-piechart-button-1-slice-urls)
(export gnc:html-piechart-set-button-1-slice-urls!)
(export gnc:html-piechart-button-2-slice-urls)
(export gnc:html-piechart-set-button-2-slice-urls!)
(export gnc:html-piechart-button-3-slice-urls)
(export gnc:html-piechart-set-button-3-slice-urls!)
(export gnc:html-piechart-button-1-legend-urls)
(export gnc:html-piechart-set-button-1-legend-urls!)
(export gnc:html-piechart-button-2-legend-urls)
(export gnc:html-piechart-set-button-2-legend-urls!)
(export gnc:html-piechart-button-3-legend-urls)
(export gnc:html-piechart-set-button-3-legend-urls!)
(export gnc:html-piechart-render)
(define <html-piechart>
(make-record-type '<html-piechart>
'(width
height
title
subtitle
data
colors
labels
button-1-slice-urls
button-2-slice-urls
button-3-slice-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls)))
(define gnc:html-piechart?
(record-predicate <html-piechart>))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-piechart> class
;; generate the <object> form for a piechart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-piechart-internal
(record-constructor <html-piechart>))
(define (gnc:make-html-piechart)
(issue-deprecation-warning
"(gnc:make-html-piechart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-piechart-internal '(pixels . -1) '(pixels . -1) #f #f #f #f #f #f #f #f #f #f #f))
(define gnc:html-piechart-data
(record-accessor <html-piechart> 'data))
(define gnc:html-piechart-set-data!
(record-modifier <html-piechart> 'data))
(define gnc:html-piechart-width
(record-accessor <html-piechart> 'width))
(define gnc:html-piechart-set-width!
(record-modifier <html-piechart> 'width))
(define gnc:html-piechart-height
(record-accessor <html-piechart> 'height))
(define gnc:html-piechart-set-height!
(record-modifier <html-piechart> 'height))
(define gnc:html-piechart-labels
(record-accessor <html-piechart> 'labels))
(define gnc:html-piechart-set-labels!
(record-modifier <html-piechart> 'labels))
(define gnc:html-piechart-colors
(record-accessor <html-piechart> 'colors))
(define gnc:html-piechart-set-colors!
(record-modifier <html-piechart> 'colors))
(define gnc:html-piechart-title
(record-accessor <html-piechart> 'title))
(define gnc:html-piechart-set-title!
(record-modifier <html-piechart> 'title))
(define gnc:html-piechart-subtitle
(record-accessor <html-piechart> 'subtitle))
(define gnc:html-piechart-set-subtitle!
(record-modifier <html-piechart> 'subtitle))
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-piechart-button-1-slice-urls
(record-accessor <html-piechart> 'button-1-slice-urls))
(define gnc:html-piechart-set-button-1-slice-urls!
(record-modifier <html-piechart> 'button-1-slice-urls))
(define gnc:html-piechart-button-2-slice-urls
(record-accessor <html-piechart> 'button-2-slice-urls))
(define gnc:html-piechart-set-button-2-slice-urls!
(record-modifier <html-piechart> 'button-2-slice-urls))
(define gnc:html-piechart-button-3-slice-urls
(record-accessor <html-piechart> 'button-3-slice-urls))
(define gnc:html-piechart-set-button-3-slice-urls!
(record-modifier <html-piechart> 'button-3-slice-urls))
(define gnc:html-piechart-button-1-legend-urls
(record-accessor <html-piechart> 'button-1-legend-urls))
(define gnc:html-piechart-set-button-1-legend-urls!
(record-modifier <html-piechart> 'button-1-legend-urls))
(define gnc:html-piechart-button-2-legend-urls
(record-accessor <html-piechart> 'button-2-legend-urls))
(define gnc:html-piechart-set-button-2-legend-urls!
(record-modifier <html-piechart> 'button-2-legend-urls))
(define gnc:html-piechart-button-3-legend-urls
(record-accessor <html-piechart> 'button-3-legend-urls))
(define gnc:html-piechart-set-button-3-legend-urls!
(record-modifier <html-piechart> 'button-3-legend-urls))
(define (gnc:html-piechart-render piechart doc)
(let* ((chart (gnc:make-html-chart))
(title (gnc:html-piechart-title piechart))
(subtitle (gnc:html-piechart-subtitle piechart))
(data (gnc:html-piechart-data piechart))
(colors (gnc:html-piechart-colors piechart)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'pie)
(gnc:html-chart-set-axes-display! chart #f)
(gnc:html-chart-set-width! chart (gnc:html-piechart-width piechart))
(gnc:html-chart-set-height! chart (gnc:html-piechart-height piechart))
(gnc:html-chart-set-data-labels! chart (gnc:html-piechart-labels piechart))
(gnc:html-chart-add-data-series! chart "" data colors)
(gnc:html-chart-set-title! chart (list title subtitle))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering piechart")
""))))
(gnc:guard-html-chart gnc:html-piechart-data)
(gnc:guard-html-chart gnc:html-piechart-set-data!)
(gnc:guard-html-chart gnc:html-piechart-width)
(gnc:guard-html-chart gnc:html-piechart-set-width!)
(gnc:guard-html-chart gnc:html-piechart-height)
(gnc:guard-html-chart gnc:html-piechart-set-height!)
(gnc:guard-html-chart gnc:html-piechart-labels)
(gnc:guard-html-chart gnc:html-piechart-set-labels!)
(gnc:guard-html-chart gnc:html-piechart-colors)
(gnc:guard-html-chart gnc:html-piechart-set-colors!)
(gnc:guard-html-chart gnc:html-piechart-title)
(gnc:guard-html-chart gnc:html-piechart-set-title!)
(gnc:guard-html-chart gnc:html-piechart-subtitle)
(gnc:guard-html-chart gnc:html-piechart-set-subtitle!)
(gnc:guard-html-chart gnc:html-piechart-button-1-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-1-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-2-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-2-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-3-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-3-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-render)

227
gnucash/report/html-scatter.scm Normal file
View File

@ -0,0 +1,227 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-scatter.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2001 Christian Stimming <stimming@tuhh.de>
;;
;; Adapted from html-barchart.scm which is
;; Copyright 2000 Bill Gribble <grib@gnumatic.com>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-scatter))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-scatter>)
(export gnc:html-scatter-add-datapoint!)
(export gnc:html-scatter-data)
(export gnc:html-scatter-height)
(export gnc:html-scatter-marker)
(export gnc:html-scatter-markercolor)
(export gnc:html-scatter-render)
(export gnc:html-scatter-set-data!)
(export gnc:html-scatter-set-height!)
(export gnc:html-scatter-set-marker!)
(export gnc:html-scatter-set-markercolor!)
(export gnc:html-scatter-set-subtitle!)
(export gnc:html-scatter-set-title!)
(export gnc:html-scatter-set-width!)
(export gnc:html-scatter-set-x-axis-label!)
(export gnc:html-scatter-set-y-axis-label!)
(export gnc:html-scatter-subtitle)
(export gnc:html-scatter-title)
(export gnc:html-scatter-width)
(export gnc:html-scatter-x-axis-label)
(export gnc:html-scatter-y-axis-label)
(export gnc:html-scatter?)
(export gnc:make-html-scatter)
(export gnc:make-html-scatter-internal)
(define <html-scatter>
(make-record-type '<html-scatter>
'(width
height
title
subtitle
x-axis-label
y-axis-label
;; a list of x-y-value lists.
data
;; Valid marker names are:
;; diamond, circle, square, x, plus, dash,
;; filledDiamond, filledCircle, filledSquare
marker
;; The color of the markers outline. Should be a hex string,
;; as returned by gnc:color-option->hex-string, prefixed by
;; #, like "#ff0000" for red
markercolor
)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-scatter?
(record-predicate <html-scatter>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-scatter> class
;; generate the <object> form for a scatter plot.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-scatter-internal
(record-constructor <html-scatter>))
(define (gnc:make-html-scatter)
(issue-deprecation-warning
"(gnc:make-html-scatter) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-scatter-internal '(pixels . -1) '(pixels . -1) #f #f #f #f '() #f #f))
(define gnc:html-scatter-width
(record-accessor <html-scatter> 'width))
(define gnc:html-scatter-set-width!
(record-modifier <html-scatter> 'width))
(define gnc:html-scatter-height
(record-accessor <html-scatter> 'height))
(define gnc:html-scatter-set-height!
(record-modifier <html-scatter> 'height))
(define gnc:html-scatter-title
(record-accessor <html-scatter> 'title))
(define gnc:html-scatter-set-title!
(record-modifier <html-scatter> 'title))
(define gnc:html-scatter-subtitle
(record-accessor <html-scatter> 'subtitle))
(define gnc:html-scatter-set-subtitle!
(record-modifier <html-scatter> 'subtitle))
(define gnc:html-scatter-x-axis-label
(record-accessor <html-scatter> 'x-axis-label))
(define gnc:html-scatter-set-x-axis-label!
(record-modifier <html-scatter> 'x-axis-label))
(define gnc:html-scatter-y-axis-label
(record-accessor <html-scatter> 'y-axis-label))
(define gnc:html-scatter-set-y-axis-label!
(record-modifier <html-scatter> 'y-axis-label))
(define gnc:html-scatter-data
(record-accessor <html-scatter> 'data))
(define gnc:html-scatter-set-data!
(record-modifier <html-scatter> 'data))
(define gnc:html-scatter-marker
(record-accessor <html-scatter> 'marker))
(define gnc:html-scatter-set-marker!
(record-modifier <html-scatter> 'marker))
(define gnc:html-scatter-markercolor
(record-accessor <html-scatter> 'markercolor))
(define gnc:html-scatter-set-markercolor!
(record-modifier <html-scatter> 'markercolor))
(define (gnc:html-scatter-add-datapoint! scatter newpoint)
(if (and (list? newpoint)
(not (null? newpoint)))
(gnc:html-scatter-set-data!
scatter
(cons newpoint (gnc:html-scatter-data scatter)))))
;; The Renderer
(define (gnc:html-scatter-render scatter doc)
(let* ((chart (gnc:make-html-chart))
(mcolor (gnc:html-scatter-markercolor scatter))
(data (gnc:html-scatter-data scatter)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'scatter)
(gnc:html-chart-set-width! chart (gnc:html-scatter-width scatter))
(gnc:html-chart-set-height! chart (gnc:html-scatter-height scatter))
(gnc:html-chart-set-data-labels! chart (make-list (length data) #f))
(gnc:html-chart-add-data-series! chart "scatter"
(map
(lambda (datum)
(list
(cons 'x (car datum))
(cons 'y (cadr datum))))
data)
(make-list (length data) mcolor)
'showLine #t
'fill #f
'borderColor mcolor)
(gnc:html-chart-set-title! chart (list
(gnc:html-scatter-title scatter)
(gnc:html-scatter-subtitle scatter)))
(gnc:html-chart-set! chart
'(options elements point pointStyle)
(case (gnc:html-scatter-marker scatter)
((filleddiamond diamond) "rectRot")
((filledcircle circle) "circle")
((filledsquare square) "rect")
((cross) "crossRot")
((plus) "cross")
((dash) "line")
(else #f)))
(gnc:html-chart-set! chart '(options scales xAxes (0) type) "linear")
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering scatter")
""))))
(gnc:guard-html-chart gnc:html-scatter-width)
(gnc:guard-html-chart gnc:html-scatter-set-width!)
(gnc:guard-html-chart gnc:html-scatter-height)
(gnc:guard-html-chart gnc:html-scatter-set-height!)
(gnc:guard-html-chart gnc:html-scatter-title)
(gnc:guard-html-chart gnc:html-scatter-set-title!)
(gnc:guard-html-chart gnc:html-scatter-subtitle)
(gnc:guard-html-chart gnc:html-scatter-set-subtitle!)
(gnc:guard-html-chart gnc:html-scatter-x-axis-label)
(gnc:guard-html-chart gnc:html-scatter-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-scatter-y-axis-label)
(gnc:guard-html-chart gnc:html-scatter-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-scatter-data)
(gnc:guard-html-chart gnc:html-scatter-set-data!)
(gnc:guard-html-chart gnc:html-scatter-marker)
(gnc:guard-html-chart gnc:html-scatter-set-marker!)
(gnc:guard-html-chart gnc:html-scatter-markercolor)
(gnc:guard-html-chart gnc:html-scatter-set-markercolor!)
(gnc:guard-html-chart gnc:html-scatter-add-datapoint!)
(gnc:guard-html-chart gnc:html-scatter-render)

25
gnucash/report/html-table.scm
View File

@ -97,6 +97,7 @@
(export gnc:html-table-get-cell)
(export gnc:html-table-set-cell!)
(export gnc:html-table-set-cell/tag!)
(export gnc:html-table-append-column!)
(export gnc:html-table-render)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -411,6 +412,30 @@
(gnc:html-table-cell-set-tag! tc tag)
(gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
(define width (apply max (cons 0 (map length (gnc:html-table-data table)))))
(define (add-fn a b) (list-set-safe! b width a))
(issue-deprecation-warning "gnc:html-table-append-column! deprecated. please \
populate html-table row-wise using gnc:html-table-append-row! instead.")
(let lp ((newcol newcol)
(olddata (reverse (gnc:html-table-data table)))
(res '())
(numrows 0))
(cond
((null? newcol)
(gnc:html-table-set-num-rows-internal! table numrows)
(gnc:html-table-set-data! table res))
((null? olddata)
(lp (cdr newcol)
'()
(cons (add-fn (car newcol) '()) res)
(1+ numrows)))
(else
(lp (cdr newcol)
(cdr olddata)
(cons (add-fn (car newcol) (car olddata)) res)
(1+ numrows))))))
(define (gnc:html-table-render table doc)
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))))

27
gnucash/report/html-utilities.scm
View File

@ -247,6 +247,33 @@
table (list (gnc:make-html-table-cell/size
1 colspan (gnc:make-html-text (gnc:html-markup-hr))))))
;; Create a html-table of all exchange rates. The report-commodity is
;; 'common-commodity', the exchange rates are given through the
;; function 'exchange-fn' and the 'accounts' determine which
;; commodities to show. Returns a html-object, a <html-table>.
(define (gnc:html-make-exchangerates common-commodity exchange-fn accounts)
(issue-deprecation-warning
"gnc:html-make-exchangerates is deprecated. use gnc:html-make-rates-table instead.")
(let* ((comm-list (gnc:accounts-get-commodities accounts common-commodity))
(entries (length comm-list))
(markup (lambda (c) (gnc:make-html-table-cell/markup "number-cell" c)))
(table (gnc:make-html-table)))
(unless (= 0 entries)
(for-each
(lambda (commodity)
(let* ((orig-amt (gnc:make-gnc-monetary commodity 1))
(exchanged (exchange-fn orig-amt common-commodity))
(conv-amount (gnc:gnc-monetary-amount exchanged)))
(gnc:html-table-append-row!
table (list (markup orig-amt)
(markup (gnc:default-price-renderer common-commodity
conv-amount))))))
comm-list)
(gnc:html-table-set-col-headers!
table (list (gnc:make-html-table-header-cell/size
1 2 (NG_ "Exchange rate" "Exchange rates" entries)))))
table))
;; Create a html-table of all prices. The report-currency is
;; 'currency', The prices are given through the function 'price-fn'
;; and the 'accounts' determine which commodities to show. Returns a

30
gnucash/report/report-core.scm
View File

@ -79,6 +79,7 @@
(export gnc:report-options)
(export gnc:report-render-html)
(export gnc:render-report)
(export gnc:report-run)
(export gnc:report-serialize)
(export gnc:report-set-ctext!)
(export gnc:report-set-dirty?!)
@ -113,6 +114,7 @@
(export gnc:report-to-template-new)
(export gnc:report-to-template-update)
(export gnc:report-type)
(export gnc:restore-report-by-guid)
(export gnc:restore-report-by-guid-with-custom-template)
;; Terminology in this file:
@ -386,6 +388,20 @@ not found.")))
(gnc:report-set-id! r (gnc-report-add r))
(gnc:report-id r)))
(define (gnc:restore-report-by-guid id template-id template-name options)
(issue-deprecation-warning "gnc:restore-report-by-guid is now deprecated.
use gnc:restore-report-by-guid-with-custom-template instead.")
(if options
(let* ((r (make-report template-id id options #t #t #f #f ""))
(report-id (gnc-report-add r)))
(if (number? report-id)
(gnc:report-set-id! r report-id))
report-id)
(begin
(gui-error-missing-template template-name)
#f)))
(define (gnc:restore-report-by-guid-with-custom-template
id template-id template-name custom-template-id options)
(if options
@ -750,6 +766,20 @@ not found.")))
(define (get-report) (gnc:report-render-html report #t))
(gnc:apply-with-error-handling get-report '()))
;; looks up the report by id and renders it with gnc:report-render-html
;; marks the cursor busy during rendering; returns the html
(define (gnc:report-run id)
(issue-deprecation-warning "gnc:report-run is deprecated. use gnc:render-report instead.")
(let ((report (gnc-report-find id))
(html #f))
(gnc-set-busy-cursor '() #t)
(gnc:backtrace-if-exception
(lambda ()
(if report (set! html (gnc:report-render-html report #t)))))
(gnc-unset-busy-cursor '())
html))
;; "thunk" should take the report-type and the report template record
(define (gnc:report-templates-for-each thunk)
(hash-for-each

68
gnucash/report/report-utilities.scm
View File

@ -593,6 +593,39 @@
accounts)
collector))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Intended for usage with a profit and loss
;; report, hence a) only the income/expense accounts are regarded, and
;; b) the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-profit accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-profit deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Only the income accounts are regarded, and
;; the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-income accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-income deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-INCOME) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Only the expense accounts are regarded, and
;; the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-expense accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-expense deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-EXPENSE) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Intended for usage with a balance sheet, hence
@ -636,6 +669,41 @@
(define (gnc:accountlist-get-comm-balance-at-date-with-closing accountlist date)
(gnc:account-get-trans-type-balance-interval-with-closing accountlist #f #f date))
;; utility function - ensure that a query matches only non-voids. Destructive.
(define (gnc:query-set-match-non-voids-only! query book)
(issue-deprecation-warning
"gnc:query-set-match-non-voids-only! is deprecated. add query for\
(logand CLEARED-ALL (lognot CLEARED-VOIDED)) instead.")
(let ((temp-query (qof-query-create-for-splits)))
(qof-query-set-book temp-query book)
(xaccQueryAddClearedMatch
temp-query
CLEARED-VOIDED
QOF-QUERY-AND)
(let ((inv-query (qof-query-invert temp-query)))
(qof-query-merge-in-place query inv-query QOF-QUERY-AND)
(qof-query-destroy inv-query)
(qof-query-destroy temp-query))))
;; utility function - ensure that a query matches only voids. Destructive
(define (gnc:query-set-match-voids-only! query book)
(issue-deprecation-warning
"gnc:query-set-match-non-voids-only! is deprecated. add CLEARED-VOIDED \
query instead.")
(let ((temp-query (qof-query-create-for-splits)))
(qof-query-set-book temp-query book)
(xaccQueryAddClearedMatch
temp-query
CLEARED-VOIDED
QOF-QUERY-AND)
(qof-query-merge-in-place query temp-query QOF-QUERY-AND)
(qof-query-destroy temp-query)))
(define (gnc:split-voided? split)
(let ((trans (xaccSplitGetParent split)))
(xaccTransGetVoidStatus trans)))

198
gnucash/report/reports/CMakeLists.txt
View File

@ -4,6 +4,7 @@ add_subdirectory(support)
#These provide some functions used by more than one report.
set (reports_common_SCHEME
aging.scm #deprecated 4.x to be removed in 5.x
cash-flow-calc.scm
)
@ -12,7 +13,10 @@ set (reports_common_SCHEME
set (reports_standard_with_exposed_generator_SCHEME
standard/new-aging.scm
standard/register.scm
standard/owner-report.scm #deprecated 4.x to be removed in 5.x
standard/new-owner-report.scm
standard/payables.scm #deprecated 4.x to be removed in 5.x
standard/receivables.scm #deprecated 4.x to be removed in 5.x
)
set (reports_standard_SCHEME
@ -48,6 +52,7 @@ set (reports_standard_SCHEME
standard/taxinvoice.scm
standard/receipt.scm
standard/invoice.scm
standard/job-report.scm
standard/balsheet-eg.scm
)
@ -165,6 +170,199 @@ add_custom_target(scm-reports ALL DEPENDS
scm-reports-us
scm-reports-de_DE)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports"
NEW_MODULE "gnucash reports"
DEPENDS "scm-rpt-reports")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report aging"
NEW_MODULE "gnucash reports aging"
DEPENDS "scm-reports-common")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports average-balance"
NEW_MODULE "gnucash reports example average-balance"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports daily-reports"
NEW_MODULE "gnucash reports example daily-reports"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report hello-world"
NEW_MODULE "gnucash reports example hello-world"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report test-graphing"
NEW_MODULE "gnucash reports example sample-graphs"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report locale-specific de_DE"
NEW_MODULE "gnucash reports locale-specific de_DE taxtxf"
DEPENDS "scm-reports-de_DE")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxtxf-de_DE"
NEW_MODULE "gnucash reports locale-specific de_DE taxtxf"
DEPENDS "scm-reports-de_DE")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report locale-specific us"
NEW_MODULE "gnucash reports locale-specific us taxtxf"
DEPENDS "scm-reports-us")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxtxf"
NEW_MODULE "gnucash reports locale-specific us taxtxf"
DEPENDS "scm-reports-us")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports account-piecharts"
NEW_MODULE "gnucash reports standard account-piecharts"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports account-summary"
NEW_MODULE "gnucash reports standard account-summary"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports advanced-portfolio"
NEW_MODULE "gnucash reports standard advanced-portfolio"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balance-forecast"
NEW_MODULE "gnucash reports standard balance-forecast"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balance-sheet"
NEW_MODULE "gnucash reports standard balance-sheet"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report balsheet-eg"
NEW_MODULE "gnucash reports standard balsheet-eg"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balsheet-pnl"
NEW_MODULE "gnucash reports standard balsheet-pnl"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-balance-sheet"
NEW_MODULE "gnucash reports standard budget-balance-sheet"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-barchart"
NEW_MODULE "gnucash reports standard budget-barchart"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-flow"
NEW_MODULE "gnucash reports standard budget-flow"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget"
NEW_MODULE "gnucash reports standard budget"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-income-statement"
NEW_MODULE "gnucash reports standard budget-income-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports cashflow-barchart"
NEW_MODULE "gnucash reports standard cashflow-barchart"
DEPENDS "scm-reports-standard-2")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports cash-flow"
NEW_MODULE "gnucash reports standard cash-flow"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports category-barchart"
NEW_MODULE "gnucash reports standard category-barchart"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report customer-summary"
NEW_MODULE "gnucash reports standard customer-summary"
DEPENDS "scm-reports-standard-2")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report welcome-to-gnucash"
NEW_MODULE "gnucash reports standard dashboard"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports equity-statement"
NEW_MODULE "gnucash reports standard equity-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports general-journal"
NEW_MODULE "gnucash reports standard general-journal"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports general-ledger"
NEW_MODULE "gnucash reports standard general-ledger"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports income-gst-statement"
NEW_MODULE "gnucash reports standard income-gst-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports income-statement"
NEW_MODULE "gnucash reports standard income-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report invoice"
NEW_MODULE "gnucash reports standard invoice"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report job-report"
NEW_MODULE "gnucash reports standard job-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports net-charts"
NEW_MODULE "gnucash reports standard net-charts"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report owner-report"
NEW_MODULE "gnucash reports standard owner-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report payables"
NEW_MODULE "gnucash reports standard payables"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports portfolio"
NEW_MODULE "gnucash reports standard portfolio"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports price-scatter"
NEW_MODULE "gnucash reports standard price-scatter"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report receipt"
NEW_MODULE "gnucash reports standard receipt"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report receivables"
NEW_MODULE "gnucash reports standard receivables"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports reconcile-report"
NEW_MODULE "gnucash reports standard reconcile-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports register"
NEW_MODULE "gnucash reports standard register"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports sx-summary"
NEW_MODULE "gnucash reports standard account-summary"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxinvoice"
NEW_MODULE "gnucash reports standard taxinvoice"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports transaction"
NEW_MODULE "gnucash reports standard transaction"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports trial-balance"
NEW_MODULE "gnucash reports standard trial-balance"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report view-column"
NEW_MODULE "gnucash reports standard view-column"
DEPENDS "scm-reports-standard")
set_local_dist(reports_DIST_local CMakeLists.txt ${reports_SCHEME}
${reports_common_SCHEME} ${reports_standard_SCHEME} ${reports_standard_SCHEME_2}

847
gnucash/report/reports/aging.scm Normal file
View File

@ -0,0 +1,847 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; aging.scm : accounts payable/receivable aging report utilities
;;
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
;; By Robert Merkel (rgmerk@mira.net)
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports aging))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash gnome-utils))
(use-modules (srfi srfi-9))
(define optname-to-date (N_ "To"))
(define optname-sort-by (N_ "Sort By"))
(define optname-sort-order (N_ "Sort Order"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price Source"))
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals"))
(define optname-show-zeros (N_ "Show zero balance items"))
(define optname-date-driver (N_ "Due or Post Date"))
;; Display tab options
(define optname-addr-source (N_ "Address Source")) ;; Billing or Shipping addresses
(define optname-disp-addr-name (N_ "Address Name"))
(define optname-disp-addr1 (N_ "Address 1"))
(define optname-disp-addr2 (N_ "Address 2"))
(define optname-disp-addr3 (N_ "Address 3"))
(define optname-disp-addr4 (N_ "Address 4"))
(define optname-disp-addr-phone (N_ "Address Phone"))
(define optname-disp-addr-fax (N_ "Address Fax"))
(define optname-disp-addr-email (N_ "Address Email"))
(define optname-disp-active (N_ "Active"))
(export optname-show-zeros)
;; The idea is: have a hash with the key being the contact name
;; (In future this might be GUID'ed, but for now it's a string
;; from the description or the split memo.
;; The value is a record which contains the currency that contact
;; is stored in (you can only owe a particular contact one
;; currency, it just gets far too difficult otherwise), and a list
;; of buckets containing the money owed for each interval,
;; oldest first.
;; overpayment is just that - it stores the current overpayment,
;; if any. Any bills get taken out of the overpayment before
;; incurring debt.
(define-record-type :company-info
(make-company-private currency bucket overpayment owner-obj)
company-info?
(currency company-get-currency)
(bucket company-get-buckets company-set-buckets)
(overpayment company-get-overpayment company-set-overpayment)
(owner-obj company-get-owner-obj company-set-owner-obj!))
(define num-buckets 5)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-company currency owner-obj)
(make-company-private currency (new-bucket-vector) 0 owner-obj))
;; Put an invoice in the appropriate bucket
(define (process-invoice company amount bucket-intervals date)
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(gnc:debug "looking for bucket for date: " date)
(begin
(gnc:debug "current bucket: " current-bucket)
(gnc:debug "bucket-intervals: " bucket-intervals)
(if (> current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
(begin
(gnc:debug "found bucket")
current-bucket)
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (calculate-adjusted-values amount overpayment)
(if (>= (gnc-numeric-compare amount overpayment) 0)
(cons (gnc-numeric-sub-fixed amount overpayment)
(gnc-numeric-zero))
(cons (gnc-numeric-zero)
(gnc-numeric-sub-fixed overpayment amount))))
(let* ((current-overpayment (company-get-overpayment company))
(adjusted-values (calculate-adjusted-values amount current-overpayment))
(adjusted-amount (car adjusted-values))
(adjusted-overpayment (cdr adjusted-values))
(bucket-index (find-bucket 0 bucket-intervals date))
(buckets (company-get-buckets company))
(new-bucket-value
(gnc-numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-bucket-value)
(company-set-buckets company buckets)
(company-set-overpayment company adjusted-overpayment)))
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
;; any payment to a company goes towards the *oldest* bill first
(define (process-payment company amount)
(define (process-payment-driver amount buckets current-bucket-index)
(if (>= current-bucket-index (vector-length buckets))
amount
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
(if (>= (gnc-numeric-compare current-bucket-amt amount) 0)
(begin
(vector-set! buckets current-bucket-index (gnc-numeric-sub-fixed
current-bucket-amt amount))
(gnc-numeric-zero))
(begin
(vector-set! buckets current-bucket-index (gnc-numeric-zero))
(process-payment-driver
(gnc-numeric-sub-fixed amount current-bucket-amt)
buckets
(+ current-bucket-index 1)))))))
(let ((overpayment (company-get-overpayment company)))
;; if there's already an overpayment, make it bigger
(gnc:debug "processing payment of " amount)
(gnc:debug "overpayment was " overpayment)
(if (gnc-numeric-positive-p overpayment)
(company-set-overpayment company (gnc-numeric-add-fixed overpayment amount))
(let ((result (process-payment-driver amount (company-get-buckets company) 0)))
(gnc:debug "payment-driver processed. new overpayment: " result)
(company-set-overpayment company result)))))
;; determine date function to use
(define (get-selected-date-from-txn transaction date-type)
(if (eq? date-type 'postdate)
(xaccTransGetDate transaction)
(xaccTransRetDateDue transaction)))
;; deal with a transaction - figure out if we've seen the company before
;; if so, either process it as a bill or a payment, if not, create
;; a new company record in the hash
(define (update-company-hash hash split bucket-intervals
reverse? show-zeros date-type)
(define (do-update value)
(let* ((transaction (xaccSplitGetParent split))
(temp-owner (gncOwnerNew))
(owner (gnc:owner-from-split split temp-owner)))
(if (not (null? owner))
(let* ((guid (gncOwnerReturnGUID owner))
(this-currency (xaccTransGetCurrency transaction))
(this-date (get-selected-date-from-txn transaction date-type))
(company-info (hash-ref hash guid)))
(gnc:debug "update-company-hash called")
(gnc:debug "owner: " owner ", guid: " guid)
(gnc:debug "split-value: " value)
(if reverse? (set! value (gnc-numeric-neg value)))
(if company-info
;; if it's an existing company, destroy the temp owner and
;; then make sure the currencies match
(begin
(if (not (gnc-commodity-equiv
this-currency
(company-get-currency company-info)))
(let ((error-str
(string-append "IGNORING TRANSACTION!\n" "Invoice Owner: " (gnc:strify owner)
"\nTransaction:" (gnc:strify transaction)
"\nSplits are:\n"
(string-join
(map gnc:strify (xaccTransGetSplitList transaction))
"\n")
"\nTransaction Currency:" (gnc:strify this-currency)
"\nClient Currency:" (gnc:strify (company-get-currency company-info)))))
(gnc-error-dialog '() error-str)
(gnc:error error-str)
(cons #f (format #f (G_ "Transactions relating to '~a' contain \
more than one currency. This report is not designed to cope with this possibility.") (gncOwnerGetName owner))))
(begin
(gnc:debug "it's an old company")
(if (gnc-numeric-negative-p value)
(process-invoice company-info (gnc-numeric-neg value) bucket-intervals this-date)
(process-payment company-info value))
(hash-set! hash guid company-info)
(cons #t guid)))
(gncOwnerFree temp-owner))
;; if it's a new company
(begin
(gnc:debug "value" value)
(let ((new-company (make-company this-currency owner)))
(if (gnc-numeric-negative-p value)
(process-invoice new-company (gnc-numeric-neg value) bucket-intervals this-date)
(process-payment new-company value))
(hash-set! hash guid new-company))
(cons #t guid))))
; else (no owner)
(gncOwnerFree temp-owner))))
;; figure out if this split is part of a closed lot
;; also save the split value...
(let* ((lot (xaccSplitGetLot split))
(value (xaccSplitGetValue split))
(is-paid? (if (null? lot) #f (gnc-lot-is-closed lot))))
;; if it's closed, then ignore it because it doesn't matter.
;; XXX: we _could_ just set the value to 0 in order to list
;; the company. I'm not sure what to do. Perhaps add an
;; option?
(if (or (not is-paid?) show-zeros)
(do-update value))))
;; get the total debt from the buckets
(define (buckets-get-total buckets)
(let ((running-total (gnc-numeric-zero))
(buckets-list (vector->list buckets)))
(for-each (lambda (bucket)
(set! running-total
(gnc-numeric-add-fixed bucket running-total)))
buckets-list)
running-total))
;; compare by the total in the buckets
(define (safe-strcmp a b)
(if (and a b)
(cond
((string<? a b) -1)
((string>? a b) 1)
(else 0))
(cond
(a 1)
(b -1)
(else 0))))
(define (compare-total litem-a litem-b)
(let* ((company-a (cdr litem-a))
(bucket-a (company-get-buckets company-a))
(company-b (cdr litem-b))
(bucket-b (company-get-buckets company-b))
(total-a (buckets-get-total bucket-a))
(total-b (buckets-get-total bucket-b))
(difference-sign (gnc-numeric-compare (gnc-numeric-sub-fixed total-a total-b) (gnc-numeric-zero))))
;; if same totals, compare by name
(if (= difference-sign 0)
(safe-strcmp (car litem-a) (car litem-b))
difference-sign)))
;; compare by buckets, oldest first.
(define (compare-buckets litem-a litem-b)
(define (driver buckets-a buckets-b)
(if (null? buckets-a)
0
(let ((diff (gnc-numeric-compare
(gnc-numeric-sub-fixed
(car buckets-a)
(car buckets-b))
(gnc-numeric-zero))))
(if (= diff 0)
(driver (cdr buckets-a) (cdr buckets-b))
diff))))
(let* ((company-a (cdr litem-a))
(bucket-a (vector->list (company-get-buckets company-a)))
(company-b (cdr litem-b))
(bucket-b (vector->list (company-get-buckets company-b)))
(difference (driver bucket-a bucket-b)))
;; if same totals, compare by name
(if (= difference 0)
(safe-strcmp (car litem-a) (car litem-b))
difference)))
;; set up the query to get the splits in the chosen account
(define (setup-query query account date)
(qof-query-set-book query (gnc-get-current-book))
(xaccQueryAddClearedMatch
query (logand CLEARED-ALL (lognot CLEARED-VOIDED)) QOF-QUERY-AND)
(xaccQueryAddSingleAccountMatch query account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT query #f 0 #t date QOF-QUERY-AND)
(qof-query-set-sort-order query
(list SPLIT-TRANS TRANS-DATE-POSTED)
'() '())
(qof-query-set-sort-increasing query #t #t #t))
(define (aging-options-generator options)
(let* ((add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(gnc:options-add-report-date!
options gnc:pagename-general
optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-value (gnc:lookup-option options
gnc:pagename-general
optname-to-date)
(cons 'relative 'today))
;; all about currencies
(gnc:options-add-currency!
options gnc:pagename-general
optname-report-currency "b")
(gnc:options-add-price-source!
options gnc:pagename-general
optname-price-source "c" 'weighted-average)
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-sort-by
"i"
(N_ "Sort companies by.")
'name
(list
(vector 'name (N_ "Name of the company"))
(vector 'total (N_ "Total amount owed to/from Company"))
(vector 'oldest-bracket (N_ "Bracket Total Owed")))))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-sort-order
"ia"
(N_ "Sort order.")
'increasing
(list
(vector 'increasing (N_ "Ascending"))
(vector 'decreasing (N_ "Descending")))))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general
optname-multicurrency-totals
"i"
(N_ "Show multi-currency totals. If not selected, convert all \
totals to report currency.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general
optname-show-zeros
"j"
(N_ "Show all vendors/customers even if they have a zero balance.")
#f))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-date-driver
"k"
(N_ "Leading date.")
'duedate
(list
(vector 'duedate (N_ "Due Date"))
(vector 'postdate (N_ "Post Date")))))
;; display tab options
;; option optname-addr-source is added in receivables.scm
;; as cannot access the value of an option in aging-options-generator
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-name
"b"
(N_ "Display Address Name. This, and other fields, may be useful if \
copying this report to a spreadsheet for use in a mail merge.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr1
"c"
(N_ "Display Address 1.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr2
"d"
(N_ "Display Address 2.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr3
"e"
(N_ "Display Address 3.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr4
"f"
(N_ "Display Address 4.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-phone
"g"
(N_ "Display Phone.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-fax
"h"
(N_ "Display Fax.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-email
"i"
(N_ "Display Email.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-active
"j"
(N_ "Display Active status.")
#f))
(gnc:options-set-default-section options "General")
options))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
;; Have make-list create a stepped list, then add a date in the future for the "current" bucket
(define (make-extended-interval-list to-date)
(define dayforcurrent (incdate to-date YearDelta)) ;; MAGIC CONSTANT
(define oldintervalreversed (reverse (make-interval-list to-date)))
(reverse (cons dayforcurrent oldintervalreversed)))
(define (aging-renderer report-obj reportname account reverse?)
(define receivable #t) ;; receivable=#t payable=#f
(define (get-name a)
(let* ((owner (company-get-owner-obj (cdr a))))
(gncOwnerGetName owner)))
;; Predicates for sorting the companys once the data has been collected
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
(define sort-preds
(list
(cons 'name (cons (lambda (a b)
(string<? (get-name a) (get-name b)))
(lambda (a b)
(string>? (get-name a) (get-name b)))))
(cons 'total (cons (lambda (a b)
(< (compare-total a b) 0))
(lambda (a b)
(> (compare-total a b) 0))))
(cons 'oldest-bracket (cons
(lambda (a b)
(< (compare-buckets a b) 0))
(lambda (a b)
(> (compare-buckets a b) 0))))))
(define (get-sort-pred sort-criterion sort-order)
(let ((choice (assq-ref sort-preds sort-criterion)))
(gnc:debug "sort-criterion" sort-criterion)
(gnc:debug "sort-order" sort-order)
(gnc:debug "choice: " choice)
(if choice
(if (eq? sort-order 'increasing)
(car choice)
(cdr choice))
(begin
(gnc:warn "internal sorting option errorin aging.scm")
(lambda (a b)
(string<? (car a) (car b)))))))
(define (get-op section name)
(gnc:lookup-option (gnc:report-options report-obj) section name))
(define (op-value section name)
(gnc:option-value (get-op section name)))
;; XXX: This is a hack - will be fixed when we move to a
;; more general interval scheme in this report
(define make-heading-list
(list
(G_ "Company")
(G_ "Current")
(G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")
(G_ "Total")))
;; following cols are optional
;; (G_ "Address Name")
;; (G_ "Address 1")
;; (G_ "Address 2")
;; (G_ "Address 3")
;; (G_ "Address 4")
;; (G_ "Phone")
;; (G_ "Fax")
;; (G_ "Email")
;; (G_ "Active")
;; Make a list of commodity collectors for column totals
(define (make-collector-list)
(define (make-collector-driver done total)
(if (< done total)
(cons
(gnc:make-commodity-collector)
(make-collector-driver (+ done 1) total))
'()))
(make-collector-driver 0 (+ num-buckets 1)))
;; update the column totals
(define (add-to-column-totals column-totals monetary-list)
(begin
(gnc:debug "column-totals" column-totals)
(gnc:debug "monetary-list" monetary-list)
(map (lambda (amount collector)
(begin
(gnc:debug "amount" amount)
(gnc:debug "collector" collector)
(collector 'add
(gnc:gnc-monetary-commodity amount)
(gnc:gnc-monetary-amount amount))))
monetary-list
column-totals)))
;; convert the buckets in the header data structure
(define (convert-to-monetary-list bucket-list currency overpayment)
(let* ((running-total (gnc-numeric-neg overpayment))
(monetised-buckets
(map (lambda (bucket-list-entry)
(begin
(set! running-total
(gnc-numeric-add-fixed running-total bucket-list-entry))
(gnc:make-gnc-monetary currency bucket-list-entry)))
(vector->list bucket-list))))
(append (reverse monetised-buckets)
(list (gnc:make-gnc-monetary currency running-total)))))
;; convert the collectors to the right output format
(define (convert-collectors collector-list report-currency
exchange-fn
multi-currencies-p)
(define (fmt-one-currency collector)
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
(if monetary
monetary
(begin
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
#f))))
(define (fmt-multiple-currencies collector)
(let ((mini-table (gnc:make-html-table)))
(collector 'format
(lambda (commodity amount)
(gnc:html-table-append-row!
mini-table
(list (gnc:make-gnc-monetary
commodity amount))))
#f)
mini-table))
(let ((fmt-function
(if multi-currencies-p
fmt-multiple-currencies
fmt-one-currency)))
(map fmt-function collector-list)))
;; return pointer to either billing or shipping address
;; note customers have a shipping address but not vendors
(define (get-addr owner disp-addr-source)
(if (and receivable (eq? disp-addr-source 'shipping))
(gncCustomerGetShipAddr (gncOwnerGetCustomer owner)) ;; shipping
(gncOwnerGetAddr owner))) ;; billing
(issue-deprecation-warning
"old aging reports are deprecated and will be removed in 5.x")
(set! receivable (eq? (op-value "__hidden" "receivable-or-payable") 'R))
(gnc:report-starting reportname)
(let* ((companys (make-hash-table 23))
(report-title (op-value gnc:pagename-general gnc:optname-reportname))
;; document will be the HTML document that we return.
(report-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general optname-to-date))))
(interval-vec (list->vector (make-extended-interval-list report-date)))
(sort-pred (get-sort-pred
(op-value gnc:pagename-general optname-sort-by)
(op-value gnc:pagename-general optname-sort-order)))
(report-currency (op-value gnc:pagename-general optname-report-currency))
(price-source (op-value gnc:pagename-general optname-price-source))
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
(show-zeros (op-value gnc:pagename-general optname-show-zeros))
(date-type (op-value gnc:pagename-general optname-date-driver))
(disp-addr-source (if receivable
(op-value gnc:pagename-display optname-addr-source)
'billing))
(disp-addr-name (op-value gnc:pagename-display optname-disp-addr-name))
(disp-addr1 (op-value gnc:pagename-display optname-disp-addr1))
(disp-addr2 (op-value gnc:pagename-display optname-disp-addr2))
(disp-addr3 (op-value gnc:pagename-display optname-disp-addr3))
(disp-addr4 (op-value gnc:pagename-display optname-disp-addr4))
(disp-addr-phone (op-value gnc:pagename-display optname-disp-addr-phone))
(disp-addr-fax (op-value gnc:pagename-display optname-disp-addr-fax))
(disp-addr-email (op-value gnc:pagename-display optname-disp-addr-email))
(disp-active (op-value gnc:pagename-display optname-disp-active))
(heading-list make-heading-list)
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
(total-collector-list (make-collector-list))
(table (gnc:make-html-table))
(query (qof-query-create-for-splits))
(company-list '())
(work-done 0)
(work-to-do 0)
(document (gnc:make-html-document)))
; (gnc:debug "Account: " account)
;; add optional column headings
(if disp-addr-name
(set! heading-list (append heading-list (list (G_ "Address Name")))))
(if disp-addr1
(set! heading-list (append heading-list (list (G_ "Address 1")))))
(if disp-addr2
(set! heading-list (append heading-list (list (G_ "Address 2")))))
(if disp-addr3
(set! heading-list (append heading-list (list (G_ "Address 3")))))
(if disp-addr4
(set! heading-list (append heading-list (list (G_ "Address 4")))))
(if disp-addr-phone
(set! heading-list (append heading-list (list (G_ "Phone")))))
(if disp-addr-fax
(set! heading-list (append heading-list (list (G_ "Fax")))))
(if disp-addr-email
(set! heading-list (append heading-list (list (G_ "Email")))))
(if disp-active
(set! heading-list (append heading-list (list (G_ "Active")))))
;; set default title
(gnc:html-document-set-title! document report-title)
;; maybe redefine better...
(if (and account (not (null? account)))
(begin
(gnc:html-document-set-title!
document (string-append report-title ": " (xaccAccountGetName account)))
(gnc:html-document-set-headline! document
(gnc:html-markup
"!"
report-title
": "
(gnc:html-markup-anchor
(gnc:account-anchor-text account)
(xaccAccountGetName account))))))
(gnc:html-table-set-col-headers! table heading-list)
(if (and account (not (null? account)))
(begin
(setup-query query account report-date)
;; get the appropriate splits
(let ((splits (qof-query-run query)))
; (gnc:debug "splits" splits)
;; build the table
(set! work-to-do (length splits))
;; work-done is already zero
(for-each (lambda (split)
(gnc:report-percent-done (* 50 (/ work-done work-to-do)))
(set! work-done (+ 1 work-done))
(update-company-hash companys
split
interval-vec
reverse? show-zeros
date-type))
splits)
; (gnc:debug "companys" companys)
;; turn the hash into a list
(hash-for-each (lambda (key value)
(set! company-list
(cons (cons key value) company-list)))
companys)
; (gnc:debug "company list" company-list)
(set! company-list (sort-list! company-list
sort-pred))
;; build the table
(set! work-to-do (length company-list))
(set! work-done 0)
(for-each (lambda (company-list-entry)
(gnc:report-percent-done (+ 50 (* 50 (/ work-done work-to-do))))
(set! work-done (+ 1 work-done))
(let* ((monetary-list (convert-to-monetary-list
(company-get-buckets
(cdr company-list-entry))
(company-get-currency
(cdr company-list-entry))
(company-get-overpayment
(cdr company-list-entry))))
(owner (company-get-owner-obj
(cdr company-list-entry)))
(company-name (gncOwnerGetName owner))
(addr (get-addr owner disp-addr-source))
(addr-name (gncAddressGetName addr))
(addr-addr1 (gncAddressGetAddr1 addr))
(addr-addr2 (gncAddressGetAddr2 addr))
(addr-addr3 (gncAddressGetAddr3 addr))
(addr-addr4 (gncAddressGetAddr4 addr))
(addr-phone (gncAddressGetPhone addr))
(addr-fax (gncAddressGetFax addr))
(addr-email (gncAddressGetEmail addr))
(company-active (if (gncOwnerGetActive owner)
(C_ "One-letter indication for 'yes'" "Y") (C_ "One-letter indication for 'no'" "N")))
(opt-fld-list '())
)
;; (gnc:debug "aging-renderer: disp-addr-source=" disp-addr-source
;; " owner=" owner
;; " gncOwnerGetID=" (gncOwnerGetID owner) ;; cust no
;; " gncCustomerGetShipAddr="
;; (gncCustomerGetShipAddr (gncOwnerGetCustomer owner)))
(if disp-addr-name
(set! opt-fld-list (append opt-fld-list (list addr-name))))
(if disp-addr1
(set! opt-fld-list (append opt-fld-list (list addr-addr1))))
(if disp-addr2
(set! opt-fld-list (append opt-fld-list (list addr-addr2))))
(if disp-addr3
(set! opt-fld-list (append opt-fld-list (list addr-addr3))))
(if disp-addr4
(set! opt-fld-list (append opt-fld-list (list addr-addr4))))
(if disp-addr-phone
(set! opt-fld-list (append opt-fld-list (list addr-phone))))
(if disp-addr-fax
(set! opt-fld-list (append opt-fld-list (list addr-fax))))
(if disp-addr-email
(set! opt-fld-list (append opt-fld-list (list addr-email))))
(if disp-active
(set! opt-fld-list (append opt-fld-list (list company-active))))
(add-to-column-totals total-collector-list
monetary-list)
(let* ((ml (reverse monetary-list))
(total (car ml))
(rest (cdr ml)))
(set! monetary-list
(reverse
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-report-text owner account report-date)
total))
rest))))
(gnc:html-table-append-row! table
(append
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
company-name))
monetary-list)
opt-fld-list))
(gncOwnerFree owner)))
company-list)
;; add the totals
(gnc:html-table-append-row!
table
(cons (G_ "Total") (convert-collectors total-collector-list
report-currency
exchange-fn
multi-totals-p)))
(gnc:html-document-add-object!
document table)))
(gnc:html-document-add-object!
document
(gnc:make-html-text
(G_ "No valid account selected. Click on the Options button and select the account to use."))))
(qof-query-destroy query)
(gnc:report-finished)
document))
(export aging-options-generator)
(export aging-renderer)

1
gnucash/report/reports/example/average-balance.scm
View File

@ -455,6 +455,7 @@
(gnc:html-chart-set-data-labels! barchart col-labels)
(gnc:html-chart-set-data-labels! barchart (map car data))
;; (gnc:html-chart-set-row-labels-rotated?! barchart #t)
(gnc:html-chart-set-width! barchart width)
(gnc:html-chart-set-height! barchart height)
(gnc:html-chart-set-height! barchart height)

2
gnucash/report/reports/reports.scm
View File

@ -42,6 +42,7 @@
(export gnc:invoice-report-create)
(export gnc:payables-report-create)
(export gnc:receivables-report-create)
(export gnc:owner-report-create) ;deprecate
(export gnc:owner-report-create-with-enddate)
(let ((loc-spec (if (string-prefix? "de_DE" (gnc-locale-name)) 'de_DE 'us)))
@ -89,4 +90,5 @@
(define gnc:payables-report-create payables-report-create-internal)
(define gnc:receivables-report-create receivables-report-create-internal)
(define gnc:owner-report-create owner-report-create) ;deprecated
(define gnc:owner-report-create-with-enddate owner-report-create-with-enddate)

601
gnucash/report/reports/standard/job-report.scm Normal file
View File

@ -0,0 +1,601 @@
;; -*-scheme-*-
;; owner-report.scm -- Print out a detailed owner report, which is a
;; summary of invoices and payments for a particular
;; company (the owner) applied to an account.
;;
;; Created by: Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
(define-module (gnucash reports standard job-report))
(use-modules (gnucash engine))
(use-modules (gnucash utilities)) ; for gnc:debug
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (srfi srfi-1))
(define acct-string (N_ "Account"))
(define owner-string (N_ "Job"))
(define owner-page gnc:pagename-general)
(define date-header (N_ "Date"))
(define due-date-header (N_ "Due Date"))
(define reference-header (N_ "Reference"))
(define type-header (N_ "Type"))
(define desc-header (N_ "Description"))
(define amount-header (N_ "Amount"))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
(vector-ref columns-used 1))
(define (num-col columns-used)
(vector-ref columns-used 2))
(define (type-col columns-used)
(vector-ref columns-used 3))
(define (memo-col columns-used)
(vector-ref columns-used 4))
(define (value-col columns-used)
(vector-ref columns-used 5))
(define columns-used-size 6)
(define (build-column-used options)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(define (make-set-col col-vector)
(let ((col 0))
(lambda (used? index)
(if used?
(begin
(vector-set! col-vector index col)
(set! col (+ col 1)))
(vector-set! col-vector index #f)))))
(let* ((col-vector (make-vector columns-used-size #f))
(set-col (make-set-col col-vector)))
(set-col (opt-val "Display Columns" date-header) 0)
(set-col (opt-val "Display Columns" due-date-header) 1)
(set-col (opt-val "Display Columns" reference-header) 2)
(set-col (opt-val "Display Columns" type-header) 3)
(set-col (opt-val "Display Columns" desc-header) 4)
(set-col (opt-val "Display Columns" amount-header) 5)
col-vector))
(define (make-heading-list column-vector)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (G_ date-header)))
(if (date-due-col column-vector)
(addto! heading-list (G_ due-date-header)))
(if (num-col column-vector)
(addto! heading-list (G_ reference-header)))
(if (type-col column-vector)
(addto! heading-list (G_ type-header)))
(if (memo-col column-vector)
(addto! heading-list (G_ desc-header)))
(if (value-col column-vector)
(addto! heading-list (G_ amount-header)))
(reverse heading-list)))
(define num-buckets 4)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
(define (make-aging-table options query bucket-intervals reverse? currency)
(let ((lots (xaccQueryGetLots query QUERY-TXN-MATCH-ANY))
(buckets (new-bucket-vector))
(payments (gnc-numeric-zero))
(table (gnc:make-html-table)))
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(begin
(if (>= current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
current-bucket
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (apply-invoice date value)
(let* ((bucket-index (find-bucket 0 bucket-intervals date))
(new-value (gnc-numeric-add-fixed
value
(vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-value)))
(define (apply-payment value)
(set! payments (gnc-numeric-add-fixed value payments)))
(for-each
(lambda (lot)
(let* ((bal (gnc-lot-get-balance lot))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(post-date (gncInvoiceGetDatePosted invoice)))
(if (not (gnc-numeric-zero-p bal))
(begin
(if reverse?
(set! bal (gnc-numeric-neg bal)))
(if (not (null? invoice))
(begin
(apply-invoice post-date bal))
(apply-payment bal))))))
lots)
(gnc:html-table-set-col-headers!
table
(list (G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")))
(gnc:html-table-append-row!
table
(reverse (map (lambda (entry)
(gnc:make-gnc-monetary currency entry))
(vector->list buckets))))
table))
;;
;; Make a row list based on the visible columns
;;
(define (make-row column-vector date due-date num type-str memo monetary)
(let ((row-contents '()))
(if (date-col column-vector)
(addto! row-contents (qof-print-date date)))
(if (date-due-col column-vector)
(addto! row-contents
(if due-date
(qof-print-date due-date)
"")))
(if (num-col column-vector)
(addto! row-contents num))
(if (type-col column-vector)
(addto! row-contents type-str))
(if (memo-col column-vector)
(addto! row-contents memo))
(if (value-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" monetary)))
row-contents))
;;
;; Adds the 'Balance' row to the table if it has not been printed and
;; total is not zero
;;
;; Returns printed?
;;
(define (add-balance-row table column-vector txn odd-row? printed? start-date total)
(if (not printed?)
(begin
(set! printed? #t)
(if (not (gnc-numeric-zero-p total))
(let ((row (make-row column-vector start-date #f "" (G_ "Balance") ""
(gnc:make-gnc-monetary (xaccTransGetCurrency txn) total)))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style (reverse row))
(set! odd-row? (not odd-row?))
(set! row-style (if odd-row? "normal-row" "alternate-row")))
)))
printed?)
;;
;; Make sure the caller checks the type first and only calls us with
;; invoice and payment transactions. we don't verify it here.
;;
;; Return a list of (printed? value odd-row?)
;;
(define (add-txn-row table txn acc column-vector odd-row? printed?
inv-str reverse? start-date total)
(let* ((type (xaccTransGetTxnType txn))
(date (xaccTransGetDate txn))
(due-date #f)
(value (xaccTransGetAccountValue txn acc))
(split (xaccTransGetSplit txn 0))
(invoice (gncInvoiceGetInvoiceFromTxn txn))
(currency (xaccTransGetCurrency txn))
(type-str
(cond
((equal? type TXN-TYPE-INVOICE)
(if (not (null? invoice))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text invoice)
inv-str))
inv-str))
((equal? type TXN-TYPE-PAYMENT) (G_ "Payment, thank you!"))
(else (G_ "Unknown"))))
)
(if reverse?
(set! value (gnc-numeric-neg value)))
(if (< start-date date)
(begin
; Adds 'balance' row if needed
(set! printed? (add-balance-row table column-vector txn odd-row? printed? start-date total))
; Now print out the invoice row
(if (and (not (null? invoice))
(gncInvoiceIsPosted invoice))
(set! due-date (gncInvoiceGetDateDue invoice)))
(let ((row (make-row column-vector date due-date (gnc-get-num-action txn split)
type-str (xaccSplitGetMemo split)
(gnc:make-gnc-monetary currency value)))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style
(reverse row)))
(set! odd-row? (not odd-row?))
))
(list printed? value odd-row?)
))
(define (make-txn-table options query acc start-date end-date)
(let ((txns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ANY))
(used-columns (build-column-used options))
(total (gnc-numeric-zero))
(currency (xaccAccountGetCommodity acc))
(table (gnc:make-html-table))
(inv-str (gnc:option-value (gnc:lookup-option options "__reg"
"inv-str")))
(reverse? (gnc:option-value (gnc:lookup-option options "__reg"
"reverse?"))))
(gnc:html-table-set-col-headers!
table
(make-heading-list used-columns))
; Order the transactions properly
(set! txns (sort txns (lambda (a b) (> 0 (xaccTransOrder a b)))))
(let ((printed? #f)
(odd-row? #t))
(for-each
(lambda (txn)
(let ((type (xaccTransGetTxnType txn)))
(if
(or (equal? type TXN-TYPE-INVOICE)
(equal? type TXN-TYPE-PAYMENT))
(let ((result (add-txn-row table txn acc used-columns odd-row? printed?
inv-str reverse? start-date total)))
(set! printed? (car result))
(set! total (gnc-numeric-add-fixed total (cadr result)))
(set! odd-row? (caddr result))
))))
txns)
;Balance row may not have been added if all transactions were before
;start-date (and no other rows would be added either) so add it now
(if (not (null? txns))
(add-balance-row table used-columns (car txns) odd-row? printed? start-date total)
))
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(if (gnc-numeric-negative-p total)
(G_ "Total Credit")
(G_ "Total Due")))
'())
(list (gnc:make-html-table-cell/size/markup
1 (value-col used-columns)
"total-number-cell"
(gnc:make-gnc-monetary currency total)))))
(let* ((interval-vec (list->vector (make-interval-list end-date))))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list (gnc:make-html-table-cell/size/markup
1 (+ 1 (value-col used-columns))
"centered-label-cell"
(make-aging-table options query interval-vec reverse? currency)))))
table))
(define (options-generator acct-type-list owner-type inv-str reverse?)
(define gnc:*report-options* (gnc:new-options))
(define (gnc:register-inv-option new-option)
(gnc:register-option gnc:*report-options* new-option))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "inv-str" inv-str))
(gnc:register-inv-option
(gnc:make-simple-boolean-option "__reg" "reverse?" "" "" reverse?))
(gnc:register-inv-option
(gnc:make-owner-option owner-page owner-string "v"
(N_ "The job for this report.")
(lambda () '()) #f owner-type))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "owner-type" owner-type))
(gnc:register-inv-option
(gnc:make-account-sel-limited-option owner-page acct-string "w"
(N_ "The account to search for transactions.")
#f #f acct-type-list))
(gnc:options-add-date-interval!
gnc:*report-options* gnc:pagename-general
(N_ "From") (N_ "To") "a")
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") date-header
"b" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") due-date-header
"c" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") reference-header
"d" (N_ "Display the transaction reference?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") type-header
"g" (N_ "Display the transaction type?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") desc-header
"ha" (N_ "Display the transaction description?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") amount-header
"hb" (N_ "Display the transaction amount?") #t))
(gnc:options-set-default-section gnc:*report-options* "General")
gnc:*report-options*)
(define (job-options-generator)
(options-generator (list ACCT-TYPE-RECEIVABLE) GNC-OWNER-JOB
(G_ "Invoice") #f))
(define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID owner)))
(qof-query-add-guid-match
q
(list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER
QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT OWNER-FROM-LOT QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER
QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(xaccQueryAddSingleAccountMatch q account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
q))
(define (make-owner-table owner)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row!
table
(list (gnc:multiline-to-html-text
(gnc:owner-get-name-and-address-dep owner))))
(gnc:html-table-append-row!
table (gnc:make-html-text (gnc:html-markup-br)))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-myname-table book date-format)
(let* ((table (gnc:make-html-table))
(name (gnc:company-info book gnc:*company-name*))
(addy (gnc:company-info book gnc:*company-addy*)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "align" "right")
'attribute (list "valign" "top")
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row! table (list (gnc:multiline-to-html-text (or addy ""))))
(gnc:html-table-append-row!
table (list (gnc-print-time64 (current-time) date-format)))
table))
(define (make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-br))))
(define (reg-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(issue-deprecation-warning
"old job report is deprecated and will be removed in 5.x. Its functionality \
is now merged into new-owner-report.scm.")
(let* ((document (gnc:make-html-document))
(table '())
(orders '())
(query (qof-query-create-for-splits))
(account (opt-val owner-page acct-string))
(owner (opt-val owner-page owner-string))
(start-date (gnc:time64-start-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general (N_ "From")))))
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general (N_ "To")))))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date book))
(type (opt-val "__reg" "owner-type"))
(type-str "")
(report-title-str ""))
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(set! type-str (N_ "Customer"))
(set! report-title-str (G_ "Customer Report")))
((eqv? type GNC-OWNER-JOB)
(set! type-str (N_ "Job"))
(set! report-title-str (G_ "Job Report")))
((eqv? type GNC-OWNER-VENDOR)
(set! type-str (N_ "Vendor"))
(set! report-title-str (G_ "Vendor Report")))
((eqv? type GNC-OWNER-EMPLOYEE)
(set! type-str (N_ "Employee"))
(set! report-title-str (G_ "Employee Report"))))
(gnc:html-document-set-title! document report-title-str)
(if (gncOwnerIsValid owner)
(begin
(setup-query query owner account end-date)
(gnc:html-document-set-title!
document
(string-append report-title-str ": " (gncOwnerGetName owner)))
(gnc:html-document-set-headline!
document (gnc:html-markup
"span"
report-title-str ": "
(gnc:html-markup-anchor
(gnc:job-anchor-text (gncOwnerGetJob owner))
(gncOwnerGetName owner))))
(if (not (null? account))
(begin
(set! table (make-txn-table (gnc:report-options report-obj)
query account start-date end-date))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 1)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 4)))
(set!
table
(gnc:make-html-text
(G_ "No valid account selected. Click on the Options button and select the account to use."))))
(gnc:html-document-add-object!
document
(make-myname-table book date-format))
(gnc:html-document-add-object!
document
(make-owner-table owner))
(make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(G_ "Date Range")
": "
(qof-print-date start-date)
" - "
(qof-print-date end-date))))
(make-break! document)
(gnc:html-document-add-object! document table))
;; else....
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(G_ "No valid customer selected."))
((eqv? type GNC-OWNER-JOB)
(G_ "No valid job selected."))
((eqv? type GNC-OWNER-VENDOR)
(G_ "No valid vendor selected."))
((eqv? type GNC-OWNER-EMPLOYEE)
(G_ "No valid employee selected."))
(else ""))
" "
(G_ "Click on the \"Options\" button to select a company.")))))
(qof-query-destroy query)
document))
(gnc:define-report
'version 1
'name "Job Report (legacy)"
'report-guid "5518ac227e474f47a34439f2d4d049de-old"
'menu-path (list gnc:menuname-business-reports)
'options-generator job-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

5
gnucash/report/reports/standard/new-owner-report.scm
View File

@ -1240,6 +1240,10 @@ and do not match the transaction."))))))))
(guid (assv-ref guid-alist type)))
(owner-report-create-internal guid owner type enddate)))
(define (owner-report-create owner account)
(issue-deprecation-warning "owner-report-create is not used anymore. call owner-report-create-with-enddate instead")
(owner-report-create-with-enddate owner account #f))
(define (gnc:owner-report-create-internal
account split query journal? double? title debit-string credit-string)
@ -1252,4 +1256,5 @@ and do not match the transaction."))))))))
(gnc:register-report-hook ACCT-TYPE-RECEIVABLE #t gnc:owner-report-create-internal)
(gnc:register-report-hook ACCT-TYPE-PAYABLE #t gnc:owner-report-create-internal)
(export owner-report-create) ;deprecate
(export owner-report-create-with-enddate)

861
gnucash/report/reports/standard/owner-report.scm Normal file
View File

@ -0,0 +1,861 @@
;; -*-scheme-*-
;; owner-report.scm -- Print out a detailed owner report, which is a
;; summary of invoices and payments for a particular
;; company (the owner) applied to an account.
;;
;; Created by: Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;; Modified by AMM to show tax figures of invoice.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
(define-module (gnucash reports standard owner-report))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-8))
(use-modules (gnucash engine))
(use-modules (gnucash utilities)) ; for gnc:debug
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
;; Option names
(define optname-from-date (N_ "From"))
(define optname-to-date (N_ "To"))
(define optname-date-driver (N_ "Due or Post Date"))
;; let's define a name for the report-guid's, much prettier
(define employee-report-guid "08ae9c2e884b4f9787144f47eacd7f44-old")
(define vendor-report-guid "d7d1e53505ee4b1b82efad9eacedaea0-old")
(define customer-report-guid "c146317be32e4948a561ec7fc89d15c1-old")
(define acct-string (N_ "Account"))
(define owner-page gnc:pagename-general)
(define date-header (N_ "Date"))
(define due-date-header (N_ "Due Date"))
(define reference-header (N_ "Reference"))
(define type-header (N_ "Type"))
(define desc-header (N_ "Description"))
(define sale-header (N_ "Sale"))
(define tax-header (N_ "Tax"))
(define credit-header (N_ "Credits"))
(define debit-header (N_ "Debits"))
(define amount-header (N_ "Amount"))
;; Depending on the report type we want to set up some lists/cases
;; with strings to ease overview and translation
;; note: we default to company
;; owner-string & doctype-str are nearly equivalent, report is vendor report
;; but default option naming was Company.
;; Names in Option panel (Untranslated! Because it is used for option
;; naming and lookup only, and the display of the option name will be
;; translated somewhere else.)
(define (owner-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (N_ "Customer"))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (N_ "Employee"))
;; FALL THROUGH
(else
(N_ "Company"))))
;; Error strings in case there is no (valid) selection (translated)
(define (invalid-selection-title-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "No valid customer selected."))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "No valid employee selected."))
;; FALL THROUGH
(else
(G_ "No valid company selected."))))
(define (invalid-selection-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "This report requires a customer to be selected."))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "This report requires a employee to be selected."))
;; FALL THROUGH
(else
(G_ "This report requires a company to be selected."))))
;; Html formatted error message documents
(define (gnc:html-make-no-owner-warning
report-title-string report-id)
(gnc:html-make-generic-warning
report-title-string
report-id
invalid-selection-title-string
invalid-selection-string))
(define (gnc:html-make-no-valid-account-warning
report-title-string report-id)
(gnc:html-make-generic-warning
report-title-string
report-id
(G_ "No valid account selected")
(G_ "This report requires a valid account to be selected.")))
;; Document names, used in report names (translated)
(define (doctype-str owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "Customer"))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "Employee"))
;; FALL THROUGH
(else
(G_ "Vendor"))))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
(vector-ref columns-used 1))
(define (num-col columns-used)
(vector-ref columns-used 2))
(define (type-col columns-used)
(vector-ref columns-used 3))
(define (memo-col columns-used)
(vector-ref columns-used 4))
(define (sale-col columns-used)
(vector-ref columns-used 5))
(define (tax-col columns-used)
(vector-ref columns-used 6))
(define (credit-col columns-used)
(vector-ref columns-used 7))
(define (debit-col columns-used)
(vector-ref columns-used 8))
(define (value-col columns-used)
(vector-ref columns-used 9))
(define columns-used-size 10)
(define (build-column-used options)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(define (make-set-col col-vector)
(let ((col 0))
(lambda (used? index)
(if used?
(begin
(vector-set! col-vector index col)
(set! col (+ col 1)))
(vector-set! col-vector index #f)))))
(let* ((col-vector (make-vector columns-used-size #f))
(set-col (make-set-col col-vector)))
(set-col (opt-val "Display Columns" date-header) 0)
(set-col (opt-val "Display Columns" due-date-header) 1)
(set-col (opt-val "Display Columns" reference-header) 2)
(set-col (opt-val "Display Columns" type-header) 3)
(set-col (opt-val "Display Columns" desc-header) 4)
(set-col (opt-val "Display Columns" sale-header) 5)
(set-col (opt-val "Display Columns" tax-header) 6)
(set-col (opt-val "Display Columns" credit-header) 7)
(set-col (opt-val "Display Columns" debit-header) 8)
(set-col (opt-val "Display Columns" amount-header) 9)
col-vector))
(define (make-heading-list column-vector)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (G_ date-header)))
(if (date-due-col column-vector)
(addto! heading-list (G_ due-date-header)))
(if (num-col column-vector)
(addto! heading-list (G_ reference-header)))
(if (type-col column-vector)
(addto! heading-list (G_ type-header)))
(if (memo-col column-vector)
(addto! heading-list (G_ desc-header)))
(if (sale-col column-vector)
(addto! heading-list (G_ sale-header)))
(if (tax-col column-vector)
(addto! heading-list (G_ tax-header)))
(if (credit-col column-vector)
(addto! heading-list (G_ credit-header)))
(if (debit-col column-vector)
(addto! heading-list (G_ debit-header)))
(if (value-col column-vector)
(addto! heading-list (G_ amount-header)))
(reverse heading-list)))
(define num-buckets 5)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
;; Have make-list create a stepped list, then add a date in the future for the "current" bucket
(define (make-extended-interval-list to-date)
(define dayforcurrent (incdate to-date YearDelta)) ;; MAGIC CONSTANT
(define oldintervalreversed (reverse (make-interval-list to-date)))
(reverse (cons dayforcurrent oldintervalreversed)))
(define (make-aging-table options query bucket-intervals reverse? date-type currency)
(let ((lots (xaccQueryGetLots query QUERY-TXN-MATCH-ANY))
(buckets (new-bucket-vector))
(payments (gnc-numeric-zero))
(table (gnc:make-html-table)))
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(begin
(if (>= current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
current-bucket
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (apply-invoice date value)
(let* ((bucket-index (find-bucket 0 bucket-intervals date))
(new-value (gnc-numeric-add-fixed
value
(vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-value)))
(define (apply-payment value)
(set! payments (gnc-numeric-add-fixed value payments)))
(for-each
(lambda (lot)
(let* ((bal (gnc-lot-get-balance lot))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(date (if (eq? date-type 'postdate)
(gncInvoiceGetDatePosted invoice)
(gncInvoiceGetDateDue invoice)))
)
(if (not (gnc-numeric-zero-p bal))
(begin
(if reverse?
(set! bal (gnc-numeric-neg bal)))
(if (not (null? invoice))
(begin
(apply-invoice date bal))
(apply-payment bal))))))
lots)
(gnc:html-table-set-col-headers!
table
(list (G_ "Current")
(G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")))
(gnc:html-table-append-row!
table
(reverse (map (lambda (entry)
(gnc:make-gnc-monetary currency entry))
(vector->list buckets))))
table))
;;
;; Make a row list based on the visible columns
;;
(define (make-row column-vector date due-date num type-str memo monetary credit debit sale tax)
(let ((row-contents '()))
(if (date-col column-vector)
(addto! row-contents (qof-print-date date)))
(if (date-due-col column-vector)
(addto! row-contents
(if due-date
(qof-print-date due-date)
"")))
(if (num-col column-vector)
(addto! row-contents (gnc:html-string-sanitize num)))
(if (type-col column-vector)
(addto! row-contents type-str))
(if (memo-col column-vector)
(addto! row-contents (gnc:html-string-sanitize memo)))
(if (sale-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" sale)))
(if (tax-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" tax)))
(if (credit-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" credit)))
(if (debit-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" debit)))
(if (value-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" monetary)))
row-contents))
;;
;; Adds the 'Balance' row to the table if it has not been printed and
;; total is not zero
;;
;; Returns printed?
;;
(define (add-balance-row table column-vector txn odd-row? printed? start-date total)
(if (not printed?)
(begin
(set! printed? #t)
(if (and (value-col column-vector) (not (gnc-numeric-zero-p total)))
(let ((row (make-row column-vector start-date #f "" (G_ "Balance") ""
(gnc:make-gnc-monetary (xaccTransGetCurrency txn) total) "" "" "" ""))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style (reverse row))
(set! odd-row? (not odd-row?))
(set! row-style (if odd-row? "normal-row" "alternate-row")))
)))
printed?)
;;
;; Make sure the caller checks the type first and only calls us with
;; invoice and payment transactions. we don't verify it here.
;;
;; Return a list of (printed? value odd-row?)
;;
(define (add-txn-row table txn acc column-vector odd-row? printed?
reverse? start-date total)
(let* ((type (xaccTransGetTxnType txn))
(date (xaccTransGetDate txn))
(due-date #f)
(value (xaccTransGetAccountValue txn acc))
(sale (gnc-numeric-zero))
(tax (gnc-numeric-zero))
(split (xaccTransGetSplit txn 0))
(invoice (gncInvoiceGetInvoiceFromTxn txn))
(currency (xaccTransGetCurrency txn))
(type-str
(cond
((equal? type TXN-TYPE-INVOICE)
(if (not (null? invoice))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text invoice)
(gncInvoiceGetTypeString invoice)))
(G_ "Unknown")))
((equal? type TXN-TYPE-PAYMENT)
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:split-anchor-text split) (G_ "Payment"))))
(else (G_ "Unknown"))))
)
(if reverse?
(set! value (gnc-numeric-neg value)))
(if (<= start-date date)
(begin
; Adds 'balance' row if needed
(set! printed? (add-balance-row table column-vector txn odd-row? printed? start-date total))
; Now print out the invoice row
(if (not (null? invoice))
(begin
(set! due-date (and (gncInvoiceIsPosted invoice)
(gncInvoiceGetDateDue invoice)))
(set! sale (gncInvoiceGetTotalSubtotal invoice))
(set! tax (gncInvoiceGetTotalTax invoice))))
(if (gncInvoiceGetIsCreditNote invoice)
(begin
(set! tax (gnc-numeric-neg tax))
(set! sale (gnc-numeric-neg sale))))
(let ((row (make-row column-vector date due-date (gnc-get-num-action txn split)
type-str (xaccSplitGetMemo split)
(gnc:make-gnc-monetary currency value)
(if (not (gnc-numeric-negative-p value))
(gnc:make-gnc-monetary currency value) "")
(if (gnc-numeric-negative-p value)
(gnc:make-gnc-monetary currency value) "")
(if (not (null? invoice))
(gnc:make-gnc-monetary currency sale) "")
(if (not (null? invoice))
(gnc:make-gnc-monetary currency tax) "")
))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style
(reverse row)))
(set! odd-row? (not odd-row?))
))
(list printed? value odd-row? sale tax)
))
(define (make-txn-table options query acc start-date end-date date-type)
(let ((txns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ANY))
(used-columns (build-column-used options))
(total (gnc-numeric-zero))
(debit (gnc-numeric-zero))
(credit (gnc-numeric-zero))
(tax (gnc-numeric-zero))
(sale (gnc-numeric-zero))
(currency (xaccAccountGetCommodity acc))
(table (gnc:make-html-table))
(reverse? (gnc:option-value (gnc:lookup-option options "__reg"
"reverse?"))))
(gnc:html-table-set-col-headers!
table
(make-heading-list used-columns))
; Order the transactions properly
(set! txns (sort txns (lambda (a b) (> 0 (xaccTransOrder a b)))))
(let ((printed? #f)
(odd-row? #t))
(for-each
(lambda (txn)
(let ((type (xaccTransGetTxnType txn)))
(if
(or (equal? type TXN-TYPE-INVOICE)
(equal? type TXN-TYPE-PAYMENT))
(let ((result (add-txn-row table txn acc used-columns odd-row? printed?
reverse? start-date total)))
(set! printed? (car result))
(if (and printed? total)
(begin
(set! sale (gnc-numeric-add-fixed sale (cadddr result)))
(set! tax (gnc-numeric-add-fixed tax (car (cddddr result))))
(if (gnc-numeric-negative-p (cadr result))
(set! debit (gnc-numeric-add-fixed debit (cadr result)))
(set! credit (gnc-numeric-add-fixed credit (cadr result))))))
(set! total (gnc-numeric-add-fixed total (cadr result)))
(set! odd-row? (caddr result))
))))
txns)
;Balance row may not have been added if all transactions were before
;start-date (and no other rows would be added either) so add it now
(if (not (null? txns))
(add-balance-row table used-columns (car txns) odd-row? printed? start-date total)
))
(if (or (sale-col used-columns) (tax-col used-columns) (credit-col used-columns) (debit-col used-columns))
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(G_ "Period Totals"))
'())
(let ((row-contents '())
(pre-span 0))
; HTML gets generated in reverse order
(if (value-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency (gnc-numeric-add-fixed credit debit)))))
(if (debit-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency debit))))
(if (credit-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency credit))))
(if (tax-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency tax))))
(if (sale-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency sale))))
(if (memo-col used-columns) (set! pre-span (+ pre-span 1)))
(if (type-col used-columns) (set! pre-span (+ pre-span 1)))
(if (num-col used-columns) (set! pre-span (+ pre-span 1)))
(if (date-due-col used-columns) (set! pre-span (+ pre-span 1)))
(if (date-col used-columns) (set! pre-span (+ pre-span 1)))
(if (>= pre-span 2) (addto! row-contents (gnc:make-html-table-cell/size 1 (- pre-span 1) "")))
row-contents))))
(if (value-col used-columns)
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(if (gnc-numeric-negative-p total)
(G_ "Total Credit")
(G_ "Total Due")))
'())
(list (gnc:make-html-table-cell/size/markup
1 (value-col used-columns)
"total-number-cell"
(gnc:make-gnc-monetary currency total))))))
(let* ((interval-vec (list->vector (make-extended-interval-list end-date))))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list (gnc:make-html-table-cell/size
1 columns-used-size
(make-aging-table options query interval-vec reverse? date-type currency)))))
table))
(define (options-generator acct-type-list owner-type reverse?)
(define gnc:*report-options* (gnc:new-options))
(define (gnc:register-inv-option new-option)
(gnc:register-option gnc:*report-options* new-option))
(gnc:register-inv-option
(gnc:make-simple-boolean-option "__reg" "reverse?" "" "" reverse?))
(gnc:register-inv-option
(gnc:make-owner-option owner-page (owner-string owner-type) "v"
(N_ "The company for this report.")
(lambda () '()) #f owner-type))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "owner-type" owner-type))
(gnc:register-inv-option
(gnc:make-account-sel-limited-option owner-page acct-string "w"
(N_ "The account to search for transactions.")
#f #f acct-type-list))
(gnc:options-add-date-interval!
gnc:*report-options* gnc:pagename-general
optname-from-date optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-default-value
(gnc:lookup-option gnc:*report-options* gnc:pagename-general optname-to-date)
(cons 'relative 'today))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") date-header
"b" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") due-date-header
"c" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") reference-header
"d" (N_ "Display the transaction reference?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") type-header
"g" (N_ "Display the transaction type?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") desc-header
"ha" (N_ "Display the transaction description?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") sale-header
"haa" (N_ "Display the sale amount column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") tax-header
"hab" (N_ "Display the tax column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") credit-header
"hac" (N_ "Display the period credits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") debit-header
"had" (N_ "Display the period debits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") amount-header
"hb" (N_ "Display the transaction amount?") #t))
(gnc:register-inv-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-date-driver
"k"
(N_ "Leading date.")
'duedate
(list
(vector 'duedate (N_ "Due Date"))
(vector 'postdate (N_ "Post Date")))))
(gnc:options-set-default-section gnc:*report-options* "General")
gnc:*report-options*)
(define (customer-options-generator)
(options-generator (list ACCT-TYPE-RECEIVABLE) GNC-OWNER-CUSTOMER #f))
(define (vendor-options-generator)
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-VENDOR #t))
(define (employee-options-generator)
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE #t))
(define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner))))
(qof-query-add-guid-match
q
(list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER
OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT OWNER-FROM-LOT OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER
OWNER-PARENTG)
guid QOF-QUERY-OR)
(xaccQueryAddSingleAccountMatch q account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
q))
(define (make-owner-table owner)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row!
table (gnc:multiline-to-html-text (gnc:owner-get-name-and-address-dep owner)))
(gnc:html-table-append-row!
table (gnc:make-html-text (gnc:html-markup-br)))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-date-row! table label date)
(gnc:html-table-append-row!
table
(list
(string-append label ": ")
(qof-print-date date))))
(define (make-date-table)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-myname-table book date-format)
(let* ((table (gnc:make-html-table))
(name (gnc:company-info book gnc:*company-name*))
(addy (gnc:company-info book gnc:*company-addy*)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "align" "right")
'attribute (list "valign" "top")
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row!
table (list (gnc:multiline-to-html-text (or addy ""))))
(gnc:html-table-append-row!
table (list (gnc-print-time64 (gnc:get-today) date-format)))
table))
(define (make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-br))))
(define (reg-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(issue-deprecation-warning
"old owner reports are deprecated and will be removed in 5.x")
(let* ((document (gnc:make-html-document))
(table '())
(orders '())
(query (qof-query-create-for-splits))
(account (opt-val owner-page acct-string))
(start-date (gnc:time64-start-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-from-date))))
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-to-date))))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date book))
(type (opt-val "__reg" "owner-type"))
(owner-descr (owner-string type))
(date-type (opt-val gnc:pagename-general optname-date-driver))
(owner (opt-val owner-page owner-descr))
(report-title (string-append (doctype-str type) " " (G_ "Report"))))
(if (not (gncOwnerIsValid owner))
(gnc:html-document-add-object!
document
(gnc:html-make-no-owner-warning
report-title (gnc:report-id report-obj)))
;; else....
(begin
(set! report-title (string-append report-title ": " (gncOwnerGetName owner)))
(if (null? account)
(gnc:html-document-add-object!
document
(gnc:html-make-no-valid-account-warning
report-title (gnc:report-id report-obj)))
;; else....
(begin
(setup-query query owner account end-date)
(gnc:html-document-set-title! document report-title)
(gnc:html-document-set-headline!
document (gnc:html-markup
"span"
(doctype-str type)
" " (G_ "Report:") " "
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
(gncOwnerGetName owner))))
(set! table (make-txn-table (gnc:report-options report-obj)
query account start-date end-date date-type))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 1)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 4))
(gnc:html-document-add-object!
document
(make-myname-table book date-format))
(gnc:html-document-add-object!
document
(make-owner-table owner))
(make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(G_ "Date Range")
": "
(qof-print-date start-date)
" - "
(qof-print-date end-date))))
(make-break! document)
(gnc:html-document-add-object! document table)
(qof-query-destroy query)))))
document))
(define* (find-first-account type #:key currency)
(or (find
(lambda (acc)
(and (eqv? type (xaccAccountGetType acc))
(or (not currency)
(gnc-commodity-equiv currency (xaccAccountGetCommodity acc)))))
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
'()))
(define* (find-first-account-for-owner owner #:key currency)
(let ((type (gncOwnerGetType (gncOwnerGetEndOwner owner))))
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(find-first-account ACCT-TYPE-RECEIVABLE #:currency currency))
((eqv? type GNC-OWNER-VENDOR)
(find-first-account ACCT-TYPE-PAYABLE #:currency currency))
((eqv? type GNC-OWNER-EMPLOYEE)
(find-first-account ACCT-TYPE-PAYABLE #:currency currency))
((eqv? type GNC-OWNER-JOB)
(find-first-account-for-owner (gncOwnerGetEndOwner owner)
#:currency currency))
(else
'()))))
(gnc:define-report
'version 1
'name "Customer Report (legacy)"
'report-guid customer-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator customer-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))
(gnc:define-report
'version 1
'name "Vendor Report (legacy)"
'report-guid vendor-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator vendor-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))
(gnc:define-report
'version 1
'name "Employee Report (legacy)"
'report-guid employee-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator employee-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

81
gnucash/report/reports/standard/payables.scm Normal file
View File

@ -0,0 +1,81 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; payables.scm : accounts payable aging report
;;
;; By Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard payables))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash reports aging))
(define acc-page gnc:pagename-general)
(define this-acc (N_ "Payable Account"))
(define (options-generator)
(let* ((options (gnc:new-options))
(add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(add-option
(gnc:make-account-sel-limited-option
acc-page this-acc
"w" (N_ "The payable account you wish to examine.")
#f #f (list ACCT-TYPE-PAYABLE)))
;; As aging.scm functions are used by both receivables.scm and payables.scm
;; add option "receivable" on hidden page "__hidden" with default value 'P
;; so aging.scm functions can tell if they are reporting on
;; accounts receivable or payable, as customers have a shipping address
;; but vendors do not. The Address Source option therefore only applies
;; to customers.
(add-option
(gnc:make-internal-option "__hidden" "receivable-or-payable" 'P))
(aging-options-generator options)))
(define (payables-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(let ((payables-account (opt-val acc-page this-acc)))
(gnc:debug "payables-account" payables-account)
(aging-renderer report-obj this-acc payables-account #f)))
(define payables-aging-guid "e57770f2dbca46619d6dac4ac5469b50-old")
;; Here we define the actual report with gnc:define-report
(gnc:define-report
'version 1
'name "Payable Aging (legacy)"
'report-guid payables-aging-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator options-generator
'renderer payables-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

94
gnucash/report/reports/standard/receivables.scm Normal file
View File

@ -0,0 +1,94 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; receivables.scm : accounts receivable aging report
;;
;; By Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard receivables))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash reports aging))
(define acc-page gnc:pagename-general)
(define this-acc (N_ "Receivables Account"))
(define optname-addr-source (N_ "Address Source")) ;; Billing or Shipping addresses
(define (options-generator)
(let* ((options (gnc:new-options))
(add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(add-option
(gnc:make-account-sel-limited-option
acc-page this-acc
"w" (N_ "The receivables account you wish to examine.")
#f #f (list ACCT-TYPE-RECEIVABLE)))
;; As aging.scm functions are used by both receivables.scm and payables.scm
;; add option "receivable" on hidden page "__hidden" with default value 'R
;; so aging.scm functions can tell if they are reporting on
;; accounts receivable or payable, as customers have a shipping address
;; but vendors do not. The Address Source option therefore only applies
;; to customers.
(add-option
(gnc:make-internal-option "__hidden" "receivable-or-payable" 'R))
(add-option
(gnc:make-multichoice-option
gnc:pagename-display
optname-addr-source
"a"
(N_ "Address source.")
'billing
(list
(vector 'billing (N_ "Billing address"))
(vector 'shipping (N_ "Shipping address")))))
(aging-options-generator options)))
(define (receivables-renderer report-obj)
(define (op-value section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(let* ((receivables-account (op-value acc-page this-acc)))
(gnc:debug "receivables-account" receivables-account)
(aging-renderer report-obj this-acc receivables-account #t)))
(define receivables-aging-guid "9cf76bed17f14401b8e3e22d0079cb98-old")
;; Here we define the actual report with gnc:define-report
(gnc:define-report
'version 1
'name "Receivable Aging (legacy)"
'report-guid receivables-aging-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator options-generator
'renderer receivables-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

59
gnucash/report/reports/standard/test/test-owner-report.scm
View File

@ -14,7 +14,11 @@
(use-modules (system vm vm))
(define uuid-list
(list (cons 'customer-new "c146317be32e4948a561ec7fc89d15c1")))
(list (cons 'employee "08ae9c2e884b4f9787144f47eacd7f44-old")
(cons 'vendor "d7d1e53505ee4b1b82efad9eacedaea0-old")
(cons 'customer "c146317be32e4948a561ec7fc89d15c1-old")
(cons 'customer-new "c146317be32e4948a561ec7fc89d15c1")
(cons 'job "5518ac227e474f47a34439f2d4d049de-old")))
(setlocale LC_ALL "C")
@ -302,6 +306,32 @@
(gnc-dmy2time64 22 06 1980) ;due
"inv $3 CN" #t #f))
;; (gnc:dump-book) (newline)
;; (gnc:dump-invoices) (newline)
(display "customer-report tests:\n")
(test-begin "customer-report")
(let* ((options (default-testing-options 'customer owner-1 (get-acct "AR-USD")))
(sxml (options->sxml 'customer options "customer-report basic")))
(test-equal "inv-descriptions"
'("inv >90 $11.50" "inv 60-90 $7.50" "inv 30-60 $8.50"
"inv >90 payment" "inv >90 payment" "inv <30days $4.00"
"inv $200" "inv $200" "inv current $6.75" "inv $3 CN"
"$31.75" "$8.00" "$8.00")
(sxml-get-row-col sxml #f 5))
(test-equal "debit-amounts"
'("$11.50" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75")
(sxml-get-row-col sxml #f 6))
(test-equal "crebit-amounts"
'("-$1.50" "-$2.00" "-$200.00" "-$3.00")
(sxml-get-row-col sxml #f 7))
;; from the report, find the 3rd table, last row, find embedded
;; table, retrieve tr contents
(test-equal "aging-table"
'("$6.75" "$1.00" "$8.50" "$7.50" "$8.00")
((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
sxml)))
(test-end "customer-report")
(display "new-owner-report tests:\n")
(test-begin "new-customer-report")
(let* ((options (default-testing-options 'customer-new
@ -354,4 +384,29 @@
((sxpath `(// (table 3) // thead // (tr 2) // *text*))
sxml))
)
(test-end "new-customer-report")))
(test-end "new-customer-report")
(display "job-report tests:\n")
;; inv for job
(let ((inv-2-copy (gncInvoiceCopy inv-2)))
(gncInvoiceAddEntry inv-2-copy (entry 25/4))
(gncInvoicePostToAccount inv-2-copy
(get-acct "AR-USD") ;post-to acc
(gnc-dmy2time64 13 05 1980) ;posted
(gnc-dmy2time64 18 06 1980) ;due
"inv for job" #t #f)
(gncInvoiceApplyPayment
inv-2-copy '() (get-acct "Bank-USD") 25/4 1
(gnc-dmy2time64 18 06 1980)
"inv for job" "fully paid"))
(test-begin "job-report")
(let* ((options (default-testing-options 'job owner-2 (get-acct "AR-USD")))
(sxml (options->sxml 'job options "job-report basic")))
(test-equal "inv-descriptions"
'("inv for job" "inv for job")
(sxml-get-row-col sxml #f 5))
(test-equal "amounts"
'("$6.25" "-$6.25")
(sxml-get-row-col sxml #f 6)))
(test-end "job-report")))

22
gnucash/report/stylesheets/CMakeLists.txt
View File

@ -20,6 +20,28 @@ gnc_add_scheme_targets(scm-report-stylesheets-1
DEPENDS "${GUILE_DEPENDS}"
MAKE_LINKS)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report stylesheet-easy"
NEW_MODULE "gnucash report stylesheets footer"
DEPENDS "scm-report-stylesheets-1")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report stylesheet-fancy"
NEW_MODULE "gnucash report stylesheets footer"
DEPENDS "scm-report-stylesheets-1")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report stylesheet-footer"
NEW_MODULE "gnucash report stylesheets footer"
DEPENDS "scm-report-stylesheets-1")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report stylesheet-head-or-tail"
NEW_MODULE "gnucash report stylesheets head-or-tail"
DEPENDS "scm-report-stylesheets-1")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report stylesheet-plain"
NEW_MODULE "gnucash report stylesheets plain"
DEPENDS "scm-report-stylesheets-1")
add_custom_target(scm-report-stylesheets ALL DEPENDS scm-report-stylesheets-1)
set_local_dist(stylesheets_DIST_local CMakeLists.txt ${stylesheets_SCHEME})

6
gnucash/report/test/CMakeLists.txt
View File

@ -53,3 +53,9 @@ set_dist_list(test_report_DIST
${scm_test_report_SOURCES}
test-report-extras.scm
)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "tests test-report-system-extras"
NEW_MODULE "tests test-report-extras"
DEPENDS "scm-test-report")

29
gnucash/report/test/test-report-html.scm
View File

@ -703,14 +703,39 @@ HTML Document Title</title></head><body></body>\n\
)
)
(test-end "HTML Table - Cell Access and Edit")
(test-begin "HTML Table - Append Columns")
(let (
(test-doc (gnc:make-html-document))
(test-table (gnc:make-html-table))
)
(gnc:html-table-set-caption! test-table #t)
(gnc:html-table-append-row! test-table "r1c1")
(gnc:html-table-append-row! test-table '("r2c1" "r2c2" "r2c3"))
(gnc:html-table-append-row! test-table '("r3c1" "r3c2"))
(gnc:html-table-append-column! test-table '("r1c4" "r2c4" "r3c4" "r4c4"))
(test-equal "HTML Table - Check Num Rows after append column"
4
(gnc:html-table-num-rows test-table)
)
(test-equal "HTML Table - Check data after append column"
'((#f #f #f "r4c4") ("r3c1" "r3c2" #f "r3c4") ("r2c1" "r2c2" "r2c3" "r2c4") ("r1c1" #f #f "r1c4"))
(gnc:html-table-data test-table)
)
(test-equal "HTML Table - Check Cell Access after append column"
"r3c2"
(gnc:html-table-get-cell test-table 2 1)
)
)
(test-end "HTML Table - Append Columns")
(test-begin "HTML Table - Table Rendering")
(let (
(test-doc (gnc:make-html-document))
(test-table (gnc:make-html-table))
)
(gnc:html-table-set-caption! test-table #t)
(gnc:html-table-append-row! test-table '("Row 1" "Col A"))
(gnc:html-table-append-row! test-table '("Row 2" "Col B"))
(gnc:html-table-append-row! test-table "Row 1")
(gnc:html-table-append-row! test-table "Row 2")
(gnc:html-table-append-column! test-table '("Col A" "Col B"))
(test-equal "HTML Table - Check table rendering result"
"<table><caption><boolean> #t</caption>\n\
<tbody>\

24
gnucash/report/test/test-report-utilities.scm
View File

@ -383,6 +383,30 @@
(gnc-dmy2time64 01 01 2001)
#t)))
(test-equal "gnc:accounts-get-comm-total-profit"
'(("GBP" . 612) ("USD" . 2389))
(collector->list
(gnc:accounts-get-comm-total-profit all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-income"
'(("GBP" . 612) ("USD" . 2573))
(collector->list
(gnc:accounts-get-comm-total-income all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-expense"
'(("USD" . -184))
(collector->list
(gnc:accounts-get-comm-total-expense all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-assets"
'(("GBP" . 608) ("USD" . 2394))
(collector->list

7
gnucash/report/test/test-report.scm
View File

@ -150,8 +150,13 @@
(test-begin "test-make-report")
(test-assert "gnc:make-report succeeds"
(gnc:make-report test4-guid))
(test-equal "gnc:restore-report-by-guid-with-custom-template"
(test-equal "gnc:restore-report-by-guid"
1
(gnc:restore-report-by-guid 1 test4-guid test4-name "options"))
(test-assert "gnc:restore-report-by-guid, no options"
(not (gnc:restore-report-by-guid 1 test4-guid test4-name #f)))
(test-equal "gnc:restore-report-by-guid-with-custom-template"
2
(gnc:restore-report-by-guid-with-custom-template
"id" test4-guid test4-name "custom-template-id" "options"))
(test-assert "gnc:restore-report-by-guid-with-custom-template, no options"

7
gnucash/report/trep-engine.scm
View File

@ -1934,7 +1934,7 @@ be excluded from periodic reporting.")
report-obj #:key custom-calculated-cells empty-report-message
custom-split-filter split->date split->date-include-false?
custom-source-accounts
export-type)
export-type filename)
;; the trep-renderer is a define* function which, at minimum, takes
;; the report object
;;
@ -1967,6 +1967,11 @@ be excluded from periodic reporting.")
(((? from-account?) . _) #t)
((_ . rest) (lp rest)))))
(when filename
(issue-deprecation-warning "trep-renderer filename is obsolete, and not \
supported for exports. please set html-document export-string instead. this \
warning will be removed in GnuCash 5.0"))
(gnc:report-starting (opt-val gnc:pagename-general gnc:optname-reportname))
(let* ((document (gnc:make-html-document))

8
libgnucash/app-utils/CMakeLists.txt
View File

@ -225,6 +225,14 @@ gnc_add_scheme_targets(scm-app-utils-2
DEPENDS "scm-bus-prefs"
MAKE_LINKS)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (OLD_MODULE "migrate-prefs")
gnc_add_scheme_deprecated_module (OLD_MODULE "migrate-prefs-user")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash gettext"
NEW_MODULE "gnucash core-utils"
DEPENDS "scm-core-utils")
add_custom_target(scm-app-utils ALL DEPENDS scm-app-utils-2 scm-app-utils-1)
set_local_dist(app_utils_DIST_local

11
libgnucash/app-utils/app-utils.scm
View File

@ -38,3 +38,14 @@
(export gnc:get-debit-string)
(export gnc:get-credit-string)
(export gnc:config-file-format-version)
;; Symbols deprecated in 4.x, to remove for 5.x
(define (gnc:get-debit-string acct-type)
(issue-deprecation-warning "gnc:get-debit-string is deprecated in 4.x. Please use (gnucash engine)'s gnc-account-get-debit-string instead.")
(gnc-account-get-debit-string acct-type))
(define (gnc:get-credit-string acct-type)
(issue-deprecation-warning "gnc:get-credit-string is deprecated in 4.x. Please use (gnucash engine)'s gnc-account-get-credit-string instead.")
(gnc-account-get-debit-string acct-type))
(define (gnc:config-file-format-version version)
(issue-deprecation-warning "gnc:config-file-format-version is deprecated in 4.x and will be removed from a future version.")
#t)

18
libgnucash/app-utils/c-interface.scm
View File

@ -26,6 +26,7 @@
(export gnc:apply-with-error-handling)
(export gnc:eval-string-with-error-handling)
(export gnc:backtrace-if-exception)
(export gnc:last-captured-error)
(define (gnc:call-with-error-handling cmd args)
(let ((captured-stack #f)
@ -77,5 +78,22 @@
((result #f) result)
((_ captured-error)
(display captured-error (current-error-port))
;; the next line will be removed in 5.x - deprecated
(set! gnc:last-captured-error (gnc:html-string-sanitize captured-error))
(when (defined? 'gnc:warn) (gnc:warn captured-error))
#f)))
(define gnc:last-captured-error "") ;deprecate - remove in 5.x
;; This database can be used to store and retrieve translatable
;; strings. Strings that are returned by the lookup function are
;; translated with gettext.
(define (gnc:make-string-database)
(define string-hash (make-hash-table))
(issue-deprecation-warning "gnc:make-string-database is deprecated. It \
will be removed in GnuCash 5.x")
(lambda args
(match args
(('lookup key) (G_ (hash-ref string-hash key)))
(('store key string) (hash-set! string-hash key string))
(_ (gnc:warn "string-database: bad action")))))

370
libgnucash/app-utils/date-utilities.scm
View File

@ -105,7 +105,21 @@
(export gnc:get-start-prev-quarter)
(export gnc:get-end-prev-quarter)
(export gnc:get-today)
(export gnc:get-one-month-ago)
(export gnc:get-three-months-ago)
(export gnc:get-six-months-ago)
(export gnc:get-one-year-ago)
(export gnc:reldate-initialize)
(export gnc:get-end-next-month)
(export gnc:get-end-next-quarter)
(export gnc:get-end-next-year)
(export gnc:get-one-month-ahead)
(export gnc:get-one-year-ahead)
(export gnc:get-six-months-ahead)
(export gnc:get-start-next-month)
(export gnc:get-start-next-quarter)
(export gnc:get-start-next-year)
(export gnc:get-three-months-ahead)
;; get stuff from localtime date vector
(define (gnc:date-get-year datevec)
@ -570,6 +584,30 @@ Defaulting to today."))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-start-next-year)
(issue-deprecation-warning "gnc:get-start-next-year is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 0)
(set-tm:year now (+ (tm:year now) 1))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-end-next-year)
(issue-deprecation-warning "gnc:get-end-next-year is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now 31)
(set-tm:mon now 11)
(set-tm:year now (+ (tm:year now) 1))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-start-accounting-period)
(gnc-accounting-period-fiscal-start))
@ -623,6 +661,38 @@ Defaulting to today."))
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-start-next-month)
(issue-deprecation-warning "gnc:get-start-next-month is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(if (= (tm:mon now) 11)
(begin
(set-tm:mon now 0)
(set-tm:year now (+ (tm:year now) 1)))
(set-tm:mon now (+ (tm:mon now) 1)))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-end-next-month)
(issue-deprecation-warning "gnc:get-end-next-month is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (= (tm:mon now) 11)
(begin
(set-tm:mon now 0)
(set-tm:year now (+ (tm:year now) 1)))
(set-tm:mon now (+ (tm:mon now) 1)))
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-start-current-quarter)
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 0)
@ -676,9 +746,152 @@ Defaulting to today."))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-start-next-quarter)
(issue-deprecation-warning "gnc:get-start-next-quarter is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(if (> (tm:mon now) 8)
(begin
(set-tm:mon now 0)
(set-tm:year now (+ (tm:year now) 1)))
(set-tm:mon now (+ (tm:mon now) (- 3 (modulo (tm:mon now) 3)))))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-end-next-quarter)
(issue-deprecation-warning "gnc:get-end-next-quarter is deprecated.")
(let ((now (gnc-localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (> (tm:mon now) 8)
(begin
(set-tm:mon now 2)
(set-tm:year now (+ (tm:year now) 1)))
(set-tm:mon now (+ (tm:mon now)
(+ 1 (modulo (tm:mon now) 3)))))
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(gnc-mktime now)))
(define (gnc:get-today)
(current-time))
(define (gnc:get-one-month-ago)
(issue-deprecation-warning "gnc:get-one-month-ago is deprecated.")
(let ((now (gnc-localtime (current-time))))
(if (= (tm:mon now) 0)
(begin
(set-tm:mon now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:mon now (- (tm:mon now) 1)))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-three-months-ago)
(issue-deprecation-warning "gnc:get-three-months-ago is unused.")
(let ((now (gnc-localtime (current-time))))
(if (< (tm:mon now) 3)
(begin
(set-tm:mon now (+ (tm:mon now) 12))
(set-tm:year now (- (tm:year now) 1))))
(set-tm:mon now (- (tm:mon now) 3))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-six-months-ago)
(issue-deprecation-warning "gnc:get-six-months-ago is unused.")
(let ((now (gnc-localtime (current-time))))
(if (< (tm:mon now) 6)
(begin
(set-tm:mon now (+ (tm:mon now) 12))
(set-tm:year now (- (tm:year now) 1))))
(set-tm:mon now (- (tm:mon now) 6))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-one-year-ago)
(issue-deprecation-warning "gnc:get-one-year-ago is unused.")
(let ((now (gnc-localtime (current-time))))
(set-tm:year now (- (tm:year now) 1))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-one-month-ahead)
(issue-deprecation-warning "gnc:get-one-month-ahead is deprecated.")
(let ((now (gnc-localtime (current-time))))
(if (= (tm:mon now) 11)
(begin
(set-tm:mon now 0)
(set-tm:year now (+ (tm:year now) 1)))
(set-tm:mon now (+ (tm:mon now) 1)))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-three-months-ahead)
(issue-deprecation-warning "gnc:get-three-months-ahead is unused.")
(let ((now (gnc-localtime (current-time))))
(if (> (tm:mon now) 8)
(begin
(set-tm:mon now (- (tm:mon now) 9))
(set-tm:year now (+ (tm:year now) 1))
(set-tm:mon now (+ (tm:mon now) 3))))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-six-months-ahead)
(issue-deprecation-warning "gnc:get-six-months-ahead is unused.")
(let ((now (gnc-localtime (current-time))))
(if (> (tm:mon now) 5)
(begin
(set-tm:mon now (- (tm:mon now) 6))
(set-tm:year now (+ (tm:year now) 1))
(set-tm:mon now (+ (tm:mon now) 6))))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
(define (gnc:get-one-year-ahead)
(issue-deprecation-warning "gnc:get-one-year-ahead is unused.")
(let ((now (gnc-localtime (current-time))))
(set-tm:year now (+ (tm:year now) 1))
(let ((month-days (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (< month-days (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc-mktime now))))
;; There is no GNC:RELATIVE-DATES list like the one mentioned in
;; gnucash-design.info, is there? Here are the currently defined
@ -730,6 +943,20 @@ Defaulting to today."))
'store 'end-prev-year-desc
(N_ "Last day of the previous calendar year."))
(gnc:reldate-string-db
'store 'start-next-year-string
(N_ "Start of next year"))
(gnc:reldate-string-db
'store 'start-next-year-desc
(N_ "First day of the next calendar year."))
(gnc:reldate-string-db
'store 'end-next-year-string
(N_ "End of next year"))
(gnc:reldate-string-db
'store 'end-next-year-desc
(N_ "Last day of the next calendar year."))
(gnc:reldate-string-db
'store 'start-accounting-period-string
(N_ "Start of accounting period"))
@ -772,6 +999,20 @@ Defaulting to today."))
'store 'end-prev-month-desc
(N_ "Last day of previous month."))
(gnc:reldate-string-db
'store 'start-next-month-string
(N_ "Start of next month"))
(gnc:reldate-string-db
'store 'start-next-month-desc
(N_ "First day of the next month."))
(gnc:reldate-string-db
'store 'end-next-month-string
(N_ "End of next month"))
(gnc:reldate-string-db
'store 'end-next-month-desc
(N_ "Last day of next month."))
(gnc:reldate-string-db
'store 'start-current-quarter-string
(N_ "Start of current quarter"))
@ -800,12 +1041,84 @@ Defaulting to today."))
'store 'end-prev-quarter-desc
(N_ "Last day of previous quarterly accounting period."))
(gnc:reldate-string-db
'store 'start-next-quarter-string
(N_ "Start of next quarter"))
(gnc:reldate-string-db
'store 'start-next-quarter-desc
(N_ "First day of the next quarterly accounting period."))
(gnc:reldate-string-db
'store 'end-next-quarter-string
(N_ "End of next quarter"))
(gnc:reldate-string-db
'store 'end-next-quarter-desc
(N_ "Last day of next quarterly accounting period."))
(gnc:reldate-string-db
'store 'today-string
(N_ "Today"))
(gnc:reldate-string-db
'store 'today-desc (N_ "The current date."))
(gnc:reldate-string-db
'store 'one-month-ago-string
(N_ "One Month Ago"))
(gnc:reldate-string-db
'store 'one-month-ago-desc (N_ "One Month Ago."))
(gnc:reldate-string-db
'store 'one-week-ago-string
(N_ "One Week Ago"))
(gnc:reldate-string-db
'store 'one-week-ago-desc (N_ "One Week Ago."))
(gnc:reldate-string-db
'store 'three-months-ago-string
(N_ "Three Months Ago"))
(gnc:reldate-string-db
'store 'three-months-ago-desc (N_ "Three Months Ago."))
(gnc:reldate-string-db
'store 'six-months-ago-string
(N_ "Six Months Ago"))
(gnc:reldate-string-db
'store 'six-months-ago-desc (N_ "Six Months Ago."))
(gnc:reldate-string-db
'store 'one-year-ago-string (N_ "One Year Ago"))
(gnc:reldate-string-db
'store 'one-year-ago-desc (N_ "One Year Ago."))
(gnc:reldate-string-db
'store 'one-month-ahead-string
(N_ "One Month Ahead"))
(gnc:reldate-string-db
'store 'one-month-ahead-desc (N_ "One Month Ahead."))
(gnc:reldate-string-db
'store 'one-week-ahead-string
(N_ "One Week Ahead"))
(gnc:reldate-string-db
'store 'one-week-ahead-desc (N_ "One Week Ahead."))
(gnc:reldate-string-db
'store 'three-months-ahead-string
(N_ "Three Months Ahead"))
(gnc:reldate-string-db
'store 'three-months-ahead-desc (N_ "Three Months Ahead."))
(gnc:reldate-string-db
'store 'six-months-ahead-string
(N_ "Six Months Ahead"))
(gnc:reldate-string-db
'store 'six-months-ahead-desc (N_ "Six Months Ahead."))
(gnc:reldate-string-db
'store 'one-year-ahead-string (N_ "One Year Ahead"))
(gnc:reldate-string-db
'store 'one-year-ahead-desc (N_ "One Year Ahead."))
(set! gnc:relative-date-values
(list
(vector 'start-cal-year
@ -820,10 +1133,18 @@ Defaulting to today."))
(gnc:reldate-string-db 'lookup 'start-prev-year-string)
(gnc:reldate-string-db 'lookup 'start-prev-year-desc)
gnc:get-start-prev-year)
(vector 'start-next-year
(gnc:reldate-string-db 'lookup 'start-next-year-string)
(gnc:reldate-string-db 'lookup 'start-next-year-desc)
gnc:get-start-next-year)
(vector 'end-prev-year
(gnc:reldate-string-db 'lookup 'end-prev-year-string)
(gnc:reldate-string-db 'lookup 'end-prev-year-desc)
gnc:get-end-prev-year)
(vector 'end-next-year
(gnc:reldate-string-db 'lookup 'end-next-year-string)
(gnc:reldate-string-db 'lookup 'end-next-year-desc)
gnc:get-end-next-year)
(vector 'start-accounting-period
(gnc:reldate-string-db 'lookup 'start-accounting-period-string)
(gnc:reldate-string-db 'lookup 'start-accounting-period-desc)
@ -848,6 +1169,14 @@ Defaulting to today."))
(gnc:reldate-string-db 'lookup 'end-prev-month-string)
(gnc:reldate-string-db 'lookup 'end-prev-month-desc)
gnc:get-end-prev-month)
(vector 'start-next-month
(gnc:reldate-string-db 'lookup 'start-next-month-string)
(gnc:reldate-string-db 'lookup 'start-next-month-desc)
gnc:get-start-next-month)
(vector 'end-next-month
(gnc:reldate-string-db 'lookup 'end-next-month-string)
(gnc:reldate-string-db 'lookup 'end-next-month-desc)
gnc:get-end-next-month)
(vector 'start-current-quarter
(gnc:reldate-string-db 'lookup 'start-current-quarter-string)
(gnc:reldate-string-db 'lookup 'start-current-quarter-desc)
@ -864,11 +1193,50 @@ Defaulting to today."))
(gnc:reldate-string-db 'lookup 'end-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'end-prev-quarter-desc)
gnc:get-end-prev-quarter)
(vector 'start-next-quarter
(gnc:reldate-string-db 'lookup 'start-next-quarter-string)
(gnc:reldate-string-db 'lookup 'start-next-quarter-desc)
gnc:get-start-next-quarter)
(vector 'end-next-quarter
(gnc:reldate-string-db 'lookup 'end-next-quarter-string)
(gnc:reldate-string-db 'lookup 'end-next-quarter-desc)
gnc:get-end-next-quarter)
(vector 'today
(gnc:reldate-string-db 'lookup 'today-string)
(gnc:reldate-string-db 'lookup 'today-desc)
gnc:get-today)
))
(vector 'one-month-ago
(gnc:reldate-string-db 'lookup 'one-month-ago-string)
(gnc:reldate-string-db 'lookup 'one-month-ago-desc)
gnc:get-one-month-ago)
(vector 'three-months-ago
(gnc:reldate-string-db 'lookup 'three-months-ago-string)
(gnc:reldate-string-db 'lookup 'three-months-ago-desc)
gnc:get-three-months-ago)
(vector 'six-months-ago
(gnc:reldate-string-db 'lookup 'six-months-ago-string)
(gnc:reldate-string-db 'lookup 'six-months-ago-desc)
gnc:get-three-months-ago)
(vector 'one-year-ago
(gnc:reldate-string-db 'lookup 'one-year-ago-string)
(gnc:reldate-string-db 'lookup 'one-year-ago-desc)
gnc:get-one-year-ago)
(vector 'one-month-ahead
(gnc:reldate-string-db 'lookup 'one-month-ahead-string)
(gnc:reldate-string-db 'lookup 'one-month-ahead-desc)
gnc:get-one-month-ahead)
(vector 'three-months-ahead
(gnc:reldate-string-db 'lookup 'three-months-ahead-string)
(gnc:reldate-string-db 'lookup 'three-months-ahead-desc)
gnc:get-three-months-ahead)
(vector 'six-months-ahead
(gnc:reldate-string-db 'lookup 'six-months-ahead-string)
(gnc:reldate-string-db 'lookup 'six-months-ahead-desc)
gnc:get-three-months-ahead)
(vector 'one-year-ahead
(gnc:reldate-string-db 'lookup 'one-year-ahead-string)
(gnc:reldate-string-db 'lookup 'one-year-ahead-desc)
gnc:get-one-year-ahead)))
;; initialise gnc:relative-date-hash
(set! gnc:relative-date-hash (make-hash-table))

21
libgnucash/engine/Account.cpp
View File

@ -3986,6 +3986,27 @@ xaccAccountGetSplitList (const Account *acc)
return GET_PRIVATE(acc)->splits;
}
gint64
xaccAccountCountSplits (const Account *acc, gboolean include_children)
{
gint64 nr, i;
PWARN ("xaccAccountCountSplits is deprecated and will be removed \
in GnuCash 5.0. If testing for an empty account, use \
xaccAccountGetSplitList(account) == NULL instead. To test descendants \
as well, use gnc_account_and_descendants_empty.");
g_return_val_if_fail(GNC_IS_ACCOUNT(acc), 0);
nr = g_list_length(xaccAccountGetSplitList(acc));
if (include_children && (gnc_account_n_children(acc) != 0))
{
for (i=0; i < gnc_account_n_children(acc); i++)
{
nr += xaccAccountCountSplits(gnc_account_nth_child(acc, i), TRUE);
}
}
return nr;
}
gboolean gnc_account_and_descendants_empty (Account *acc)
{

12
libgnucash/engine/Account.h
View File

@ -1050,6 +1050,18 @@ gboolean xaccAccountIsEquityType(GNCAccountType t);
*/
SplitList* xaccAccountGetSplitList (const Account *account);
/** The xaccAccountCountSplits() routine returns the number of all
* the splits in the account. xaccAccountCountSplits is O(N). if
* testing for emptiness, use xaccAccountGetSplitList != NULL.
* @param acc the account for which to count the splits
*
* @param include_children also count splits in descendants (TRUE) or
* for this account only (FALSE).
*/
gint64 xaccAccountCountSplits (const Account *acc, gboolean include_children);
/** The xaccAccountMoveAllSplits() routine reassigns each of the splits
* in accfrom to accto. */
void xaccAccountMoveAllSplits (Account *accfrom, Account *accto);

10
libgnucash/tax/CMakeLists.txt
View File

@ -73,6 +73,16 @@ gnc_add_scheme_targets(scm-tax-de_DE-3
OUTPUT_DIR "gnucash/locale/de_DE"
DEPENDS "scm-tax-de_DE-2;${GUILE_DEPENDS}")
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash tax de_DE"
NEW_MODULE "gnucash locale de_DE tax"
DEPENDS "scm-tax-de_DE-3")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash tax us"
NEW_MODULE "gnucash locale us tax"
DEPENDS "scm-tax-us-3")
add_custom_target(scm-locale-tax ALL DEPENDS scm-tax-us-1 scm-tax-us-2 scm-tax-us-3 scm-tax-de_DE-1 scm-tax-de_DE-2 scm-tax-de_DE-3)
set(de_DE_tax_EXTRA_DIST

10
po/POTFILES.in
View File

@ -9,6 +9,7 @@ bindings/guile/gnc-engine-guile.c
bindings/guile/gnc-guile-bindings.c
bindings/guile/gnc-guile-utils.c
bindings/guile/gnc-kvp-guile.cpp
bindings/guile/gnc-module.scm
bindings/guile/gnc-numeric.scm
bindings/guile/utilities.scm
bindings/python/app_utils.py
@ -442,9 +443,13 @@ gnucash/report/eguile-utilities.scm
gnucash/report/gnc-report.c
gnucash/report/html-acct-table.scm
gnucash/report/html-anytag.scm
gnucash/report/html-barchart.scm
gnucash/report/html-chart.scm
gnucash/report/html-document.scm
gnucash/report/html-fonts.scm
gnucash/report/html-linechart.scm
gnucash/report/html-piechart.scm
gnucash/report/html-scatter.scm
gnucash/report/html-style-info.scm
gnucash/report/html-style-sheet.scm
gnucash/report/html-table.scm
@ -453,6 +458,7 @@ gnucash/report/html-utilities.scm
gnucash/report/options-utilities.scm
gnucash/report/report-core.scm
gnucash/report/report-register-hooks.scm
gnucash/report/reports/aging.scm
gnucash/report/reports/cash-flow-calc.scm
gnucash/report/reports/example/average-balance.scm
gnucash/report/reports/example/daily-reports.scm
@ -486,13 +492,17 @@ gnucash/report/reports/standard/ifrs-cost-basis.scm
gnucash/report/reports/standard/income-gst-statement.scm
gnucash/report/reports/standard/income-statement.scm
gnucash/report/reports/standard/invoice.scm
gnucash/report/reports/standard/job-report.scm
gnucash/report/reports/standard/lot-viewer.scm
gnucash/report/reports/standard/net-charts.scm
gnucash/report/reports/standard/new-aging.scm
gnucash/report/reports/standard/new-owner-report.scm
gnucash/report/reports/standard/owner-report.scm
gnucash/report/reports/standard/payables.scm
gnucash/report/reports/standard/portfolio.scm
gnucash/report/reports/standard/price-scatter.scm
gnucash/report/reports/standard/receipt.scm
gnucash/report/reports/standard/receivables.scm
gnucash/report/reports/standard/reconcile-report.scm
gnucash/report/reports/standard/register.scm
gnucash/report/reports/standard/taxinvoice.scm