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

Merge Stefan Bayer's 'SepaInternalTransfer' into maint.

Browse Source
This commit is contained in:
John Ralls
2021-12-03 13:11:28 -08:00
parent b8458d0732 05513747ee
commit 17a3f7fef2
62 changed files with 1066 additions and 5332 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
bindings/guile/CMakeLists.txt
View File

@@ -127,14 +127,6 @@ 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,7 +30,6 @@
(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)
@@ -105,37 +104,9 @@
(gnc:owner-get-owner-id (gncJobGetOwner (gncOwnerGetJob owner))))
(else ""))))
;; 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.
;; 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.
(define gnc:split->owner
(let ((ht (make-hash-table)))
(lambda (split)

41
bindings/guile/engine.scm
View File

@@ -30,44 +30,3 @@
(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
View File

@@ -1,88 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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,7 +31,6 @@ 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)
@@ -41,12 +40,6 @@ 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"
@@ -69,12 +62,6 @@ 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"
@@ -91,7 +78,6 @@ set(test_scm_SCHEME
)
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-engine
scm-srfi64-extras
@@ -130,6 +116,7 @@ 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,57 +242,4 @@
(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,10 +11,4 @@
(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,25 +7,12 @@
(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")
@@ -34,35 +21,6 @@
"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,8 +32,6 @@
(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)
@@ -66,22 +64,6 @@
(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
@@ -126,26 +108,6 @@
(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.