r16893 - gnucash/branches/2.2/src/import-export/qif-import - [r16873] Improve the QIF txn matcher (#336211)
Andreas Köhler
andi5 at cvs.gnucash.org
Wed Jan 30 15:24:48 EST 2008
Author: andi5
Date: 2008-01-30 15:24:48 -0500 (Wed, 30 Jan 2008)
New Revision: 16893
Trac: http://svn.gnucash.org/trac/changeset/16893
Modified:
gnucash/branches/2.2/src/import-export/qif-import/qif-merge-groups.scm
Log:
[r16873] Improve the QIF txn matcher (#336211)
Don't run it when we have no accounts or empty accounts.
Cache the account list early on.
Patch by Charles Day.
Modified: gnucash/branches/2.2/src/import-export/qif-import/qif-merge-groups.scm
===================================================================
--- gnucash/branches/2.2/src/import-export/qif-import/qif-merge-groups.scm 2008-01-30 20:24:39 UTC (rev 16892)
+++ gnucash/branches/2.2/src/import-export/qif-import/qif-merge-groups.scm 2008-01-30 20:24:48 UTC (rev 16893)
@@ -1,156 +1,187 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; qif-merge-groups.scm
-;;; eliminate duplicate xtns in a new (imported) account group
+;;; eliminate duplicate xtns in a new (imported) account group
;;;
-;;; Copyright 2001 Bill Gribble <grib at billgribble.com>
+;;; Copyright 2001 Bill Gribble <grib at billgribble.com>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-get-transactions root)
- (let ((query (qof-query-create-for-splits))
- (xtns #f))
+ (let ((accounts (gnc-account-get-descendants-sorted root)))
+ (if (null? accounts)
+ '()
+ (let ((query (qof-query-create-for-splits))
+ (xtns #f))
- (qof-query-set-book query (gnc-account-get-book root))
+ (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
- (gnc-account-get-descendants-sorted root)
- QOF-GUID-MATCH-ANY QOF-QUERY-AND)
+ ;; 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))
+ (set! xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL))
+ ;; lose the query
+ (qof-query-destroy query)
+ xtns))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; gnc:account-tree-find-duplicates
-;; detect redundant splits/xtns from 'new' and return
-;; them in a list.
+;; gnc:account-tree-find-duplicates
+;;
+;; This procedure compares two account trees, given by old-root
+;; and new-root, and returns a list of splits/transactions in
+;; old-root that may be duplicates.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-find-duplicates old-root new-root window)
- ;; get all the transactions in the new group, then iterate over them
- ;; trying to find matches in the new group. If there are matches,
- ;; push the matches onto a list.
- (let* ((new-xtns (gnc:account-tree-get-transactions new-root))
- (progress-dialog '())
- (work-to-do (length new-xtns))
- (work-done 0)
- (matches '()))
-
- (if (> work-to-do 100)
- (begin
- (set! progress-dialog (gnc-progress-dialog-new window #f))
- (gnc-progress-dialog-set-title progress-dialog (_ "Progress"))
- (gnc-progress-dialog-set-heading progress-dialog
- (_ "Finding duplicate transactions..."))))
- ;; for each transaction in the new account tree, build a query that could
- ;; match possibly similar transactions.
- (for-each
- (lambda (xtn)
- (let ((query (qof-query-create-for-splits)))
- (set! work-done (+ 1 work-done))
- (if (not (null? progress-dialog))
- (begin
- (gnc-progress-dialog-set-value
- progress-dialog (/ work-done work-to-do))
- (gnc-progress-dialog-update progress-dialog)))
+ ;; 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))))
- (qof-query-set-book query (gnc-account-get-book 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))
+ (progress-dialog '())
+ (work-to-do (length new-xtns))
+ (work-done 0)
+ (matches '()))
- ;; first, we want to find only transactions from the old group.
- (xaccQueryAddAccountMatch query
- (gnc-account-get-descendants-sorted old-root)
- QOF-GUID-MATCH-ANY QOF-QUERY-AND)
-
- ;; the date should be close to the same.. +/- a week.
- (let ((date (gnc-transaction-get-date-posted xtn)))
- (xaccQueryAddDateMatchTS
- query #t (decdate date WeekDelta) #t (incdate date WeekDelta)
- QOF-QUERY-AND))
-
- ;; for each split in the transaction, add a term to match the
- ;; properties of one split
- (let ((q-splits (qof-query-create-for-splits)))
- (for-each
- (lambda (split)
- (let ((sq (qof-query-create-for-splits)))
- (qof-query-set-book sq (gnc-account-get-book old-root))
-
- ;; we want to match the account in the old account
- ;; tree that has the same name as an account in the
- ;; new account tree. If there's not one (new
- ;; account), the match will be NULL and we know the
- ;; query won't find anything. optimize this later.
- (xaccQueryAddSingleAccountMatch
- sq
- (gnc-account-lookup-by-full-name
- old-root (gnc-account-get-full-name
- (xaccSplitGetAccount split)))
- QOF-QUERY-AND)
-
- ;; we want the value for the split to match the value
- ;; the old-root split. We should really check for
- ;; fuzziness.
- (xaccQueryAddValueMatch
- sq (xaccSplitGetValue split)
- QOF-NUMERIC-MATCH-ANY QOF-COMPARE-EQUAL
- QOF-QUERY-AND)
-
- ;; now merge into the split query. Reminder: q-splits
- ;; is set up to match any split that matches any split
- ;; in the current xtn; every split in an old transaction
- ;; must pass that filter.
- (let ((q-new (qof-query-merge q-splits sq QOF-QUERY-OR)))
- (qof-query-destroy q-splits)
- (qof-query-destroy sq)
- (set! q-splits q-new))))
- (xaccTransGetSplitList xtn))
-
- ;; now q-splits will match any split that is the same as one
- ;; split in the old-root xtn. Merge it in.
- (let ((q-new (qof-query-merge query q-splits QOF-QUERY-AND)))
- (qof-query-destroy query)
- (qof-query-destroy q-splits)
- (set! query q-new)))
-
- ;; now that we have built a query, get transactions in the old
- ;; account tree that matches it.
- (let ((old-xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL)))
- (set! old-xtns (map
- (lambda (elt)
- (cons elt #f)) old-xtns))
-
- ;; if anything matched the query, push it onto the matches list
- ;; along with the transaction
- (if (not (null? old-xtns))
- (set! matches (cons (cons xtn old-xtns) matches))))
- (qof-query-destroy query)))
- new-xtns)
-
- ;; get rid of the progress dialog
- (if (not (null? progress-dialog))
- (gnc-progress-dialog-destroy progress-dialog))
+ ;; Use a progress dialog if this might take a while.
+ (if (> work-to-do 100)
+ (begin
+ (set! progress-dialog (gnc-progress-dialog-new window #f))
+ (gnc-progress-dialog-set-title progress-dialog (_ "Progress"))
+ (gnc-progress-dialog-set-heading progress-dialog
+ (_ "Finding duplicate transactions..."))))
- ;; return the matches
- matches))
-
+ ;; For each transaction in the new account tree, build a query
+ ;; that matches possibly duplicate transactions in the old tree.
+ (for-each
+ (lambda (xtn)
+ (let ((query (qof-query-create-for-splits)))
+ (set! work-done (+ 1 work-done))
+ (if (not (null? progress-dialog))
+ (begin
+ (gnc-progress-dialog-set-value progress-dialog
+ (/ work-done work-to-do))
+ (gnc-progress-dialog-update progress-dialog)))
+
+ (qof-query-set-book query (gnc-account-get-book old-root))
+
+ ;; First, we only want to find only transactions
+ ;; from accounts in the old tree.
+ (xaccQueryAddAccountMatch query
+ old-accounts
+ QOF-GUID-MATCH-ANY QOF-QUERY-AND)
+
+ ;; The date should be close to the same.. +/- a week.
+ (let ((date (gnc-transaction-get-date-posted xtn)))
+ (xaccQueryAddDateMatchTS query #t
+ (decdate date WeekDelta) #t
+ (incdate date WeekDelta)
+ QOF-QUERY-AND))
+
+ ;; For each split in the transaction, add a term
+ ;; to match the properties of one split.
+ (let ((q-splits (qof-query-create-for-splits)))
+ (for-each
+ (lambda (split)
+ (let ((sq (qof-query-create-for-splits)))
+ (qof-query-set-book sq (gnc-account-get-book old-root))
+
+ ;; We want to match the account in the old tree that
+ ;; has the same name as an account in the new tree.
+ ;; If there's not one (indicating a new account),
+ ;; the match will be NULL and the query won't find
+ ;; anything. Optimize this later.
+ (xaccQueryAddSingleAccountMatch
+ sq
+ (gnc-account-lookup-by-full-name old-root
+ (gnc-account-get-full-name
+ (xaccSplitGetAccount split)))
+ QOF-QUERY-AND)
+
+ ;; We want the value of the split in the new tree
+ ;; to match the the value of the split in the old
+ ;; tree. We should really check for fuzziness.
+ (xaccQueryAddValueMatch sq
+ (xaccSplitGetValue split)
+ QOF-NUMERIC-MATCH-ANY
+ QOF-COMPARE-EQUAL
+ QOF-QUERY-AND)
+
+ ;; Now merge into the split query. Reminder: q-splits
+ ;; is set up to match any split that matches any split
+ ;; in the new transaction; every split in an old
+ ;; transaction must pass that filter.
+ (let ((q-new (qof-query-merge q-splits
+ sq
+ QOF-QUERY-OR)))
+ (qof-query-destroy q-splits)
+ (qof-query-destroy sq)
+ (set! q-splits q-new))))
+ (xaccTransGetSplitList xtn))
+
+ ;; Now q-splits will match any split that is the same as one
+ ;; split in the old-root transaction. Merge it in.
+ (let ((q-new (qof-query-merge query
+ q-splits
+ QOF-QUERY-AND)))
+ (qof-query-destroy query)
+ (qof-query-destroy q-splits)
+ (set! query q-new)))
+
+ ;; Now that we have built a query, get transactions in the old
+ ;; account tree that match it.
+ (let ((old-xtns (xaccQueryGetTransactions query
+ QUERY-TXN-MATCH-ALL)))
+ (set! old-xtns (map
+ (lambda (elt)
+ (cons elt #f)) old-xtns))
+
+ ;; If anything matched the query, push it onto the matches
+ ;; list along with the transaction.
+ (if (not (null? old-xtns))
+ (set! matches (cons (cons xtn old-xtns) matches))))
+
+ (qof-query-destroy query)))
+ new-xtns)
+
+ ;; Get rid of the progress dialog.
+ (if (not (null? progress-dialog))
+ (gnc-progress-dialog-destroy progress-dialog))
+
+ ;; Return the matches.
+ matches)
+
+ ;; Since there are either no accounts or no transactions in the old
+ ;; tree, duplicate checking is unnecessary. Return an empty list.
+ '())))
+
(define (gnc:prune-matching-transactions match-list)
- (for-each
+ (for-each
(lambda (match)
(let ((new-xtn (car match))
(matches (cdr match))
(do-delete #f))
- (for-each
+ (for-each
(lambda (old)
(if (cdr old)
(set! do-delete #t)))
matches)
- (if do-delete
- (begin
+ (if do-delete
+ (begin
(xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn)))))
More information about the gnucash-changes
mailing list