mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Remove guile functions that were marked as deprecated in gnucash the 3.x series
This commit is contained in:
Geert Janssens
parent
306964797b
commit
30ac2cf266
@ -50,15 +50,7 @@ set (report_system_SCHEME
|
||||
eguile-html-utilities.scm
|
||||
)
|
||||
|
||||
set (report_system_SCHEME_2a
|
||||
collectors.scm
|
||||
)
|
||||
|
||||
set (report_system_SCHEME_2b
|
||||
report-collectors.scm
|
||||
)
|
||||
|
||||
set (report_system_SCHEME_3
|
||||
set (report_system_SCHEME_2
|
||||
commodity-utilities.scm
|
||||
html-acct-table.scm
|
||||
html-chart.scm
|
||||
@ -97,34 +89,19 @@ gnc_add_scheme_targets(scm-report-system-1
|
||||
FALSE
|
||||
)
|
||||
|
||||
gnc_add_scheme_targets(scm-report-system-2a
|
||||
"${report_system_SCHEME_2a}"
|
||||
"gnucash/report/report-system"
|
||||
gnc_add_scheme_targets(scm-report-system-2
|
||||
"${report_system_SCHEME_2}"
|
||||
""
|
||||
scm-report-system-1
|
||||
FALSE
|
||||
)
|
||||
|
||||
gnc_add_scheme_targets(scm-report-system-2b
|
||||
"${report_system_SCHEME_2b}"
|
||||
"gnucash/report/report-system"
|
||||
scm-report-system-2a
|
||||
FALSE
|
||||
)
|
||||
|
||||
gnc_add_scheme_targets(scm-report-system-3
|
||||
"${report_system_SCHEME_3}"
|
||||
""
|
||||
scm-report-system-2b
|
||||
FALSE
|
||||
)
|
||||
|
||||
add_custom_target(scm-report-system ALL DEPENDS scm-report-system-3)
|
||||
add_custom_target(scm-report-system ALL DEPENDS scm-report-system-2)
|
||||
|
||||
set_local_dist(report_system_DIST_local CMakeLists.txt
|
||||
report-system.i
|
||||
${report_system_HEADERS} ${report_system_SOURCES}
|
||||
${report_system_SCHEME} ${report_system_SCHEME_1}
|
||||
${report_system_SCHEME_2a} ${report_system_SCHEME_2b}
|
||||
${report_system_SCHEME_3})
|
||||
${report_system_SCHEME_2})
|
||||
|
||||
set(report_system_DIST ${report_system_DIST_local} ${test_report_system_DIST} PARENT_SCOPE)
|
||||
|
||||
@ -1,351 +0,0 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 report-system collectors))
|
||||
|
||||
(issue-deprecation-warning
|
||||
"(gnucash report report-system collectors) is deprecated.")
|
||||
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(export make-filter)
|
||||
(export filter-satisfies)
|
||||
(export filter-id)
|
||||
(export assert-filter)
|
||||
(export make-equal-filter)
|
||||
(export make-predicate-filter)
|
||||
|
||||
(export make-collector)
|
||||
(export collector-accumulate-from)
|
||||
(export collector-count-from)
|
||||
(export collector-into-list)
|
||||
(export collector-per-property)
|
||||
(export collector-filtered-list)
|
||||
(export collector-split)
|
||||
(export make-mapper-collector)
|
||||
(export make-list-collector)
|
||||
(export collector-from-slotset)
|
||||
(export labelled-collector-from-slotset)
|
||||
(export collector-add)
|
||||
(export collector-end)
|
||||
(export assert-collector)
|
||||
(export collector-add-all)
|
||||
(export collector-where)
|
||||
(export collector-reformat)
|
||||
(export collector-print)
|
||||
(export collector-do)
|
||||
(export function-state->collector)
|
||||
(export make-eq-set-collector)
|
||||
(export make-extreme-collector)
|
||||
|
||||
(export make-slotset)
|
||||
(export slotset?)
|
||||
(export slotset-slots)
|
||||
(export slotset-slot)
|
||||
(export hashmap->slotset)
|
||||
(export alist->slotset)
|
||||
(export slotset-check)
|
||||
(export slotset-map-input)
|
||||
|
||||
(export binary-search-lt)
|
||||
|
||||
;; Filters
|
||||
(define (make-filter id predicate)
|
||||
(list 'filter id predicate))
|
||||
|
||||
(define (filter? filter)
|
||||
(eq? (car filter) 'filter))
|
||||
|
||||
(define (assert-filter filter)
|
||||
(if (filter? filter) #t
|
||||
(throw (list "not a filter" filter))))
|
||||
|
||||
(define (filter-satisfies filter object)
|
||||
(assert-filter filter)
|
||||
(let ((predicate (third filter)))
|
||||
(predicate object)))
|
||||
|
||||
(define (filter-id filter)
|
||||
(assert-filter filter)
|
||||
(second filter))
|
||||
|
||||
(define (make-predicate-filter id predicate)
|
||||
(make-filter id predicate))
|
||||
|
||||
|
||||
(define (make-equal-filter x)
|
||||
(make-filter x
|
||||
(lambda (value)
|
||||
(equal? x value))))
|
||||
|
||||
;;
|
||||
;; SlotSet
|
||||
;;
|
||||
|
||||
(define (make-slotset value->slot slots)
|
||||
(if (not (procedure? value->slot))
|
||||
(throw 'not-a-procedure value->slot))
|
||||
(if (not (pair? slots))
|
||||
(throw 'not-a-list slots))
|
||||
(list 'slotset value->slot slots))
|
||||
|
||||
(define (slotset? slotset)
|
||||
(eq? (car slotset) 'slotset))
|
||||
|
||||
(define (assert-slotset slotset)
|
||||
(if (slotset? slotset) #t
|
||||
(throw (list "not a slotset" slotset))))
|
||||
|
||||
(define (slotset-slots slotset)
|
||||
(assert-slotset slotset)
|
||||
(third slotset))
|
||||
|
||||
(define (slotset-slot slotset value)
|
||||
(assert-slotset slotset)
|
||||
((second slotset) value))
|
||||
|
||||
(define (slotset-map-input mapfn orig-slotset)
|
||||
(let ((orig-slotset-slot (second orig-slotset))
|
||||
(orig-slotset-slots (third orig-slotset)))
|
||||
(make-slotset (lambda (v) (orig-slotset-slot (mapfn v)))
|
||||
orig-slotset-slots)))
|
||||
|
||||
(define (hashmap->slotset hashmap)
|
||||
(make-slotset (lambda (v)
|
||||
(hash-ref hashmap v))
|
||||
(hashmap->list (lambda (key value) value) hashmap)))
|
||||
|
||||
(define (alist->slotset alist)
|
||||
(make-slotset (lambda (v) (assoc-ref alist v))
|
||||
(hash-map->list (lambda (key value) key)
|
||||
(fold (lambda (val h)
|
||||
(hash-set! h val val)
|
||||
h)
|
||||
(make-hash-table)
|
||||
(map cdr alist)))))
|
||||
|
||||
(define (slotset-check slotset)
|
||||
(assert-slotset slotset)
|
||||
(make-slotset (lambda (value)
|
||||
(let ((result (slotset-slot value)))
|
||||
(if (member result (third slotset))
|
||||
(throw (list 'slotset-to-non-value))
|
||||
result)))
|
||||
(third slotset)))
|
||||
;;
|
||||
;; Collectors
|
||||
;;
|
||||
|
||||
(define (make-collector f1 f2)
|
||||
(list 'collector f1 f2))
|
||||
|
||||
(define (collector-add collector value)
|
||||
(assert-collector collector)
|
||||
(let ((result ((second collector) value)))
|
||||
(assert-collector result)
|
||||
result))
|
||||
|
||||
(define (collector-end collector)
|
||||
(assert-collector collector)
|
||||
(let ((fn (third collector)))
|
||||
(fn)))
|
||||
|
||||
(define (collector-print stream name collector)
|
||||
(make-collector (lambda (value) (format stream "(add ~a ~a)\n" name value)
|
||||
(collector-print stream name (collector-add collector value)))
|
||||
(lambda () (let ((result (collector-end collector)))
|
||||
(format stream "(result ~a ~a)\n" name result)
|
||||
result))))
|
||||
|
||||
|
||||
(define (collector? collector)
|
||||
(and (list? collector)
|
||||
(eq? (car collector) 'collector)))
|
||||
|
||||
(define (assert-collector collector)
|
||||
(if (collector? collector) #t
|
||||
(throw 'error (list "not a collector" collector))))
|
||||
|
||||
(define (collector-add-all collector values)
|
||||
(if (null-list? values) (collector-end collector)
|
||||
(collector-add-all (collector-add collector (car values))
|
||||
(cdr values))))
|
||||
|
||||
(define (collector-accumulate-from total)
|
||||
(make-collector (lambda (x) (collector-accumulate-from (+ total x)))
|
||||
(lambda () total)))
|
||||
|
||||
(define (collector-count-from total)
|
||||
(make-collector (lambda (x) (collector-count-from (+ total 1)))
|
||||
(lambda () total)))
|
||||
|
||||
(define (collector-into-list)
|
||||
(define (collect-into l)
|
||||
(make-collector (lambda (x) (collect-into (cons x l)))
|
||||
(lambda () (reverse! l))))
|
||||
(collect-into '()))
|
||||
|
||||
(define (collector-per-property items make-property-filter make-per-property-collector)
|
||||
(let ((collectors (map (lambda (item)
|
||||
(cons (make-property-filter item)
|
||||
(make-per-property-collector item)))
|
||||
items)))
|
||||
(collector-filtered-list collectors)))
|
||||
|
||||
(define (collector-filtered-list filter-collector-pairs)
|
||||
(define (mapfn sublist value)
|
||||
(let ((pair (car sublist))
|
||||
(rest (cdr sublist)))
|
||||
(if (filter-satisfies (car pair) value)
|
||||
(cons (cons (car pair) (collector-add (cdr pair) value))
|
||||
rest)
|
||||
(cons pair (mapfn rest value)))))
|
||||
(make-collector
|
||||
(lambda (value)
|
||||
(collector-filtered-list (mapfn filter-collector-pairs value)))
|
||||
(lambda () (map (lambda (pair)
|
||||
(cons (filter-id (car pair))
|
||||
(collector-end (cdr pair))))
|
||||
filter-collector-pairs))))
|
||||
|
||||
;; Breaks a sequence of items into a list of collectors by property
|
||||
|
||||
(define (collector-split prop-fn make-per-split-collector)
|
||||
(let ((list '()))
|
||||
(define collector (make-collector (lambda (value)
|
||||
(let* ((prop (prop-fn value))
|
||||
(elt (assoc prop list)))
|
||||
(if elt
|
||||
(begin
|
||||
(set-cdr! elt (collector-add (cdr elt) value))
|
||||
collector)
|
||||
(begin (set! list (cons (cons prop
|
||||
(collector-add (make-per-split-collector prop)
|
||||
value))
|
||||
list))
|
||||
collector))))
|
||||
(lambda ()
|
||||
(map (lambda (pair) (cons (car pair)
|
||||
(collector-end (cdr pair))))
|
||||
list))))
|
||||
collector))
|
||||
|
||||
(define (make-eq-set-collector list)
|
||||
(define collector (make-collector
|
||||
(lambda (value)
|
||||
(if (memq value list) collector
|
||||
(make-eq-set-collector (cons value list))))
|
||||
(lambda () list)))
|
||||
collector)
|
||||
|
||||
(define (make-extreme-collector ordering current)
|
||||
(define collector (make-collector (lambda (value)
|
||||
(if (ordering value current)
|
||||
(make-extreme-collector ordering value)
|
||||
collector))
|
||||
(lambda () current)))
|
||||
collector)
|
||||
|
||||
|
||||
(define (collector-where pred collector)
|
||||
(define new-collector
|
||||
(make-collector (lambda (value)
|
||||
(if (pred value)
|
||||
(begin ;(format #t "accept ~a\n" value)
|
||||
(collector-where pred
|
||||
(collector-add collector value)))
|
||||
new-collector))
|
||||
(lambda () (collector-end collector))))
|
||||
new-collector)
|
||||
|
||||
(define (make-mapper-collector mapfn collector)
|
||||
(make-collector (lambda (value)
|
||||
(make-mapper-collector mapfn (collector-add collector (mapfn value))))
|
||||
(lambda () (collector-end collector))))
|
||||
|
||||
(define (collector-reformat formatter collector)
|
||||
(make-collector (lambda (value)
|
||||
(collector-reformat formatter (collector-add collector value)))
|
||||
(lambda () (formatter (collector-end collector)))))
|
||||
|
||||
|
||||
(define (make-list-collector collectors)
|
||||
(make-collector (lambda (value)
|
||||
(make-list-collector (map (lambda (inner-collector)
|
||||
(collector-add inner-collector value))
|
||||
collectors)))
|
||||
(lambda () (map collector-end collectors))))
|
||||
|
||||
|
||||
(define (collector-from-slotset slotset slot-collector)
|
||||
(define (make-table)
|
||||
(let ((valuemap (make-hash-table)))
|
||||
(for-each (lambda (slot)
|
||||
(hash-set! valuemap slot (slot-collector slot)))
|
||||
(slotset-slots slotset))
|
||||
valuemap))
|
||||
(let ((valuemap (make-table)))
|
||||
(define collector
|
||||
(make-collector (lambda (value)
|
||||
(let* ((slot (slotset-slot slotset value)))
|
||||
(hash-set! valuemap slot
|
||||
(collector-add (hash-ref valuemap slot)
|
||||
value)))
|
||||
collector)
|
||||
(lambda () (map (lambda (slot)
|
||||
(collector-end (hash-ref valuemap slot)))
|
||||
(slotset-slots slotset)))))
|
||||
collector))
|
||||
|
||||
(define (labelled-collector-from-slotset slotset slot-collector)
|
||||
(collector-from-slotset slotset
|
||||
(lambda (slot)
|
||||
(collector-reformat (lambda (result)
|
||||
(cons slot result))
|
||||
(slot-collector slot)))))
|
||||
|
||||
|
||||
(define (function-state->collector fn state)
|
||||
(make-collector (lambda (value)
|
||||
(let ((next (fn value state)))
|
||||
(function-state->collector fn next)))
|
||||
(lambda ()
|
||||
state)))
|
||||
|
||||
(define (collector-do collector . other-collectors)
|
||||
(collector-reformat (lambda (final)
|
||||
(car final))
|
||||
(make-list-collector (cons collector other-collectors))))
|
||||
|
||||
|
||||
;; Binary search. Returns highest index with content less than or
|
||||
;; equal to the supplied value.
|
||||
|
||||
(define (binary-search-lt <= val vec)
|
||||
(and (not (zero? (vector-length vec)))
|
||||
(let loop ((low 0)
|
||||
(high (1- (vector-length vec))))
|
||||
(let* ((midpoint (ceiling (/ (+ low high) 2)))
|
||||
(midvalue (vector-ref vec midpoint)))
|
||||
(if (= low high)
|
||||
(and (<= midvalue val)
|
||||
low)
|
||||
(if (<= midvalue val)
|
||||
(loop midpoint high)
|
||||
(loop low (1- midpoint))))))))
|
||||
@ -76,13 +76,6 @@
|
||||
;; Functions to create some list of prices from data in transactions.
|
||||
|
||||
|
||||
;; Helper for warnings below.
|
||||
(define (gnc-commodity-numeric->string commodity numeric)
|
||||
(issue-deprecation-warning "gnc-commodity-numeric->string deprecated. \
|
||||
construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary commodity numeric)))
|
||||
|
||||
;; Helper for exchange below
|
||||
(define (gnc:exchange-by-euro-numeric
|
||||
foreign-commodity foreign-numeric domestic date)
|
||||
@ -266,31 +259,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
(loop result
|
||||
(cdr commodity-splits))))))))
|
||||
|
||||
;; Get the instantaneous prices for all commodities in
|
||||
;; 'commodity-list', i.e. the same thing as get-commodity-inst-prices
|
||||
;; but extended to a commodity-list. Returns an alist. Each pair
|
||||
;; consists of the foreign-currency and the appropriate list from
|
||||
;; gnc:get-commodity-inst-prices, see there.
|
||||
(define (gnc:get-commoditylist-inst-prices
|
||||
commodity-list report-currency end-date
|
||||
start-percent delta-percent)
|
||||
(issue-deprecation-warning
|
||||
"gnc:get-commoditylist-inst-prices is deprecated.")
|
||||
(let ((currency-accounts
|
||||
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
|
||||
(work-to-do (length commodity-list)))
|
||||
(map
|
||||
(lambda (c work-done)
|
||||
(if start-percent
|
||||
(gnc:report-percent-done
|
||||
(+ start-percent (* delta-percent (/ work-done work-to-do)))))
|
||||
(cons c
|
||||
(gnc:get-commodity-inst-prices
|
||||
currency-accounts end-date c report-currency)))
|
||||
commodity-list
|
||||
(iota work-to-do))))
|
||||
|
||||
|
||||
;; Find the price in 'pricelist' that's nearest to 'date'. The
|
||||
;; pricelist comes from
|
||||
;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or,
|
||||
@ -704,50 +672,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
(* (gnc:gnc-monetary-amount foreign) (cadr pair))
|
||||
0)))))))
|
||||
|
||||
;; Helper for the gnc:exchange-by-pricalist* below. Exchange the
|
||||
;; <gnc:monetary> 'foreign' into the <gnc:commodity*> 'domestic' by
|
||||
;; the <gnc:numeric> 'price-value'. Returns a <gnc:monetary>.
|
||||
(define (gnc:exchange-by-pricevalue-helper
|
||||
foreign domestic price-value)
|
||||
(issue-deprecation-warning
|
||||
"gnc:exchange-by-pricevalue-helper is deprecated. please inline function.")
|
||||
(and (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price-value
|
||||
(* (gnc:gnc-monetary-amount foreign)
|
||||
price-value)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricevalue-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic 0)))
|
||||
0)))))
|
||||
|
||||
;; Helper for gnc:exchange-by-pricedb-* below. 'price' gets tested for
|
||||
;; #f here, and gets unref'd here too. Exchange the <gnc:monetary>
|
||||
;; 'foreign' into the <gnc:commodity*> 'domestic' by the <gnc:Price>
|
||||
;; 'price'. Returns a <gnc:monetary>.
|
||||
(define (gnc:exchange-by-pricedb-helper
|
||||
foreign domestic price)
|
||||
(issue-deprecation-warning
|
||||
"gnc:exchange-by-pricedb-helper is deprecated.")
|
||||
(and (gnc:gnc-monetary? foreign)
|
||||
(gnc:make-gnc-monetary
|
||||
domestic
|
||||
(if price
|
||||
(let ((result
|
||||
(* (gnc:gnc-monetary-amount foreign)
|
||||
(gnc-price-get-value price))))
|
||||
(gnc-price-unref price)
|
||||
result)
|
||||
(begin
|
||||
(warn "gnc:exchange-by-pricedb-helper: No price found for "
|
||||
(gnc:monetary->string foreign) " into "
|
||||
(gnc:monetary->string
|
||||
(gnc:make-gnc-monetary domestic 0)))
|
||||
0)))))
|
||||
|
||||
;; This is another ready-to-use function for calculation of exchange
|
||||
;; rates. (Note that this is already the function itself. It doesn't
|
||||
;; return a function as opposed to make-exchange-function.) It takes
|
||||
@ -876,18 +800,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
(lambda (foreign domestic date)
|
||||
(gnc:exchange-by-pricealist-nearest
|
||||
pricealist foreign domestic date))))
|
||||
;; actual-transactions isn't used, at least not as a value passed to this
|
||||
;; function. price-scatter.scm does use it but calls
|
||||
;; gnc:get-commodity-inst-prices directly.
|
||||
((actual-transactions) (let ((pricealist
|
||||
(gnc:get-commoditylist-inst-prices
|
||||
commodity-list report-currency to-date-tp
|
||||
start-percent delta-percent)))
|
||||
(issue-deprecation-warning
|
||||
"this path is never reached in code.")
|
||||
(lambda (foreign domestic date)
|
||||
(gnc:exchange-by-pricealist-nearest
|
||||
pricealist foreign domestic date))))
|
||||
((pricedb-latest) (lambda (foreign domestic date)
|
||||
(gnc:exchange-by-pricedb-latest foreign domestic)))
|
||||
((pricedb-nearest) gnc:exchange-by-pricedb-nearest)
|
||||
@ -961,18 +873,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
|
||||
#f)
|
||||
balance)))
|
||||
|
||||
(define (gnc-commodity-collector-commodity-count collector)
|
||||
(issue-deprecation-warning
|
||||
"gnc-commodity-collector-commodity-count is deprecated. please inline.")
|
||||
(length (collector 'format (lambda (comm amt) comm) #f)))
|
||||
|
||||
(define (gnc-commodity-collector-contains-commodity? collector commodity)
|
||||
(issue-deprecation-warning
|
||||
"gnc-commodity-collector-contains-commodity? is deprecated. please inline.")
|
||||
(member commodity
|
||||
(collector 'format (lambda (comm amt) comm) #f)
|
||||
gnc-commodity-equiv))
|
||||
|
||||
(define (gnc:uniform-commodity? amt report-commodity)
|
||||
;; function to see if the commodity-collector amt
|
||||
;; contains any foreign commodities
|
||||
|
||||
@ -118,28 +118,6 @@
|
||||
default-accounts
|
||||
#f #t)))
|
||||
|
||||
;; The single checkbox whether to include the sub-account balances
|
||||
;; into the other balances.
|
||||
(define (gnc:options-add-include-subaccounts!
|
||||
options pagename optname sort-tag)
|
||||
(issue-deprecation-warning "gnc:options-add-include-subaccounts! is deprecated.")
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename optname
|
||||
sort-tag (N_ "Include sub-account balances in printed balance?") #t)))
|
||||
|
||||
;; The single checkbox whether to group the accounts into main
|
||||
;; categories and ahow a subtotal for those.
|
||||
(define (gnc:options-add-group-accounts!
|
||||
options pagename optname sort-tag default?)
|
||||
(issue-deprecation-warning "gnc:options-add-group-accounts! is deprecated.")
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename optname
|
||||
sort-tag (N_ "Group the accounts in main categories?") default?)))
|
||||
|
||||
;; To let the user select a currency for the report.
|
||||
(define (gnc:options-add-currency!
|
||||
options pagename name-report-currency sort-tag)
|
||||
@ -151,22 +129,6 @@
|
||||
(N_ "Select the currency to display the values of this report in.")
|
||||
(gnc-default-report-currency))))
|
||||
|
||||
;; These are common options for the selection of the report's
|
||||
;; currency/commodity.
|
||||
(define (gnc:options-add-currency-selection!
|
||||
options pagename
|
||||
name-show-foreign name-report-currency sort-tag)
|
||||
(issue-deprecation-warning "gnc:options-add-currency-selection! is deprecated.")
|
||||
(gnc:register-option
|
||||
options
|
||||
(gnc:make-simple-boolean-option
|
||||
pagename name-show-foreign
|
||||
(string-append sort-tag "a")
|
||||
(N_ "Display the account's foreign currency amount?") #f))
|
||||
|
||||
(gnc:options-add-currency! options pagename name-report-currency
|
||||
(string-append sort-tag "b")))
|
||||
|
||||
;; A multichoice option for the source of prices
|
||||
(define (gnc:options-add-price-source!
|
||||
options pagename optname sort-tag default)
|
||||
|
||||
@ -1,231 +0,0 @@
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 report-system report-collectors))
|
||||
|
||||
(issue-deprecation-warning
|
||||
"(gnucash report report-system report-collectors) is deprecated.")
|
||||
|
||||
(use-modules (gnucash gnc-module))
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
(use-modules (ice-9 format))
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(use-modules (gnucash utilities))
|
||||
(use-modules (gnucash report report-system))
|
||||
(use-modules (gnucash app-utils))
|
||||
(use-modules (gnucash engine))
|
||||
(use-modules (gnucash report report-system collectors))
|
||||
|
||||
(export account-destination-alist)
|
||||
(export category-by-account-report)
|
||||
(export category-by-account-report-work)
|
||||
(export category-by-account-report-do-work)
|
||||
(export make-gnc-collector-collector)
|
||||
|
||||
(export splits-up-to)
|
||||
(export split->commodity)
|
||||
|
||||
(define (split->commodity split)
|
||||
(xaccAccountGetCommodity (xaccSplitGetAccount split)))
|
||||
|
||||
(define (split->date split)
|
||||
(xaccTransGetDate (xaccSplitGetParent split)))
|
||||
|
||||
(define (split->account split)
|
||||
(xaccSplitGetAccount split))
|
||||
|
||||
(define (split-closing? split)
|
||||
(xaccTransGetIsClosingTxn (xaccSplitGetParent split)))
|
||||
|
||||
(define (splits-up-to accounts startdate enddate)
|
||||
(gnc:account-get-trans-type-splits-interval accounts #f
|
||||
startdate
|
||||
enddate))
|
||||
|
||||
(define (make-gnc-collector-collector)
|
||||
(let ((gnc-collector (gnc:make-commodity-collector)))
|
||||
(define collector
|
||||
(make-collector (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (split->commodity split)))
|
||||
(gnc-collector 'add acct-comm shares)
|
||||
collector))
|
||||
(lambda () gnc-collector)))
|
||||
collector))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Plan:
|
||||
;; We create reports via collectors - effectively per account, per date stores of values.
|
||||
;; Values are held as report-system/collector objects (sorry about the name reuse..),
|
||||
;; which can then be evaluated by a collector-reformat step.
|
||||
;;
|
||||
;; For a given report, we want to retrieve relevant transactions once
|
||||
;; (this is the splits-up-to function), and then push the transactions
|
||||
;; into a collector structure. This way there's no O(n^2) or worse
|
||||
;; complexity.
|
||||
|
||||
(define (build-account-collector account-destination-alist
|
||||
per-account-collector)
|
||||
(let ((slotset (slotset-map-input split->account
|
||||
(alist->slotset account-destination-alist))))
|
||||
(collector-from-slotset slotset per-account-collector)))
|
||||
|
||||
(define (build-date-collector dates per-date-collector)
|
||||
(let* ((date-vector (list->vector dates))
|
||||
(slotset (make-slotset (lambda (split)
|
||||
(let* ((date (split->date split))
|
||||
(interval-index (binary-search-lt (lambda (pair date)
|
||||
(or (not (car pair))
|
||||
(<= (car pair) date)))
|
||||
date
|
||||
date-vector))
|
||||
(interval (vector-ref date-vector interval-index)))
|
||||
interval))
|
||||
dates)))
|
||||
(collector-from-slotset slotset per-date-collector)))
|
||||
|
||||
(define (build-category-by-account-collector account-destination-alist dates cell-accumulator result-collector)
|
||||
(build-account-collector account-destination-alist
|
||||
(lambda (account)
|
||||
(collector-reformat (lambda (result)
|
||||
(list account (result-collector account result)))
|
||||
(build-date-collector dates
|
||||
(lambda (date)
|
||||
(cell-accumulator account date)))))))
|
||||
|
||||
(define (category-by-account-report do-intervals? datepairs account-alist
|
||||
split-collector result-collector progress-range)
|
||||
(let* ((work (category-by-account-report-work do-intervals? datepairs
|
||||
account-alist split-collector result-collector))
|
||||
(splits-fn (car work))
|
||||
(collector (cdr work))
|
||||
(splits (splits-fn)))
|
||||
(collector-add-all (collector-do collector
|
||||
(progress-collector (length splits) progress-range))
|
||||
splits)))
|
||||
|
||||
(define (category-by-account-report-do-work work progress-range)
|
||||
(let* ((splits-fn (car work))
|
||||
(collector (cdr work))
|
||||
(splits (splits-fn)))
|
||||
(collector-add-all (collector-do collector
|
||||
(progress-collector (length splits) progress-range))
|
||||
splits)))
|
||||
|
||||
;; Decide how to run the given report (but don't actually do any work)
|
||||
|
||||
(define (category-by-account-report-work do-intervals? dates account-alist
|
||||
split-collector result-collector)
|
||||
(let* ((dateinfo (if do-intervals?
|
||||
(category-report-dates-intervals dates)
|
||||
(category-report-dates-accumulate dates)))
|
||||
(processed-dates (third dateinfo))
|
||||
(splits-fn (lambda () (category-report-splits dateinfo account-alist)))
|
||||
(collector (collector-where (lambda (split) (not (split-closing? split)))
|
||||
(build-category-by-account-collector account-alist
|
||||
processed-dates split-collector
|
||||
result-collector))))
|
||||
(cons splits-fn collector)))
|
||||
|
||||
(define (category-report-splits dateinfo account-alist)
|
||||
(let ((min-date (first dateinfo))
|
||||
(max-date (second dateinfo)))
|
||||
(splits-up-to (map car account-alist) min-date max-date)))
|
||||
|
||||
(define (category-report-dates-intervals dates)
|
||||
(let* ((min-date (apply min (map first dates)))
|
||||
(max-date (apply max (map second dates))))
|
||||
(list min-date max-date dates)))
|
||||
|
||||
(define (category-report-dates-accumulate dates)
|
||||
(let* ((min-date #f)
|
||||
(max-date (apply max dates))
|
||||
(datepairs (reverse! (cdr (fold (lambda (next acc)
|
||||
(let ((prev (car acc))
|
||||
(pairs-so-far (cdr acc)))
|
||||
(cons next (cons (list prev next) pairs-so-far))))
|
||||
(cons min-date '()) dates)))))
|
||||
(list min-date max-date datepairs)))
|
||||
|
||||
|
||||
|
||||
(define (progress-collector size range)
|
||||
(let* ((from (car range))
|
||||
(to (cdr range))
|
||||
(width (- to from)))
|
||||
(define (count->percentage count)
|
||||
(+ (* width (/ count size)) from))
|
||||
(function-state->collector (lambda (value state)
|
||||
(let ((last (floor (count->percentage (- state 1))))
|
||||
(next (floor (count->percentage state))))
|
||||
(if (not (= last next))
|
||||
(gnc:report-percent-done (+ (* width (/ state size)) from)))
|
||||
(+ state 1)))
|
||||
0)))
|
||||
|
||||
(define (gnc-account-child-accounts-recursive account)
|
||||
(define (helper account initial)
|
||||
(fold (lambda (child-account accumulator)
|
||||
(append (helper child-account (list child-account))
|
||||
accumulator))
|
||||
initial
|
||||
(gnc-account-get-children account)))
|
||||
(helper account '()))
|
||||
|
||||
(define (traverse-accounts tree-depth show-acct? account-types)
|
||||
(define (inner-traverse-accounts current-depth accounts)
|
||||
(if (< current-depth tree-depth)
|
||||
(let ((res '()))
|
||||
(for-each
|
||||
(lambda (a)
|
||||
(begin
|
||||
(if (show-acct? a)
|
||||
(set! res
|
||||
(cons (cons a a) res)))
|
||||
(set! res (append
|
||||
(inner-traverse-accounts
|
||||
(+ 1 current-depth)
|
||||
(gnc-account-get-children a))
|
||||
res))))
|
||||
accounts)
|
||||
res)
|
||||
;; else (i.e. current-depth == tree-depth)
|
||||
(fold (lambda (account acc)
|
||||
(let ((child-accounts (gnc-account-child-accounts-recursive account)))
|
||||
(append (map (lambda (child-account)
|
||||
(cons child-account account))
|
||||
child-accounts)
|
||||
(list (cons account account))
|
||||
acc)))
|
||||
'()
|
||||
(filter show-acct? accounts))))
|
||||
(let* ((topl-accounts (gnc:filter-accountlist-type
|
||||
account-types
|
||||
(gnc-account-get-children-sorted
|
||||
(gnc-get-current-root-account))))
|
||||
(account-head-list (inner-traverse-accounts 1 topl-accounts)))
|
||||
account-head-list))
|
||||
|
||||
(define (account-destination-alist accounts account-types tree-depth)
|
||||
(define (show-acct? a)
|
||||
(member a accounts))
|
||||
(traverse-accounts tree-depth show-acct? account-types))
|
||||
@ -41,12 +41,10 @@
|
||||
(export gnc:get-match-commodity-splits)
|
||||
(export gnc:get-match-commodity-splits-sorted)
|
||||
(export gnc:get-all-commodity-splits )
|
||||
(export gnc-commodity-numeric->string)
|
||||
(export gnc:exchange-by-euro-numeric)
|
||||
(export gnc:get-commodity-totalavg-prices)
|
||||
(export gnc:get-commoditylist-totalavg-prices)
|
||||
(export gnc:get-commodity-inst-prices)
|
||||
(export gnc:get-commoditylist-inst-prices)
|
||||
(export gnc:pricelist-price-find-nearest)
|
||||
(export gnc:pricealist-lookup-nearest-in-time)
|
||||
(export gnc:resolve-unknown-comm)
|
||||
@ -57,8 +55,6 @@
|
||||
(export gnc:exchange-by-euro)
|
||||
(export gnc:exchange-if-same)
|
||||
(export gnc:make-exchange-function)
|
||||
(export gnc:exchange-by-pricevalue-helper) ;deprecated
|
||||
(export gnc:exchange-by-pricedb-helper)
|
||||
(export gnc:exchange-by-pricedb-latest )
|
||||
(export gnc:exchange-by-pricedb-nearest)
|
||||
(export gnc:exchange-by-pricealist-nearest)
|
||||
@ -66,7 +62,6 @@
|
||||
(export gnc:case-exchange-time-fn)
|
||||
(export gnc:sum-collector-commodity)
|
||||
(export gnc:sum-collector-stocks)
|
||||
(export gnc-commodity-collector-contains-commodity?) ;deprecated
|
||||
|
||||
;; options-utilities.scm
|
||||
|
||||
@ -75,10 +70,7 @@
|
||||
(export gnc:options-add-interval-choice!)
|
||||
(export gnc:options-add-account-levels!)
|
||||
(export gnc:options-add-account-selection!)
|
||||
(export gnc:options-add-include-subaccounts!) ;deprecated
|
||||
(export gnc:options-add-group-accounts!) ;deprecated
|
||||
(export gnc:options-add-currency!)
|
||||
(export gnc:options-add-currency-selection!) ;deprecated
|
||||
(export gnc:options-add-price-source!)
|
||||
(export gnc:options-add-plot-size!)
|
||||
(export gnc:options-add-marker-choice!)
|
||||
@ -206,14 +198,6 @@
|
||||
(export gnc:report-embedded-list)
|
||||
(export gnc:report-template-is-custom/template-guid?)
|
||||
(export gnc:is-custom-report-type)
|
||||
;; Legacy : the following 3 functions are only needed to
|
||||
;; load a saved-reports file version 2.0
|
||||
(export gnc:report-template-new-options/name)
|
||||
(export gnc:report-template-menu-name/name)
|
||||
(export gnc:report-template-renderer/name)
|
||||
;; Legacy: this function is needed only to restore
|
||||
;; a open report when loading a book last saved in GnuCash 2.2
|
||||
(export gnc:restore-report)
|
||||
|
||||
;; html-barchart.scm
|
||||
|
||||
@ -705,7 +689,6 @@
|
||||
|
||||
(export list-ref-safe)
|
||||
(export list-set-safe!)
|
||||
(export gnc-commodity-value->string)
|
||||
(export gnc:monetary->string)
|
||||
(export gnc:account-has-shares?)
|
||||
(export gnc:account-is-stock?)
|
||||
@ -716,15 +699,10 @@
|
||||
(export gnc:accounts-get-commodities)
|
||||
(export gnc:get-current-account-tree-depth)
|
||||
(export gnc:acccounts-get-all-subaccounts)
|
||||
(export gnc:make-stats-collector) ;deprecated
|
||||
(export gnc:make-drcr-collector) ;deprecated
|
||||
(export gnc:make-value-collector)
|
||||
(export gnc:make-number-collector) ;deprecated
|
||||
(export gnc:make-commodity-collector)
|
||||
(export gnc:commodity-collector-get-negated)
|
||||
(export gnc:commodity-collectorlist-get-merged) ;deprecated
|
||||
(export gnc-commodity-collector-commodity-count)
|
||||
(export gnc:account-get-balance-at-date)
|
||||
(export gnc:account-get-balances-at-dates)
|
||||
(export gnc:account-get-comm-balance-at-date)
|
||||
(export gnc:account-get-comm-value-interval)
|
||||
@ -753,10 +731,7 @@
|
||||
(export gnc:monetaries-add)
|
||||
(export gnc:account-get-trans-type-balance-interval)
|
||||
(export gnc:account-get-trans-type-balance-interval-with-closing)
|
||||
(export gnc:account-get-total-flow) ;deprecated
|
||||
(export gnc:account-get-pos-trans-total-interval)
|
||||
(export gnc:account-get-trans-type-splits-interval)
|
||||
(export gnc:double-col) ;deprecated
|
||||
(export gnc:budget-get-start-date)
|
||||
(export gnc:budget-get-end-date)
|
||||
(export gnc:budget-account-get-net)
|
||||
|
||||
@ -36,14 +36,6 @@
|
||||
(set! l (append! l filler)))))
|
||||
l)
|
||||
|
||||
;; pair is a list of one gnc:commodity and one gnc:numeric
|
||||
;; value. Deprecated -- use <gnc-monetary> instead.
|
||||
(define (gnc-commodity-value->string pair)
|
||||
(issue-deprecation-warning "gnc-commodity-value->string deprecated. \
|
||||
construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
(xaccPrintAmount
|
||||
(cadr pair) (gnc-commodity-print-info (car pair) #t)))
|
||||
|
||||
;; Just for convenience. But in reports you should rather stick to the
|
||||
;; style-info mechanism and simple plug the <gnc-monetary> into the
|
||||
;; html-renderer.
|
||||
@ -176,71 +168,6 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
;; I might just go for the record-and-function-set way. <rlb> cstim:
|
||||
;; yes. I think that would still be faster.
|
||||
|
||||
(define (gnc:make-stats-collector)
|
||||
(issue-deprecation-warning
|
||||
"gnc:make-stats-collector is obsolete. use srfi-1 functions instead.")
|
||||
(let ((value 0)
|
||||
(totalitems 0)
|
||||
(maximum -inf.0)
|
||||
(minimum +inf.0))
|
||||
(let ((adder (lambda (amount)
|
||||
(when (number? amount)
|
||||
(set! value (+ amount value))
|
||||
(if (> amount maximum) (set! maximum amount))
|
||||
(if (< amount minimum) (set! minimum amount))
|
||||
(set! totalitems (1+ totalitems)))))
|
||||
(getnumitems (lambda () totalitems))
|
||||
(gettotal (lambda () value))
|
||||
(getaverage (lambda () (/ value totalitems)))
|
||||
(getmax (lambda () maximum))
|
||||
(getmin (lambda () minimum))
|
||||
(reset-all (lambda ()
|
||||
(set! value 0)
|
||||
(set! maximum -inf.0)
|
||||
(set! minimum +inf.0)
|
||||
(set! totalitems 0))))
|
||||
(lambda (action value)
|
||||
(case action
|
||||
((add) (adder value))
|
||||
((total) (gettotal))
|
||||
((average) (getaverage))
|
||||
((numitems) (getnumitems))
|
||||
((getmax) (getmax))
|
||||
((getmin) (getmin))
|
||||
((reset) (reset-all))
|
||||
(else (gnc:warn "bad stats-collector action: " action)))))))
|
||||
|
||||
(define (gnc:make-drcr-collector)
|
||||
(issue-deprecation-warning
|
||||
"gnc:make-drcr-collector is obsolete. use srfi-1 functions instead.")
|
||||
(let ;;; values
|
||||
((debits 0)
|
||||
(credits 0)
|
||||
(totalitems 0))
|
||||
(let ;;; Functions to manipulate values
|
||||
((adder (lambda (amount)
|
||||
(if (> 0 amount)
|
||||
(set! credits (- credits amount))
|
||||
(set! debits (+ debits amount)))
|
||||
(set! totalitems (+ 1 totalitems))))
|
||||
(getdebits (lambda () debits))
|
||||
(getcredits (lambda () credits))
|
||||
(setdebits (lambda (amount)
|
||||
(set! debits amount)))
|
||||
(getitems (lambda () totalitems))
|
||||
(reset-all (lambda ()
|
||||
(set! credits 0)
|
||||
(set! debits 0)
|
||||
(set! totalitems 0))))
|
||||
(lambda (action value) ;;; Dispatch function
|
||||
(case action
|
||||
((add) (adder value))
|
||||
((debits) (getdebits))
|
||||
((credits) (getcredits))
|
||||
((items) (getitems))
|
||||
((reset) (reset-all))
|
||||
(else (gnc:warn "bad dr-cr-collector action: " action)))))))
|
||||
|
||||
;; This is a collector of values -- works similar to the stats-collector but
|
||||
;; has much less overhead. It is used by the currency-collector (see below).
|
||||
(define (gnc:make-value-collector)
|
||||
@ -371,13 +298,6 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
(negated 'minusmerge collector #f)
|
||||
negated))
|
||||
|
||||
(define (gnc:commodity-collectorlist-get-merged collectorlist)
|
||||
(issue-deprecation-warning
|
||||
"gnc:commodity-collectorlist-get-merged is now deprecated.")
|
||||
(let ((merged (gnc:make-commodity-collector)))
|
||||
(for-each (lambda (collector) (merged 'merge collector #f)) collectorlist)
|
||||
merged))
|
||||
|
||||
;; Returns zero if all entries in this collector are zero.
|
||||
(define (gnc-commodity-collector-allzero? collector)
|
||||
(every zero?
|
||||
@ -405,29 +325,6 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
|
||||
(car list-of-monetaries)
|
||||
(throw "gnc:monetary+ expects 1 currency " (gnc:strify monetaries)))))
|
||||
|
||||
;; get the account balance at the specified date. if include-children?
|
||||
;; is true, the balances of all children (not just direct children)
|
||||
;; are included in the calculation.
|
||||
;; I think this (gnc:account-get-balance-at-date) is flawed in sub-acct handling.
|
||||
;; Consider account structure:
|
||||
;; Assets [USD] - bal=$0
|
||||
;; Bank [USD] - bal=$100
|
||||
;; Broker [USD] - bal=$200
|
||||
;; Cash [USD] - bal=$800
|
||||
;; Funds [FUND] - bal=3 FUND @ $1000 each = $3000
|
||||
;; - Calling (gnc:account-get-balance-at-date BANK TODAY #f) returns 100
|
||||
;; - Calling (gnc:account-get-balance-at-date BROKER TODAY #f) returns 200
|
||||
;; - Calling (gnc:account-get-balance-at-date BROKER TODAY #t) returns 1000
|
||||
;; this is because although it counts all subaccounts bal $200 + $800 + 3FUND,
|
||||
;; it retrieves the parent account commodity USD $1000 only.
|
||||
;; It needs to be deprecated.
|
||||
(define (gnc:account-get-balance-at-date account date include-children?)
|
||||
(issue-deprecation-warning "this gnc:account-get-balance-at-date function is \
|
||||
flawed. see report-utilities.scm. please update reports.")
|
||||
(let ((collector (gnc:account-get-comm-balance-at-date
|
||||
account date include-children?)))
|
||||
(cadr (collector 'getpair (xaccAccountGetCommodity account) #f))))
|
||||
|
||||
;; this function will scan through the account splitlist, building
|
||||
;; a list of balances along the way at dates specified in dates-list.
|
||||
;; in: account
|
||||
@ -733,93 +630,6 @@ flawed. see report-utilities.scm. please update reports.")
|
||||
account-list type start-date end-date))
|
||||
total))
|
||||
|
||||
;; Filters the splits from the source to the target accounts
|
||||
;; returns a commodity collector
|
||||
;; does NOT do currency exchanges
|
||||
(define (gnc:account-get-total-flow direction target-account-list from-date to-date)
|
||||
(issue-deprecation-warning
|
||||
"(gnc:account-get-total-flow) is deprecated.")
|
||||
(let ((total-flow (gnc:make-commodity-collector)))
|
||||
(for-each
|
||||
(lambda (target-account)
|
||||
(for-each
|
||||
(lambda (target-account-split)
|
||||
(let* ((transaction (xaccSplitGetParent target-account-split))
|
||||
(split-value (xaccSplitGetAmount target-account-split)))
|
||||
(if (and (<= from-date (xaccTransGetDate transaction) to-date)
|
||||
(or (and (eq? direction 'in)
|
||||
(positive? split-value))
|
||||
(and (eq? direction 'out)
|
||||
(negative? split-value))))
|
||||
(total-flow 'add (xaccTransGetCurrency transaction) split-value))))
|
||||
(xaccAccountGetSplitList target-account)))
|
||||
target-account-list)
|
||||
total-flow))
|
||||
|
||||
;; similar, but only counts transactions with non-negative shares and
|
||||
;; *ignores* any closing entries
|
||||
(define (gnc:account-get-pos-trans-total-interval
|
||||
account-list type start-date end-date)
|
||||
(issue-deprecation-warning
|
||||
"(gnc:account-get-pos-trans-total-interval) is deprecated.")
|
||||
(let* ((str-query (qof-query-create-for-splits))
|
||||
(sign-query (qof-query-create-for-splits))
|
||||
(total-query #f)
|
||||
(splits #f)
|
||||
(get-val (lambda (alist key)
|
||||
(let ((lst (assoc-ref alist key)))
|
||||
(if lst (car lst) lst))))
|
||||
(matchstr (get-val type 'str))
|
||||
(case-sens (if (get-val type 'cased) #t #f))
|
||||
(regexp (if (get-val type 'regexp) #t #f))
|
||||
(pos? (if (get-val type 'positive) #t #f))
|
||||
(total (gnc:make-commodity-collector))
|
||||
)
|
||||
(qof-query-set-book str-query (gnc-get-current-book))
|
||||
(qof-query-set-book sign-query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! str-query (gnc-get-current-book))
|
||||
(gnc:query-set-match-non-voids-only! sign-query (gnc-get-current-book))
|
||||
(xaccQueryAddAccountMatch str-query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddAccountMatch sign-query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT
|
||||
str-query
|
||||
(and start-date #t) (if start-date start-date 0)
|
||||
(and end-date #t) (if end-date end-date 0)
|
||||
QOF-QUERY-AND)
|
||||
(xaccQueryAddDateMatchTT
|
||||
sign-query
|
||||
(and start-date #t) (if start-date start-date 0)
|
||||
(and end-date #t) (if end-date end-date 0)
|
||||
QOF-QUERY-AND)
|
||||
(xaccQueryAddDescriptionMatch
|
||||
str-query matchstr case-sens regexp QOF-COMPARE-CONTAINS QOF-QUERY-AND)
|
||||
(set! total-query
|
||||
;; this is a tad inefficient, but its a simple way to accomplish
|
||||
;; description match inversion...
|
||||
(if pos?
|
||||
(qof-query-merge-in-place sign-query str-query QOF-QUERY-AND)
|
||||
(let ((inv-query (qof-query-invert str-query)))
|
||||
(qof-query-merge-in-place
|
||||
sign-query inv-query QOF-QUERY-AND)
|
||||
qof-query-destroy inv-query)))
|
||||
(qof-query-destroy str-query)
|
||||
|
||||
(set! splits (qof-query-run total-query))
|
||||
(map (lambda (split)
|
||||
(let* ((shares (xaccSplitGetAmount split))
|
||||
(acct-comm (xaccAccountGetCommodity
|
||||
(xaccSplitGetAccount split)))
|
||||
)
|
||||
(or (gnc-numeric-negative-p shares)
|
||||
(total 'add acct-comm shares)
|
||||
)
|
||||
)
|
||||
)
|
||||
splits
|
||||
)
|
||||
(qof-query-destroy total-query)
|
||||
total))
|
||||
|
||||
;; Return the splits that match an account list, date range, and (optionally) type
|
||||
;; where type is defined as an alist like:
|
||||
;; '((str "match me") (cased #f) (regexp #f) (closing #f))
|
||||
@ -862,50 +672,6 @@ flawed. see report-utilities.scm. please update reports.")
|
||||
(qof-query-destroy query)
|
||||
splits))))
|
||||
|
||||
;; the following function is only used in trial-balance. best move it
|
||||
;; back there, and deprecate this exported function.
|
||||
(define (gnc:double-col
|
||||
req signed-balance report-commodity exchange-fn show-comm?)
|
||||
(issue-deprecation-warning
|
||||
"(gnc:double-col) is deprecated.")
|
||||
(let* ((sum (and signed-balance
|
||||
(gnc:sum-collector-commodity
|
||||
signed-balance
|
||||
report-commodity
|
||||
exchange-fn)))
|
||||
(amt (and sum (gnc:gnc-monetary-amount sum)))
|
||||
(neg? (and amt (gnc-numeric-negative-p amt)))
|
||||
(bal (if neg?
|
||||
(let ((bal (gnc:make-commodity-collector)))
|
||||
(bal 'minusmerge signed-balance #f)
|
||||
bal)
|
||||
signed-balance))
|
||||
(bal-sum (gnc:sum-collector-commodity
|
||||
bal
|
||||
report-commodity
|
||||
exchange-fn))
|
||||
(balance
|
||||
(if (gnc:uniform-commodity? bal report-commodity)
|
||||
(if (gnc-numeric-zero-p amt) #f bal-sum)
|
||||
(if show-comm?
|
||||
(gnc-commodity-table bal report-commodity exchange-fn)
|
||||
bal-sum)
|
||||
))
|
||||
)
|
||||
(car (assoc-ref
|
||||
(list
|
||||
(list 'entry balance)
|
||||
(list 'debit (if neg? #f balance))
|
||||
(list 'credit (if neg? balance #f))
|
||||
(list 'zero-q (if neg? #f (if balance #f #t)))
|
||||
(list 'debit-q (if neg? #f (if balance #t #f)))
|
||||
(list 'credit-q (if neg? #t #f))
|
||||
)
|
||||
req
|
||||
))
|
||||
)
|
||||
)
|
||||
|
||||
;; Returns the start date of the first period (period 0) of the budget.
|
||||
(define (gnc:budget-get-start-date budget)
|
||||
(gnc-budget-get-period-start-date budget 0))
|
||||
|
||||
@ -91,8 +91,6 @@
|
||||
;; define strings centrally to ease code clarity
|
||||
(define rpterr-dupe
|
||||
(_ "One of your reports has a report-guid that is a duplicate. Please check the report system, especially your saved reports, for a report with this report-guid: "))
|
||||
(define rpterr-upgraded
|
||||
(_ "The GnuCash report system has been upgraded. Your old saved reports have been transferred into a new format. If you experience trouble with saved reports, please contact the GnuCash development team."))
|
||||
(define rpterr-guid1 (_ "Wrong report definition: "))
|
||||
(define rpterr-guid2 (_ " Report is missing a GUID."))
|
||||
(define rptwarn-legacy
|
||||
@ -138,47 +136,9 @@ not found.")))
|
||||
(if (hash-ref *gnc:_report-templates_* report-guid)
|
||||
(gui-error (string-append rpterr-dupe report-guid))
|
||||
(hash-set! *gnc:_report-templates_* report-guid report-rec)))
|
||||
|
||||
(report-name
|
||||
;; we've got an old style report with no report-guid
|
||||
(issue-deprecation-warning
|
||||
"old report definition without guid is deprecated.")
|
||||
|
||||
;; give it an arbitrary one
|
||||
(set! report-guid (guid-new-return))
|
||||
(gnc:report-template-set-report-guid! report-rec report-guid)
|
||||
|
||||
;; we also need to give it a parent-type, so that it will
|
||||
;; restore from the open state properly we'll key that from the
|
||||
;; only known good way to tie back to the original report -- the
|
||||
;; renderer
|
||||
(hash-for-each
|
||||
(lambda (id rec)
|
||||
(if (and (equal? (gnc:report-template-renderer rec)
|
||||
(gnc:report-template-renderer report-rec))
|
||||
(not (gnc:report-template-parent-type rec)))
|
||||
(begin
|
||||
(gnc:warn "gnc:define-report: setting parent-type of " report-name
|
||||
" to " (gnc:report-template-report-guid rec))
|
||||
(gnc:report-template-set-parent-type!
|
||||
report-rec (gnc:report-template-report-guid rec))
|
||||
(gnc:debug "done setting, is now "
|
||||
(gnc:report-template-parent-type report-rec)))))
|
||||
*gnc:_report-templates_*)
|
||||
|
||||
(cond
|
||||
((gnc:report-template-parent-type report-rec)
|
||||
;; re-save this old-style report in the new format
|
||||
(gnc:report-template-save-to-savefile report-rec)
|
||||
(gnc:debug "complete saving " report-name " in new format")
|
||||
(unless gnc:old-style-report-warned
|
||||
(set! gnc:old-style-report-warned #t)
|
||||
(gui-error rpterr-upgraded)
|
||||
(hash-set! *gnc:_report-templates_* report-guid report-rec)))
|
||||
|
||||
(else
|
||||
;;there is no parent found -> this is an inital faulty report definition
|
||||
(gui-error (string-append rpterr-guid1 report-name rpterr-guid2))))))))
|
||||
;;reports without guid are no longer supported
|
||||
(gui-error (string-append rpterr-guid1 report-name rpterr-guid2))))))
|
||||
|
||||
(define gnc:report-template-version
|
||||
(record-accessor <report-template> 'version))
|
||||
@ -817,80 +777,3 @@ not found.")))
|
||||
(gnc:debug "Renaming report " template-guid)
|
||||
(gnc:report-template-set-name templ new-name)
|
||||
(gnc:save-all-reports))))
|
||||
|
||||
;; Legacy functions
|
||||
;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; Legacy : the following 3 functions are only needed to
|
||||
;; load a saved-reports file version 2.0
|
||||
|
||||
(define (gnc:report-template-new-options/name template-name)
|
||||
(issue-deprecation-warning
|
||||
"gnc:report-template-new-options/name is deprecated.")
|
||||
(let ((templ #f))
|
||||
(hash-for-each
|
||||
(lambda (id rec)
|
||||
(if (equal? template-name (gnc:report-template-name rec))
|
||||
(set! templ (hash-ref *gnc:_report-templates_* id))))
|
||||
*gnc:_report-templates_*)
|
||||
(and templ
|
||||
(gnc:report-template-new-options templ))))
|
||||
|
||||
(define (gnc:report-template-menu-name/name template-name)
|
||||
(issue-deprecation-warning
|
||||
"gnc:report-template-menu-name/name is deprecated.")
|
||||
(let ((templ #f))
|
||||
(hash-for-each
|
||||
(lambda (id rec)
|
||||
(if (equal? template-name (gnc:report-template-name rec))
|
||||
(set! templ (hash-ref *gnc:_report-templates_* id))))
|
||||
*gnc:_report-templates_*)
|
||||
(and templ
|
||||
(or (gnc:report-template-menu-name templ)
|
||||
(gnc:report-template-name templ)))))
|
||||
|
||||
(define (gnc:report-template-renderer/name template-name)
|
||||
(issue-deprecation-warning
|
||||
"gnc:report-template-renderer/name is deprecated.")
|
||||
(let ((templ #f))
|
||||
(hash-for-each
|
||||
(lambda (id rec)
|
||||
(if (equal? template-name (gnc:report-template-name rec))
|
||||
(set! templ (hash-ref *gnc:_report-templates_* id))))
|
||||
*gnc:_report-templates_*)
|
||||
(and templ
|
||||
(gnc:report-template-renderer templ))))
|
||||
|
||||
;; Used internally only to convert a report template name into a corresponding guid
|
||||
;; Note that this may fail if several reports exist with the same name
|
||||
(define (gnc:report-template-name-to-id template-name)
|
||||
(issue-deprecation-warning
|
||||
"gnc:report-template-name-to-id is deprecated.")
|
||||
(let ((template-id #f))
|
||||
(hash-for-each
|
||||
(lambda (id rec)
|
||||
(if (equal? template-name (gnc:report-template-name rec))
|
||||
(set! template-id id)))
|
||||
*gnc:_report-templates_*)
|
||||
template-id))
|
||||
|
||||
;; Legacy: this function is needed only to restore
|
||||
;; a saved report when loading a book last saved in GnuCash 2.2
|
||||
(define gnc:restore-report
|
||||
(let ((first-warn? #t))
|
||||
(lambda (id template-name options)
|
||||
(issue-deprecation-warning
|
||||
"gnc:restore-report is deprecated.")
|
||||
(cond
|
||||
(options
|
||||
(let* ((constructor (record-constructor <report>))
|
||||
(template-id (gnc:report-template-name-to-id template-name))
|
||||
(report (constructor template-id id options #t #t #f #f "")))
|
||||
;; Warn user (one time) we're attempting to restore old style reports
|
||||
(when first-warn?
|
||||
(set! first-warn? #f)
|
||||
(gui-warning rptwarn-legacy))
|
||||
(gnc-report-add report)))
|
||||
(else
|
||||
(gui-error-missing-template template-name)
|
||||
#f)))))
|
||||
|
||||
@ -32,7 +32,7 @@ set(GUILE_DEPENDS
|
||||
scm-engine
|
||||
scm-test-engine
|
||||
scm-scm
|
||||
scm-report-system-3
|
||||
scm-report-system
|
||||
scm-test-report-system
|
||||
)
|
||||
gnc_add_scheme_tests("${scm_test_report_system_SOURCES}")
|
||||
|
||||
@ -36,11 +36,13 @@
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(define (test-check2)
|
||||
;; this tests deprecated features
|
||||
(display "\n*** Missing GUID detection:\n")
|
||||
; the parent type is set to test unique report names later on
|
||||
(display "\n*** Duplicate name, parent type of pre-existing report:\n")
|
||||
(gnc:define-report 'version "1"
|
||||
'name "Test Report Template")
|
||||
(test-equal "2 reports defined, with 1 autogenerated guid"
|
||||
'name "Test Report Template"
|
||||
'report-guid "54c2fc051af64a08ba2334c2e9179e25"
|
||||
'parent-type "54c2fc051af64a08ba2334c2e9179e23")
|
||||
(test-equal "2 reports defined, with same report name"
|
||||
2
|
||||
(length (gnc:all-report-template-guids))))
|
||||
|
||||
|
||||
@ -22,7 +22,6 @@
|
||||
(test-commodity-collector)
|
||||
(test-get-account-balances)
|
||||
(test-monetary-adders)
|
||||
(test-make-stats-collector)
|
||||
(test-end "report-utilities"))
|
||||
|
||||
(define (NDayDelta t64 n)
|
||||
@ -199,12 +198,6 @@
|
||||
(collector->list
|
||||
(gnc:commodity-collector-get-negated coll-A)))
|
||||
|
||||
;; deprecated:
|
||||
(test-equal "gnc:commodity-collectorlist-get-merged"
|
||||
'(("USD" . 25) ("GBP" . 0))
|
||||
(collector->list
|
||||
(gnc:commodity-collectorlist-get-merged (list coll-A coll-B))))
|
||||
|
||||
(test-equal "gnc-commodity-collector-allzero? #f"
|
||||
#f
|
||||
(gnc-commodity-collector-allzero? coll-A))
|
||||
@ -296,16 +289,6 @@
|
||||
(bank (account-lookup "Bank"))
|
||||
(gbp-bank (account-lookup "GBP Bank")))
|
||||
|
||||
;; deprecated:
|
||||
(test-equal "gnc:account-get-balance-at-date 1/1/2001 incl children"
|
||||
2301
|
||||
(gnc:account-get-balance-at-date asset (gnc-dmy2time64 01 01 2001) #t))
|
||||
|
||||
;; deprecated:
|
||||
(test-equal "gnc:account-get-balance-at-date 1/1/2001 excl children"
|
||||
15
|
||||
(gnc:account-get-balance-at-date asset (gnc-dmy2time64 01 01 2001) #f))
|
||||
|
||||
(test-equal "gnc:account-get-comm-balance-at-date 1/1/2001 incl children"
|
||||
'(("GBP" . 608) ("USD" . 2301))
|
||||
(collector->list
|
||||
@ -505,50 +488,3 @@
|
||||
"gnc:monetary+ with >1 currency fails"
|
||||
#t
|
||||
(gnc:monetary+ usd10 usd10 eur8))))
|
||||
|
||||
(define (test-make-stats-collector)
|
||||
(test-begin "gnc:make-stats-collector")
|
||||
(let ((s (gnc:make-stats-collector)))
|
||||
(test-equal "initial s is 0"
|
||||
0
|
||||
(s 'total #f))
|
||||
|
||||
(s 'add 5)
|
||||
(test-equal "s+=5 is 5"
|
||||
5
|
||||
(s 'total #f))
|
||||
|
||||
(s 'add 9)
|
||||
(test-equal "s+=9 is 14"
|
||||
14
|
||||
(s 'total #f))
|
||||
|
||||
(test-equal "avg(s) is 7"
|
||||
7
|
||||
(s 'average #f))
|
||||
|
||||
(s 'add 1E12)
|
||||
(s 'add -1E13)
|
||||
|
||||
(test-equal "max(s) is now 1E12"
|
||||
1E12
|
||||
(s 'getmax #f))
|
||||
|
||||
(test-equal "min(s) is now -1E13"
|
||||
-1E13
|
||||
(s 'getmin #f))
|
||||
|
||||
(s 'add 9E12)
|
||||
(test-equal "newavg(s) is 2.8"
|
||||
2.8
|
||||
(s 'average #f))
|
||||
|
||||
(test-equal "num(s) is 5"
|
||||
5
|
||||
(s 'numitems #f))
|
||||
|
||||
(s 'reset #f)
|
||||
(test-equal "after reset num(s) is 0"
|
||||
0
|
||||
(s 'numitems #f)))
|
||||
(test-end "gnc:make-stats-collector"))
|
||||
|
||||
@ -156,7 +156,6 @@ set (app_utils_SCHEME_2
|
||||
)
|
||||
|
||||
set (app_utils_SCHEME_1
|
||||
hooks.scm
|
||||
business-options.scm
|
||||
c-interface.scm
|
||||
date-utilities.scm
|
||||
|
||||
@ -148,7 +148,6 @@
|
||||
(export gnc:options-get-default-section)
|
||||
(export gnc:options-copy-values)
|
||||
(export gnc:send-options)
|
||||
(export gnc:save-options)
|
||||
|
||||
(define (gnc:option-get-value book category key)
|
||||
;;Access an option directly
|
||||
@ -264,11 +263,6 @@
|
||||
(export gnc:get-start-next-year)
|
||||
(export gnc:get-three-months-ahead)
|
||||
|
||||
;; hooks
|
||||
(export gnc:hook-run-danglers) ;; from hooks.scm- deprecated
|
||||
(re-export gnc-hook-add-scm-dangler)
|
||||
(re-export HOOK-REPORT)
|
||||
|
||||
;; simple-obj
|
||||
(export make-simple-class)
|
||||
(export simple-obj-getter)
|
||||
@ -283,7 +277,6 @@
|
||||
|
||||
(load-from-path "c-interface")
|
||||
(load-from-path "options")
|
||||
(load-from-path "hooks")
|
||||
(load-from-path "prefs")
|
||||
(load-from-path "date-utilities")
|
||||
(load-from-path "simple-obj")
|
||||
|
||||
@ -1,23 +0,0 @@
|
||||
;; 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 (gnc:hook-run-danglers hook . args)
|
||||
(issue-deprecation-warning "gnc:hook-run-danglers is now deprecated.")
|
||||
(if (null? args)
|
||||
(set! args '())
|
||||
(set! args (car args)))
|
||||
(gnc-hook-run hook args))
|
||||
@ -1987,19 +1987,6 @@ the option '~a'."))
|
||||
(gnc-option-db-register-option db_handle option))
|
||||
options))
|
||||
|
||||
(define (gnc:save-options options options-string file header truncate?)
|
||||
(issue-deprecation-warning
|
||||
"gnc:save-options is deprecated.")
|
||||
(let ((code (gnc:generate-restore-forms options options-string))
|
||||
(port (false-if-exception
|
||||
(if truncate?
|
||||
(open file (logior O_WRONLY O_CREAT O_TRUNC))
|
||||
(open file (logior O_WRONLY O_CREAT O_APPEND))))))
|
||||
(if port (begin
|
||||
(display header port)
|
||||
(display code port)
|
||||
(close port)))))
|
||||
|
||||
(define (gnc:options-make-end-date! options pagename optname sort-tag info)
|
||||
(gnc:register-option
|
||||
options
|
||||
|
||||
@ -36,42 +36,6 @@
|
||||
(map thunk children)))
|
||||
|
||||
;; account related functions
|
||||
;; is account in list of accounts?
|
||||
(define (account-same? a1 a2)
|
||||
(issue-deprecation-warning "account-same? is deprecated. use equal? instead.")
|
||||
(or (eq? a1 a2)
|
||||
(string=? (gncAccountGetGUID a1) (gncAccountGetGUID a2))))
|
||||
|
||||
(define account-in-list?
|
||||
(lambda (account accounts)
|
||||
(issue-deprecation-warning "account-in-list? is deprecated. use member instead.")
|
||||
(cond
|
||||
((null? accounts) #f)
|
||||
((account-same? (car accounts) account) #t)
|
||||
(else (account-in-list? account (cdr accounts))))))
|
||||
|
||||
;; Optimized version of account-in-list if we know
|
||||
;; the list in advance.
|
||||
(define (account-in-list-pred accounts)
|
||||
(define (my-assoc str alist)
|
||||
(find (lambda (pair) (account-same? str (car pair))) alist))
|
||||
(define (my-hash acc size)
|
||||
(remainder (string-hash (gncAccountGetGUID acc)) size))
|
||||
(issue-deprecation-warning "account-in-list-pred is deprecated.")
|
||||
(let ((hash-table (make-hash-table)))
|
||||
(for-each (lambda (acc) (hashx-set! my-hash my-assoc hash-table acc #t))
|
||||
accounts)
|
||||
(lambda (account)
|
||||
(hashx-ref my-hash my-assoc hash-table account))))
|
||||
|
||||
(define account-in-alist
|
||||
(lambda (account alist)
|
||||
(issue-deprecation-warning "account-in-alist is deprecated. use assoc instead.")
|
||||
(cond
|
||||
((null? alist) #f)
|
||||
((account-same? (caar alist) account) (car alist))
|
||||
(else (account-in-alist account (cdr alist))))))
|
||||
|
||||
;; helper for sorting of account list
|
||||
(define (account-full-name<? a b)
|
||||
(string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
|
||||
@ -83,54 +47,3 @@
|
||||
(let ((acct-depth (gnc-account-get-current-depth acct)))
|
||||
(+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
|
||||
accounts)))
|
||||
|
||||
(define (account-assoc acc alist)
|
||||
(issue-deprecation-warning "account-assoc is deprecated. use assoc instead.")
|
||||
(find (lambda (pair) (account-same? acc (car pair))) alist))
|
||||
|
||||
(define (account-hash acc size)
|
||||
(issue-deprecation-warning "account-hash is deprecated. internal function.")
|
||||
(remainder (string-hash (gncAccountGetGUID acc)) size))
|
||||
|
||||
(define (account-hashtable-ref table account)
|
||||
(issue-deprecation-warning "account-hashtable-ref is deprecated. \
|
||||
use assoc-ref instead..")
|
||||
(hashx-ref account-hash account-assoc table account))
|
||||
|
||||
(define (account-hashtable-set! table account value)
|
||||
(issue-deprecation-warning "account-hashtable-set! is deprecated. \
|
||||
use assoc-set! instead.")
|
||||
(hashx-set! account-hash account-assoc table account value))
|
||||
|
||||
;; Splits
|
||||
(export split-same?) ;deprecated
|
||||
(export split-in-list?) ;deprecated
|
||||
(define (split-same? s1 s2)
|
||||
(issue-deprecation-warning "split-same? is deprecated. use equal? instead.")
|
||||
(or (eq? s1 s2)
|
||||
(string=? (gncSplitGetGUID s1) (gncSplitGetGUID s2))))
|
||||
(define split-in-list?
|
||||
(lambda (split splits)
|
||||
(issue-deprecation-warning "split-in-list? is deprecated. use member instead.")
|
||||
(cond
|
||||
((null? splits) #f)
|
||||
((split-same? (car splits) split) #t)
|
||||
(else (split-in-list? split (cdr splits))))))
|
||||
(define (split-assoc split alist)
|
||||
(issue-deprecation-warning "split-assoc is deprecated. use assoc instead")
|
||||
(find (lambda (pair) (split-same? (cdr split) (cdr (car pair)))) alist))
|
||||
(define (split-hash split size)
|
||||
(issue-deprecation-warning "split-hash is deprecated. \
|
||||
internal function -- no srfi-1 equivalent")
|
||||
(remainder (car split) size))
|
||||
(define (split-hashtable-ref table split)
|
||||
(issue-deprecation-warning "split-hashtable-ref is deprecated. \
|
||||
use assoc-ref instead.")
|
||||
(hashx-ref split-hash split-assoc table
|
||||
(cons (string-hash (gncSplitGetGUID split)) split)))
|
||||
(define (split-hashtable-set! table split value)
|
||||
(issue-deprecation-warning "split-hashtable-set! is deprecated. \
|
||||
use assoc-set! instead")
|
||||
(hashx-set! split-hash split-assoc table
|
||||
(cons (string-hash (gncSplitGetGUID split)) split) value))
|
||||
|
||||
|
||||
@ -63,19 +63,8 @@
|
||||
(export gnc:account-map-descendants)
|
||||
(export gnc:account-map-children)
|
||||
|
||||
(export account-same?) ;deprecated
|
||||
(export account-in-list?) ;deprecated
|
||||
(export account-in-list-pred) ;deprecated
|
||||
(export account-in-alist) ;deprecated
|
||||
(export account-full-name<?)
|
||||
(export accounts-get-children-depth)
|
||||
(export account-hashtable-ref) ;deprecated
|
||||
(export account-hashtable-set!) ;deprecated
|
||||
|
||||
(export split-same?) ;deprecated
|
||||
(export split-in-list?) ;deprecated
|
||||
(export split-hashtable-ref) ;deprecated
|
||||
(export split-hashtable-set!) ;deprecated
|
||||
|
||||
(export gnc:split-structure)
|
||||
(export gnc:make-split-scm)
|
||||
|
||||
@ -219,9 +219,7 @@ gnc_add_test_with_guile(test-scm-query test-scm-query.cpp ENGINE_TEST_INCLUDE_DI
|
||||
|
||||
|
||||
set(engine_test_SCHEME
|
||||
test-account.scm
|
||||
test-create-account.scm
|
||||
test-split.scm
|
||||
)
|
||||
|
||||
#list(APPEND engine_test_SCHEME test-scm-query-import.scm) Fails
|
||||
@ -313,11 +311,9 @@ set(test_engine_SOURCES_DIST
|
||||
)
|
||||
|
||||
set(test_engine_SCHEME_DIST
|
||||
test-account.scm
|
||||
test-create-account.scm
|
||||
test-engine-extras.scm
|
||||
test-scm-query-import.scm
|
||||
test-split.scm
|
||||
)
|
||||
|
||||
set(test_engine_EXTRA_DIST
|
||||
|
||||
@ -1,52 +0,0 @@
|
||||
(use-modules (gnucash gnc-module))
|
||||
|
||||
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
||||
|
||||
(use-modules (gnucash engine))
|
||||
|
||||
(use-modules (tests test-engine-extras))
|
||||
|
||||
;; this test suite tests deprecated functions.
|
||||
|
||||
(define (run-test)
|
||||
(test test-account-same?)
|
||||
(test test-account-in-list?)
|
||||
(test test-account-in-alist?)
|
||||
(test test-account-list-predicate))
|
||||
|
||||
(define (test-account-same?)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist))))
|
||||
(and (account-same? bank-account bank-account)
|
||||
(not (account-same? bank-account expense-account)))))
|
||||
|
||||
(define (test-account-in-alist?)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist))))
|
||||
(let ((alist (list (cons bank-account "Bank") (cons expense-account "Expenses"))))
|
||||
(and (account-in-alist bank-account alist)
|
||||
(account-in-alist expense-account alist)
|
||||
(not (account-in-alist wallet-account alist))))))
|
||||
|
||||
(define (test-account-in-list?)
|
||||
(test-account-list-predicate-generic
|
||||
(lambda (accounts) (lambda (account) (account-in-list? account accounts)))))
|
||||
|
||||
(define (test-account-list-predicate)
|
||||
(test-account-list-predicate-generic account-in-list-pred))
|
||||
|
||||
(define (test-account-list-predicate-generic predicate)
|
||||
(let* ((env (create-test-env))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(other-account (cdr (assoc "Other" account-alist)))
|
||||
(bank-or-wallet? (predicate (list bank-account wallet-account))))
|
||||
(and (bank-or-wallet? bank-account)
|
||||
(bank-or-wallet? wallet-account)
|
||||
(not (bank-or-wallet? other-account)))))
|
||||
@ -1,29 +0,0 @@
|
||||
(use-modules (gnucash gnc-module))
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
|
||||
|
||||
(use-modules (gnucash engine))
|
||||
(use-modules (tests test-engine-extras))
|
||||
(use-modules (gnucash app-utils))
|
||||
|
||||
(define (run-test)
|
||||
(test test-split-in-list?))
|
||||
|
||||
(define (test-split-in-list?)
|
||||
;; this test suite tests deprecated functions.
|
||||
(let* ((env (create-test-env))
|
||||
(today (current-time))
|
||||
(account-alist (env-create-test-accounts env))
|
||||
(bank-account (cdr (assoc "Bank" account-alist)))
|
||||
(expense-account (cdr (assoc "Expenses" account-alist)))
|
||||
(wallet-account (cdr (assoc "Wallet" account-alist)))
|
||||
(tx1 (env-create-transaction env today bank-account wallet-account 20/1))
|
||||
(tx2 (env-create-transaction env today bank-account expense-account 10/1))
|
||||
(splits-tx1 (xaccTransGetSplitList tx1))
|
||||
(splits-tx2 (xaccTransGetSplitList tx2)))
|
||||
(and (split-in-list? (first splits-tx1) splits-tx1)
|
||||
(split-in-list? (second splits-tx1) splits-tx1)
|
||||
(not (split-in-list? (first splits-tx1) splits-tx2))
|
||||
(not (split-in-list? (second splits-tx1) splits-tx2))
|
||||
(not (split-in-list? (first splits-tx1) '())))))
|
||||
@ -469,7 +469,6 @@ gnucash/report/reports/standard/view-column.scm
|
||||
gnucash/report/reports/support/balsheet-eg.eguile.scm
|
||||
gnucash/report/reports/support/receipt.eguile.scm
|
||||
gnucash/report/reports/support/taxinvoice.eguile.scm
|
||||
gnucash/report/report-system/collectors.scm
|
||||
gnucash/report/report-system/commodity-utilities.scm
|
||||
gnucash/report/report-system/eguile-gnc.scm
|
||||
gnucash/report/report-system/eguile-html-utilities.scm
|
||||
@ -491,7 +490,6 @@ gnucash/report/report-system/html-table.scm
|
||||
gnucash/report/report-system/html-text.scm
|
||||
gnucash/report/report-system/html-utilities.scm
|
||||
gnucash/report/report-system/options-utilities.scm
|
||||
gnucash/report/report-system/report-collectors.scm
|
||||
gnucash/report/report-system/report-register-hooks.scm
|
||||
gnucash/report/report-system/report.scm
|
||||
gnucash/report/report-system/report-system.scm
|
||||
@ -536,7 +534,6 @@ libgnucash/app-utils/gnc-sx-instance-model.c
|
||||
libgnucash/app-utils/gnc-ui-balances.c
|
||||
libgnucash/app-utils/gnc-ui-util.c
|
||||
libgnucash/app-utils/guile-util.c
|
||||
libgnucash/app-utils/hooks.scm
|
||||
libgnucash/app-utils/options.scm
|
||||
libgnucash/app-utils/option-util.c
|
||||
libgnucash/app-utils/prefs.scm
|
||||
|
||||
Loading…
Reference in New Issue
Block a user