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

Remove guile functions that were marked as deprecated in gnucash the 3.x series

Browse Source
This commit is contained in:
Geert Janssens 2019-06-08 14:09:40 +02:00
parent 306964797b
commit 30ac2cf266
21 changed files with 16 additions and 1427 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
gnucash/report/report-system/CMakeLists.txt
View File

@ -50,15 +50,7 @@ set (report_system_SCHEME
eguile-html-utilities.scm eguile-html-utilities.scm
) )
set (report_system_SCHEME_2a set (report_system_SCHEME_2
collectors.scm
)
set (report_system_SCHEME_2b
report-collectors.scm
)
set (report_system_SCHEME_3
commodity-utilities.scm commodity-utilities.scm
html-acct-table.scm html-acct-table.scm
html-chart.scm html-chart.scm
@ -97,34 +89,19 @@ gnc_add_scheme_targets(scm-report-system-1
FALSE FALSE
) )
gnc_add_scheme_targets(scm-report-system-2a gnc_add_scheme_targets(scm-report-system-2
"${report_system_SCHEME_2a}" "${report_system_SCHEME_2}"
"gnucash/report/report-system" ""
scm-report-system-1 scm-report-system-1
FALSE FALSE
) )
gnc_add_scheme_targets(scm-report-system-2b add_custom_target(scm-report-system ALL DEPENDS scm-report-system-2)
"${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)
set_local_dist(report_system_DIST_local CMakeLists.txt set_local_dist(report_system_DIST_local CMakeLists.txt
report-system.i report-system.i
${report_system_HEADERS} ${report_system_SOURCES} ${report_system_HEADERS} ${report_system_SOURCES}
${report_system_SCHEME} ${report_system_SCHEME_1} ${report_system_SCHEME} ${report_system_SCHEME_1}
${report_system_SCHEME_2a} ${report_system_SCHEME_2b} ${report_system_SCHEME_2})
${report_system_SCHEME_3})
set(report_system_DIST ${report_system_DIST_local} ${test_report_system_DIST} PARENT_SCOPE) set(report_system_DIST ${report_system_DIST_local} ${test_report_system_DIST} PARENT_SCOPE)

351
gnucash/report/report-system/collectors.scm
View File

@ -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))))))))

100
gnucash/report/report-system/commodity-utilities.scm
View File

