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

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

@ -32,24 +32,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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)) xtns))))
;; 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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-find-duplicates ;; gnc:account-tree-find-duplicates
@ -74,170 +62,141 @@
;; 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
;; 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))
(work-to-do (length new-xtns))
(work-done 0)
(matches '()))
;; This procedure handles progress reporting, pause, and cancel. (cond
(define (update-progress) ((any pair? (map xaccAccountGetSplitList old-accounts))
(set! work-done (+ 1 work-done)) ;; Get all the transactions in the new tree, thisthen iterate
(if (and progress-dialog ;; over them trying to find matches in the old tree. If
(zero? (remainder work-done 8))) ;; there are matches, push the matches onto a list.
(begin (let* ((new-xtns (gnc:account-tree-get-transactions new-root))
(gnc-progress-dialog-set-value progress-dialog (work-to-do (length new-xtns))
(/ work-done work-to-do)) (work-done 0)
(qif-import:check-pause progress-dialog) (matches '()))
(if qif-import:canceled
(throw 'cancel)))))
;; This procedure handles progress reporting, pause, and cancel.
(define (update-progress)
(set! work-done (+ 1 work-done))
(when (and progress-dialog (zero? (modulo work-done 8)))
(gnc-progress-dialog-set-value progress-dialog
(/ work-done work-to-do))
(qif-import:check-pause progress-dialog)
(if qif-import:canceled (throw 'cancel))))
(if progress-dialog (when progress-dialog
(gnc-progress-dialog-set-sub progress-dialog (gnc-progress-dialog-set-sub progress-dialog
(_ "Finding duplicate transactions"))) (_ "Finding duplicate transactions")))
;; For each transaction in the new account tree, build a query ;; For each transaction in the new account tree, build a query
;; that matches possibly duplicate transactions in the old tree. ;; that matches possibly duplicate transactions in the old tree.
(for-each (for-each
(lambda (xtn) (lambda (xtn)
(let ((query (qof-query-create-for-splits)) (let ((query (qof-query-create-for-splits))
(num-splits 0)) (num-splits 0))
(qof-query-set-book query (gnc-account-get-book old-root)) (qof-query-set-book query (gnc-account-get-book old-root))
;; 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.
(let ((q-splits (qof-query-create-for-splits))) (let ((q-splits (qof-query-create-for-splits)))
(for-each (for-each
(lambda (split) (lambda (split)
(set! num-splits (+ num-splits 1)) (set! num-splits (+ num-splits 1))
(let ((sq (qof-query-create-for-splits))) (let ((sq (qof-query-create-for-splits)))
(qof-query-set-book sq (gnc-account-get-book old-root)) (qof-query-set-book sq (gnc-account-get-book old-root))
;; Require a match on the account name. If the name ;; Require a match on the account name. If the name
;; doesn't exist in the old tree (indicating a new ;; doesn't exist in the old tree (indicating a new
;; 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-destroy q-splits)
QOF-QUERY-OR))) (qof-query-destroy sq)
(qof-query-destroy q-splits) (set! q-splits q-new))))
(qof-query-destroy sq) (xaccTransGetSplitList xtn))
(set! q-splits q-new))))
(xaccTransGetSplitList xtn))
;; 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-destroy query)
QOF-QUERY-AND))) (qof-query-destroy q-splits)
(qof-query-destroy query) (set! query q-new)))
(qof-query-destroy q-splits)
(set! query q-new)))
;; Now that we have built a query that finds matching splits ;; Now that we have built a query that finds matching splits
;; in the old tree, run it and build a list of transactions ;; in the old tree, run it and build a list of transactions
;; from the results. ;; from the results.
;; ;;
;; If the transaction from the new tree has more than two ;; If the transaction from the new tree has more than two
;; splits, then we'll assume that it fully reflects what ;; splits, then we'll assume that it fully reflects what
;; occurred, and only consider transactions in the old tree ;; occurred, and only consider transactions in the old tree
;; that match with every single split. ;; that match with every single split.
;; ;;
;; All other new transactions could be incomplete, so we'll ;; All other new transactions could be incomplete, so we'll
;; consider transactions from the old tree to be possible ;; consider transactions from the old tree to be possible
;; 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.
(if (not (null? old-xtns)) (if (not (null? old-xtns))
(set! matches (cons (cons xtn old-xtns) matches)))) (set! matches (cons (cons xtn old-xtns) matches))))
(qof-query-destroy query)) (qof-query-destroy query))
(update-progress)) (update-progress))
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.
(gnc:backtrace-if-exception (gnc:backtrace-if-exception
(lambda () (catch 'cancel private-find (lambda (key . args) #t))))) (lambda () (catch 'cancel private-find (lambda (key . args) #t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -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 (xaccTransBeginEdit new-xtn)
(lambda (old) (xaccTransDestroy new-xtn)
(if (cdr old) (xaccTransCommitEdit new-xtn))))
(set! do-delete #t)))
matches)
(if do-delete
(begin
(xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn)))))
match-list)) match-list))