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

[qif/qif-merge-groups] compact functions

Browse Source
This commit is contained in:
Christopher Lam 2019-08-02 19:03:41 +08:00
parent a146d2cd58
commit b2d1ad526c
1 changed files with 125 additions and 173 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

132
gnucash/import-export/qif-imp/qif-merge-groups.scm
View File

@ -32,25 +32,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-get-transactions root) (define (gnc:account-tree-get-transactions root)
(let ((accounts (gnc-account-get-descendants-sorted root))) (let ((accounts (gnc-account-get-descendants-sorted root)))
(if (null? accounts) (let ((q (qof-query-create-for-splits)))
'() (qof-query-set-book q (gnc-account-get-book root))
(let ((query (qof-query-create-for-splits)) (xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xtns #f)) (let ((xtns (xaccQueryGetTransactions q QUERY-TXN-MATCH-ALL)))
(qof-query-destroy q)
(qof-query-set-book query (gnc-account-get-book root))
;; we want to find all transactions with every split inside the
;; account group.
(xaccQueryAddAccountMatch query accounts
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(set! xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL))
;; lose the query
(qof-query-destroy query)
xtns)))) xtns))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-find-duplicates ;; gnc:account-tree-find-duplicates
;; ;;
@ -74,22 +62,13 @@
;; This procedure does all the work. We'll define it, then call it safely. ;; This procedure does all the work. We'll define it, then call it safely.
(define (private-find) (define (private-find)
;; Given a list of accounts, this predicate returns true if any
;; of those accounts are involved in a transaction.
(define (has-any-xtns? acctlist)
(if (null? acctlist)
#f
(let ((splits (xaccAccountGetSplitList (car acctlist))))
(if (null? splits)
(has-any-xtns? (cdr acctlist))
#t))))
(let ((old-accounts (gnc-account-get-descendants-sorted old-root))) (let ((old-accounts (gnc-account-get-descendants-sorted old-root)))
(if (has-any-xtns? old-accounts)
;; Get all the transactions in the new tree, then iterate over them (cond
;; trying to find matches in the old tree. If there are matches, ((any pair? (map xaccAccountGetSplitList old-accounts))
;; push the matches onto a list. ;; Get all the transactions in the new tree, thisthen iterate
;; over them trying to find matches in the old tree. If
;; there are matches, push the matches onto a list.
(let* ((new-xtns (gnc:account-tree-get-transactions new-root)) (let* ((new-xtns (gnc:account-tree-get-transactions new-root))
(work-to-do (length new-xtns)) (work-to-do (length new-xtns))
(work-done 0) (work-done 0)
@ -98,17 +77,13 @@
;; This procedure handles progress reporting, pause, and cancel. ;; This procedure handles progress reporting, pause, and cancel.
(define (update-progress) (define (update-progress)
(set! work-done (+ 1 work-done)) (set! work-done (+ 1 work-done))
(if (and progress-dialog (when (and progress-dialog (zero? (modulo work-done 8)))
(zero? (remainder work-done 8)))
(begin
(gnc-progress-dialog-set-value progress-dialog (gnc-progress-dialog-set-value progress-dialog
(/ work-done work-to-do)) (/ work-done work-to-do))
(qif-import:check-pause progress-dialog) (qif-import:check-pause progress-dialog)
(if qif-import:canceled (if qif-import:canceled (throw 'cancel))))
(throw 'cancel)))))
(when progress-dialog
(if progress-dialog
(gnc-progress-dialog-set-sub progress-dialog (gnc-progress-dialog-set-sub progress-dialog
(_ "Finding duplicate transactions"))) (_ "Finding duplicate transactions")))
@ -122,16 +97,14 @@
;; First, we only want to find only transactions ;; First, we only want to find only transactions
;; from accounts in the old tree. ;; from accounts in the old tree.
(xaccQueryAddAccountMatch query (xaccQueryAddAccountMatch
old-accounts query old-accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
;; The date should be close to the same.. +/- a week. ;; The date should be close to the same.. +/- a week.
(let ((date (xaccTransGetDate xtn))) (let ((date (xaccTransGetDate xtn)))
(xaccQueryAddDateMatchTT query (xaccQueryAddDateMatchTT
#t (decdate date WeekDelta) query #t (decdate date WeekDelta)
#t (incdate date WeekDelta) #t (incdate date WeekDelta) QOF-QUERY-AND))
QOF-QUERY-AND))
;; For each split in the new transaction, add a ;; For each split in the new transaction, add a
;; term that can match on its properties. ;; term that can match on its properties.
@ -147,28 +120,23 @@
;; account), the match will be NULL and the query ;; account), the match will be NULL and the query
;; won't find anything. Optimize this later. ;; won't find anything. Optimize this later.
(xaccQueryAddSingleAccountMatch (xaccQueryAddSingleAccountMatch
sq sq (gnc-account-lookup-by-full-name
(gnc-account-lookup-by-full-name old-root old-root (gnc-account-get-full-name
(gnc-account-get-full-name
(xaccSplitGetAccount split))) (xaccSplitGetAccount split)))
QOF-QUERY-AND) QOF-QUERY-AND)
;; Require the value of the split in the new tree ;; Require the value of the split in the new tree
;; to match the the value of the split in the old ;; to match the the value of the split in the old
;; tree. We should really check for fuzziness. ;; tree. We should really check for fuzziness.
(xaccQueryAddValueMatch sq (xaccQueryAddValueMatch
(xaccSplitGetValue split) sq (xaccSplitGetValue split) QOF-NUMERIC-MATCH-ANY
QOF-NUMERIC-MATCH-ANY QOF-COMPARE-EQUAL QOF-QUERY-AND)
QOF-COMPARE-EQUAL
QOF-QUERY-AND)
;; Now merge into the split query. Reminder: q-splits ;; Now merge into the split query. Reminder: q-splits
;; must be merged with an OR. Otherwise, nothing will ;; must be merged with an OR. Otherwise, nothing will
;; match. (For example, something can be equal to 4 or ;; match. (For example, something can be equal to 4 or
;; to -4, but not both.) ;; to -4, but not both.)
(let ((q-new (qof-query-merge q-splits (let ((q-new (qof-query-merge q-splits sq QOF-QUERY-OR)))
sq
QOF-QUERY-OR)))
(qof-query-destroy q-splits) (qof-query-destroy q-splits)
(qof-query-destroy sq) (qof-query-destroy sq)
(set! q-splits q-new)))) (set! q-splits q-new))))
@ -176,9 +144,7 @@
;; Now q-splits will find every split that is the same as ;; Now q-splits will find every split that is the same as
;; any one split of the new-root transaction. Merge it in. ;; any one split of the new-root transaction. Merge it in.
(let ((q-new (qof-query-merge query (let ((q-new (qof-query-merge query q-splits QOF-QUERY-AND)))
q-splits
QOF-QUERY-AND)))
(qof-query-destroy query) (qof-query-destroy query)
(qof-query-destroy q-splits) (qof-query-destroy q-splits)
(set! query q-new))) (set! query q-new)))
@ -197,17 +163,14 @@
;; duplicates even if only one split matches. ;; duplicates even if only one split matches.
;; ;;
;; For more information, see bug 481528. ;; For more information, see bug 481528.
(let ((old-xtns (xaccQueryGetTransactions
query
(if (> num-splits 2)
QUERY-TXN-MATCH-ALL
QUERY-TXN-MATCH-ANY))))
;; Turn the resulting list of possibly duplicated (let ((old-xtns (map (lambda (elt) (cons elt #f))
;; transactions into an association list. (xaccQueryGetTransactions
(set! old-xtns (map query (if (> num-splits 2)
(lambda (elt) QUERY-TXN-MATCH-ALL
(cons elt #f)) old-xtns)) QUERY-TXN-MATCH-ANY)))))
(display "\n*** gnc:account-tree-find-duplicates\n")
(for-each pk old-xtns)
;; If anything matched the query, add it to our "matches" ;; If anything matched the query, add it to our "matches"
;; association list, keyed by the new-root transaction. ;; association list, keyed by the new-root transaction.
@ -219,20 +182,16 @@
new-xtns) new-xtns)
;; Finished. ;; Finished.
(if progress-dialog (when progress-dialog
(gnc-progress-dialog-set-value progress-dialog 1)) (gnc-progress-dialog-set-value progress-dialog 1))
;; Return the matches. ;; Return the matches.
matches) matches))
;; Since there are either no accounts or no transactions in the old ;; Since there are either no accounts or no transactions in the old
;; tree, duplicate checking is unnecessary. ;; tree, duplicate checking is unnecessary.
(begin (else
;; Finished. (when progress-dialog (gnc-progress-dialog-set-value progress-dialog 1))
(if progress-dialog
(gnc-progress-dialog-set-value progress-dialog 1))
;; Return an empty list.
'())))) '()))))
;; Safely do the work and return the result. ;; Safely do the work and return the result.
@ -252,20 +211,13 @@
(define (gnc:prune-matching-transactions match-list) (define (gnc:prune-matching-transactions match-list)
(for-each (for-each
(lambda (match) (lambda (txn-match)
(let ((new-xtn (car match)) (let ((new-xtn (car txn-match))
(matches (cdr match)) (matches (cdr txn-match)))
(do-delete #f)) (when (any cdr matches)
(for-each
(lambda (old)
(if (cdr old)
(set! do-delete #t)))
matches)
(if do-delete
(begin
(xaccTransBeginEdit new-xtn) (xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn) (xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn))))) (xaccTransCommitEdit new-xtn))))
match-list)) match-list))