@ -76,13 +76,6 @@
;; Functions to create some list of prices from data in transactions. ;; 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 ;; Helper for exchange below
(define (gnc:exchange-by-euro-numeric (define (gnc:exchange-by-euro-numeric
foreign-commodity foreign-numeric domestic date) foreign-commodity foreign-numeric domestic date)
@ -266,31 +259,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(loop result (loop result
(cdr commodity-splits)))))))) (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 ;; Find the price in 'pricelist' that's nearest to 'date'. The
;; pricelist comes from ;; pricelist comes from
;; e.g. gnc:get-commodity-totalavg-prices. Returns a <gnc-numeric> or, ;; 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)) (* (gnc:gnc-monetary-amount foreign) (cadr pair))
0))))))) 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 ;; This is another ready-to-use function for calculation of exchange
;; rates. (Note that this is already the function itself. It doesn't ;; rates. (Note that this is already the function itself. It doesn't
;; return a function as opposed to make-exchange-function.) It takes ;; 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) (lambda (foreign domestic date)
(gnc:exchange-by-pricealist-nearest (gnc:exchange-by-pricealist-nearest
pricealist foreign domestic date)))) 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) ((pricedb-latest) (lambda (foreign domestic date)
(gnc:exchange-by-pricedb-latest foreign domestic))) (gnc:exchange-by-pricedb-latest foreign domestic)))
((pricedb-nearest) gnc:exchange-by-pricedb-nearest) ((pricedb-nearest) gnc:exchange-by-pricedb-nearest)
@ -961,18 +873,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
#f) #f)
balance))) 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) (define (gnc:uniform-commodity? amt report-commodity)
;; function to see if the commodity-collector amt ;; function to see if the commodity-collector amt
;; contains any foreign commodities ;; contains any foreign commodities

38
gnucash/report/report-system/options-utilities.scm
View File

@ -118,28 +118,6 @@
default-accounts default-accounts
#f #t))) #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. ;; To let the user select a currency for the report.
(define (gnc:options-add-currency! (define (gnc:options-add-currency!
options pagename name-report-currency sort-tag) options pagename name-report-currency sort-tag)
@ -151,22 +129,6 @@
(N_ "Select the currency to display the values of this report in.") (N_ "Select the currency to display the values of this report in.")
(gnc-default-report-currency)))) (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 ;; A multichoice option for the source of prices
(define (gnc:options-add-price-source! (define (gnc:options-add-price-source!
options pagename optname sort-tag default) options pagename optname sort-tag default)

231
gnucash/report/report-system/report-collectors.scm
View File

@ -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))

25
gnucash/report/report-system/report-system.scm
View File

@ -41,12 +41,10 @@
(export gnc:get-match-commodity-splits) (export gnc:get-match-commodity-splits)
(export gnc:get-match-commodity-splits-sorted) (export gnc:get-match-commodity-splits-sorted)
(export gnc:get-all-commodity-splits ) (export gnc:get-all-commodity-splits )
(export gnc-commodity-numeric->string)
(export gnc:exchange-by-euro-numeric) (export gnc:exchange-by-euro-numeric)
(export gnc:get-commodity-totalavg-prices) (export gnc:get-commodity-totalavg-prices)
(export gnc:get-commoditylist-totalavg-prices) (export gnc:get-commoditylist-totalavg-prices)
(export gnc:get-commodity-inst-prices) (export gnc:get-commodity-inst-prices)
(export gnc:get-commoditylist-inst-prices)
(export gnc:pricelist-price-find-nearest) (export gnc:pricelist-price-find-nearest)
(export gnc:pricealist-lookup-nearest-in-time) (export gnc:pricealist-lookup-nearest-in-time)
(export gnc:resolve-unknown-comm) (export gnc:resolve-unknown-comm)
@ -57,8 +55,6 @@
(export gnc:exchange-by-euro) (export gnc:exchange-by-euro)
(export gnc:exchange-if-same) (export gnc:exchange-if-same)
(export gnc:make-exchange-function) (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-latest )
(export gnc:exchange-by-pricedb-nearest) (export gnc:exchange-by-pricedb-nearest)
(export gnc:exchange-by-pricealist-nearest) (export gnc:exchange-by-pricealist-nearest)
@ -66,7 +62,6 @@
(export gnc:case-exchange-time-fn) (export gnc:case-exchange-time-fn)
(export gnc:sum-collector-commodity) (export gnc:sum-collector-commodity)
(export gnc:sum-collector-stocks) (export gnc:sum-collector-stocks)
(export gnc-commodity-collector-contains-commodity?) ;deprecated
;; options-utilities.scm ;; options-utilities.scm
@ -75,10 +70,7 @@
(export gnc:options-add-interval-choice!) (export gnc:options-add-interval-choice!)
(export gnc:options-add-account-levels!) (export gnc:options-add-account-levels!)
(export gnc:options-add-account-selection!) (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!)
(export gnc:options-add-currency-selection!) ;deprecated
(export gnc:options-add-price-source!) (export gnc:options-add-price-source!)
(export gnc:options-add-plot-size!) (export gnc:options-add-plot-size!)
(export gnc:options-add-marker-choice!) (export gnc:options-add-marker-choice!)
@ -206,14 +198,6 @@
(export gnc:report-embedded-list) (export gnc:report-embedded-list)
(export gnc:report-template-is-custom/template-guid?) (export gnc:report-template-is-custom/template-guid?)
(export gnc:is-custom-report-type) (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 ;; html-barchart.scm
@ -705,7 +689,6 @@
(export list-ref-safe) (export list-ref-safe)
(export list-set-safe!) (export list-set-safe!)
(export gnc-commodity-value->string)
(export gnc:monetary->string) (export gnc:monetary->string)
(export gnc:account-has-shares?) (export gnc:account-has-shares?)
(export gnc:account-is-stock?) (export gnc:account-is-stock?)
@ -716,15 +699,10 @@
(export gnc:accounts-get-commodities) (export gnc:accounts-get-commodities)
(export gnc:get-current-account-tree-depth) (export gnc:get-current-account-tree-depth)
(export gnc:acccounts-get-all-subaccounts) (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-value-collector)
(export gnc:make-number-collector) ;deprecated (export gnc:make-number-collector) ;deprecated
(export gnc:make-commodity-collector) (export gnc:make-commodity-collector)
(export gnc:commodity-collector-get-negated) (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-balances-at-dates)
(export gnc:account-get-comm-balance-at-date) (export gnc:account-get-comm-balance-at-date)
(export gnc:account-get-comm-value-interval) (export gnc:account-get-comm-value-interval)
@ -753,10 +731,7 @@
(export gnc:monetaries-add) (export gnc:monetaries-add)
(export gnc:account-get-trans-type-balance-interval) (export gnc:account-get-trans-type-balance-interval)
(export gnc:account-get-trans-type-balance-interval-with-closing) (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:account-get-trans-type-splits-interval)
(export gnc:double-col) ;deprecated
(export gnc:budget-get-start-date) (export gnc:budget-get-start-date)
(export gnc:budget-get-end-date) (export gnc:budget-get-end-date)
(export gnc:budget-account-get-net) (export gnc:budget-account-get-net)

234
gnucash/report/report-system/report-utilities.scm
View File

@ -36,14 +36,6 @@
(set! l (append! l filler))))) (set! l (append! l filler)))))
l) 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 ;; Just for convenience. But in reports you should rather stick to the
;; style-info mechanism and simple plug the <gnc-monetary> into the ;; style-info mechanism and simple plug the <gnc-monetary> into the
;; html-renderer. ;; 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: ;; I might just go for the record-and-function-set way. <rlb> cstim:
;; yes. I think that would still be faster. ;; 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 ;; 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). ;; has much less overhead. It is used by the currency-collector (see below).
(define (gnc:make-value-collector) (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 'minusmerge collector #f)
negated)) 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. ;; Returns zero if all entries in this collector are zero.
(define (gnc-commodity-collector-allzero? collector) (define (gnc-commodity-collector-allzero? collector)
(every zero? (every zero?
@ -405,29 +325,6 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
(car list-of-monetaries) (car list-of-monetaries)
(throw "gnc:monetary+ expects 1 currency " (gnc:strify 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 ;; this function will scan through the account splitlist, building
;; a list of balances along the way at dates specified in dates-list. ;; a list of balances along the way at dates specified in dates-list.
;; in: account ;; in: account
@ -733,93 +630,6 @@ flawed. see report-utilities.scm. please update reports.")
account-list type start-date end-date)) account-list type start-date end-date))
total)) 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 ;; Return the splits that match an account list, date range, and (optionally) type
;; where type is defined as an alist like: ;; where type is defined as an alist like:
;; '((str "match me") (cased #f) (regexp #f) (closing #f)) ;; '((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) (qof-query-destroy query)
splits)))) 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. ;; Returns the start date of the first period (period 0) of the budget.
(define (gnc:budget-get-start-date budget) (define (gnc:budget-get-start-date budget)
(gnc-budget-get-period-start-date budget 0)) (gnc-budget-get-period-start-date budget 0))

121
gnucash/report/report-system/report.scm
View File

@ -91,8 +91,6 @@
;; define strings centrally to ease code clarity ;; define strings centrally to ease code clarity
(define rpterr-dupe (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: ")) (_ "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-guid1 (_ "Wrong report definition: "))
(define rpterr-guid2 (_ " Report is missing a GUID.")) (define rpterr-guid2 (_ " Report is missing a GUID."))
(define rptwarn-legacy (define rptwarn-legacy
@ -138,47 +136,9 @@ not found.")))
(if (hash-ref *gnc:_report-templates_* report-guid) (if (hash-ref *gnc:_report-templates_* report-guid)
(gui-error (string-append rpterr-dupe report-guid)) (gui-error (string-append rpterr-dupe report-guid))
(hash-set! *gnc:_report-templates_* report-guid report-rec))) (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 (else
;;there is no parent found -> this is an inital faulty report definition ;;reports without guid are no longer supported
(gui-error (string-append rpterr-guid1 report-name rpterr-guid2)))))))) (gui-error (string-append rpterr-guid1 report-name rpterr-guid2))))))
(define gnc:report-template-version (define gnc:report-template-version
(record-accessor <report-template> 'version)) (record-accessor <report-template> 'version))
@ -817,80 +777,3 @@ not found.")))
(gnc:debug "Renaming report " template-guid) (gnc:debug "Renaming report " template-guid)
(gnc:report-template-set-name templ new-name) (gnc:report-template-set-name templ new-name)
(gnc:save-all-reports)))) (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)))))

2
gnucash/report/report-system/test/CMakeLists.txt
View File

@ -32,7 +32,7 @@ set(GUILE_DEPENDS
scm-engine scm-engine
scm-test-engine scm-test-engine
scm-scm scm-scm
scm-report-system-3 scm-report-system
scm-test-report-system scm-test-report-system
) )
gnc_add_scheme_tests("${scm_test_report_system_SOURCES}") gnc_add_scheme_tests("${scm_test_report_system_SOURCES}")

10
gnucash/report/report-system/test/test-report-system.scm
View File

@ -36,11 +36,13 @@
;; ----------------------------------------------------------------------- ;; -----------------------------------------------------------------------
(define (test-check2) (define (test-check2)
;; this tests deprecated features ; the parent type is set to test unique report names later on
(display "\n*** Missing GUID detection:\n") (display "\n*** Duplicate name, parent type of pre-existing report:\n")
(gnc:define-report 'version "1" (gnc:define-report 'version "1"
'name "Test Report Template") 'name "Test Report Template"
(test-equal "2 reports defined, with 1 autogenerated guid" 'report-guid "54c2fc051af64a08ba2334c2e9179e25"
'parent-type "54c2fc051af64a08ba2334c2e9179e23")
(test-equal "2 reports defined, with same report name"
2 2
(length (gnc:all-report-template-guids)))) (length (gnc:all-report-template-guids))))

64
gnucash/report/report-system/test/test-report-utilities.scm
View File

@ -22,7 +22,6 @@
(test-commodity-collector) (test-commodity-collector)
(test-get-account-balances) (test-get-account-balances)
(test-monetary-adders) (test-monetary-adders)
(test-make-stats-collector)
(test-end "report-utilities")) (test-end "report-utilities"))
(define (NDayDelta t64 n) (define (NDayDelta t64 n)
@ -199,12 +198,6 @@
(collector->list (collector->list
(gnc:commodity-collector-get-negated coll-A))) (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" (test-equal "gnc-commodity-collector-allzero? #f"
#f #f
(gnc-commodity-collector-allzero? coll-A)) (gnc-commodity-collector-allzero? coll-A))
@ -296,16 +289,6 @@
(bank (account-lookup "Bank")) (bank (account-lookup "Bank"))
(gbp-bank (account-lookup "GBP 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" (test-equal "gnc:account-get-comm-balance-at-date 1/1/2001 incl children"
'(("GBP" . 608) ("USD" . 2301)) '(("GBP" . 608) ("USD" . 2301))
(collector->list (collector->list
@ -505,50 +488,3 @@
"gnc:monetary+ with >1 currency fails" "gnc:monetary+ with >1 currency fails"
#t #t
(gnc:monetary+ usd10 usd10 eur8)))) (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"))

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

@ -156,7 +156,6 @@ set (app_utils_SCHEME_2
) )
set (app_utils_SCHEME_1 set (app_utils_SCHEME_1
hooks.scm
business-options.scm business-options.scm
c-interface.scm c-interface.scm
date-utilities.scm date-utilities.scm

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

@ -148,7 +148,6 @@
(export gnc:options-get-default-section) (export gnc:options-get-default-section)
(export gnc:options-copy-values) (export gnc:options-copy-values)
(export gnc:send-options) (export gnc:send-options)
(export gnc:save-options)
(define (gnc:option-get-value book category key) (define (gnc:option-get-value book category key)
;;Access an option directly ;;Access an option directly
@ -264,11 +263,6 @@
(export gnc:get-start-next-year) (export gnc:get-start-next-year)
(export gnc:get-three-months-ahead) (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 ;; simple-obj
(export make-simple-class) (export make-simple-class)
(export simple-obj-getter) (export simple-obj-getter)
@ -283,7 +277,6 @@
(load-from-path "c-interface") (load-from-path "c-interface")
(load-from-path "options") (load-from-path "options")
(load-from-path "hooks")
(load-from-path "prefs") (load-from-path "prefs")
(load-from-path "date-utilities") (load-from-path "date-utilities")
(load-from-path "simple-obj") (load-from-path "simple-obj")

23
libgnucash/app-utils/hooks.scm
View File

@ -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))

13
libgnucash/app-utils/options.scm
View File

@ -1987,19 +1987,6 @@ the option '~a'."))
(gnc-option-db-register-option db_handle option)) (gnc-option-db-register-option db_handle option))
options)) 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) (define (gnc:options-make-end-date! options pagename optname sort-tag info)
(gnc:register-option (gnc:register-option
options options

87
libgnucash/engine/engine-utilities.scm
View File

@ -36,42 +36,6 @@
(map thunk children))) (map thunk children)))
;; account related functions ;; 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 ;; helper for sorting of account list
(define (account-full-name<? a b) (define (account-full-name<? a b)
(string<? (gnc-account-get-full-name a) (gnc-account-get-full-name 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))) (let ((acct-depth (gnc-account-get-current-depth acct)))
(+ acct-depth (- (gnc-account-get-tree-depth acct) 1)))) (+ acct-depth (- (gnc-account-get-tree-depth acct) 1))))
accounts))) 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))

11
libgnucash/engine/engine.scm
View File

@ -63,19 +63,8 @@
(export gnc:account-map-descendants) (export gnc:account-map-descendants)
(export gnc:account-map-children) (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 account-full-name<?)
(export accounts-get-children-depth) (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:split-structure)
(export gnc:make-split-scm) (export gnc:make-split-scm)

4
libgnucash/engine/test/CMakeLists.txt
View File

@ -219,9 +219,7 @@ gnc_add_test_with_guile(test-scm-query test-scm-query.cpp ENGINE_TEST_INCLUDE_DI
set(engine_test_SCHEME set(engine_test_SCHEME
test-account.scm
test-create-account.scm test-create-account.scm
test-split.scm
) )
#list(APPEND engine_test_SCHEME test-scm-query-import.scm) Fails #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 set(test_engine_SCHEME_DIST
test-account.scm
test-create-account.scm test-create-account.scm
test-engine-extras.scm test-engine-extras.scm
test-scm-query-import.scm test-scm-query-import.scm
test-split.scm
) )
set(test_engine_EXTRA_DIST set(test_engine_EXTRA_DIST

52
libgnucash/engine/test/test-account.scm
View File

@ -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)))))

29
libgnucash/engine/test/test-split.scm
View File

@ -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) '())))))

3
po/POTFILES.in
View File

@ -469,7 +469,6 @@ gnucash/report/reports/standard/view-column.scm
gnucash/report/reports/support/balsheet-eg.eguile.scm gnucash/report/reports/support/balsheet-eg.eguile.scm
gnucash/report/reports/support/receipt.eguile.scm gnucash/report/reports/support/receipt.eguile.scm
gnucash/report/reports/support/taxinvoice.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/commodity-utilities.scm
gnucash/report/report-system/eguile-gnc.scm gnucash/report/report-system/eguile-gnc.scm
gnucash/report/report-system/eguile-html-utilities.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-text.scm
gnucash/report/report-system/html-utilities.scm gnucash/report/report-system/html-utilities.scm
gnucash/report/report-system/options-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-register-hooks.scm
gnucash/report/report-system/report.scm gnucash/report/report-system/report.scm
gnucash/report/report-system/report-system.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-balances.c
libgnucash/app-utils/gnc-ui-util.c libgnucash/app-utils/gnc-ui-util.c
libgnucash/app-utils/guile-util.c libgnucash/app-utils/guile-util.c
libgnucash/app-utils/hooks.scm
libgnucash/app-utils/options.scm libgnucash/app-utils/options.scm
libgnucash/app-utils/option-util.c libgnucash/app-utils/option-util.c
libgnucash/app-utils/prefs.scm libgnucash/app-utils/prefs.scm