diff --git a/gnucash/import-export/qif-imp/qif-merge-groups.scm b/gnucash/import-export/qif-imp/qif-merge-groups.scm index b53c872400..9bf5c2fb9b 100644 --- a/gnucash/import-export/qif-imp/qif-merge-groups.scm +++ b/gnucash/import-export/qif-imp/qif-merge-groups.scm @@ -32,24 +32,12 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (gnc:account-tree-get-transactions root) (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)) - - ;; 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)))) - + (let ((q (qof-query-create-for-splits))) + (qof-query-set-book q (gnc-account-get-book root)) + (xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND) + (let ((xtns (xaccQueryGetTransactions q QUERY-TXN-MATCH-ALL))) + (qof-query-destroy q) + xtns)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; gnc:account-tree-find-duplicates @@ -74,170 +62,141 @@ ;; This procedure does all the work. We'll define it, then call it safely. (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))) - (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. - (define (update-progress) - (set! work-done (+ 1 work-done)) - (if (and progress-dialog - (zero? (remainder work-done 8))) - (begin - (gnc-progress-dialog-set-value progress-dialog - (/ work-done work-to-do)) - (qif-import:check-pause progress-dialog) - (if qif-import:canceled - (throw 'cancel))))) + (cond + ((any pair? (map xaccAccountGetSplitList old-accounts)) + ;; 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)) + (work-to-do (length new-xtns)) + (work-done 0) + (matches '())) + ;; 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 - (gnc-progress-dialog-set-sub progress-dialog + (when progress-dialog + (gnc-progress-dialog-set-sub progress-dialog (_ "Finding duplicate transactions"))) - ;; 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)) - (num-splits 0)) - (qof-query-set-book query (gnc-account-get-book old-root)) + ;; 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)) + (num-splits 0)) + (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) + ;; 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 (xaccTransGetDate xtn))) - (xaccQueryAddDateMatchTT query - #t (decdate date WeekDelta) - #t (incdate date WeekDelta) - QOF-QUERY-AND)) + ;; The date should be close to the same.. +/- a week. + (let ((date (xaccTransGetDate xtn))) + (xaccQueryAddDateMatchTT + query #t (decdate date WeekDelta) + #t (incdate date WeekDelta) QOF-QUERY-AND)) - ;; For each split in the new transaction, add a - ;; term that can match on its properties. - (let ((q-splits (qof-query-create-for-splits))) - (for-each - (lambda (split) - (set! num-splits (+ num-splits 1)) - (let ((sq (qof-query-create-for-splits))) - (qof-query-set-book sq (gnc-account-get-book old-root)) + ;; For each split in the new transaction, add a + ;; term that can match on its properties. + (let ((q-splits (qof-query-create-for-splits))) + (for-each + (lambda (split) + (set! num-splits (+ num-splits 1)) + (let ((sq (qof-query-create-for-splits))) + (qof-query-set-book sq (gnc-account-get-book old-root)) - ;; Require a match on the account name. If the name - ;; doesn't exist in the old tree (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) + ;; Require a match on the account name. If the name + ;; doesn't exist in the old tree (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) - ;; Require 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) + ;; Require 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 - ;; must be merged with an OR. Otherwise, nothing will - ;; match. (For example, something can be equal to 4 or - ;; to -4, but not both.) - (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 merge into the split query. Reminder: q-splits + ;; must be merged with an OR. Otherwise, nothing will + ;; match. (For example, something can be equal to 4 or + ;; to -4, but not both.) + (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 find every split that is the same as - ;; any one split of the new-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 q-splits will find every split that is the same as + ;; any one split of the new-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 that finds matching splits - ;; in the old tree, run it and build a list of transactions - ;; from the results. - ;; - ;; If the transaction from the new tree has more than two - ;; splits, then we'll assume that it fully reflects what - ;; occurred, and only consider transactions in the old tree - ;; that match with every single split. - ;; - ;; All other new transactions could be incomplete, so we'll - ;; consider transactions from the old tree to be possible - ;; duplicates even if only one split matches. - ;; - ;; For more information, see bug 481528. - (let ((old-xtns (xaccQueryGetTransactions - query - (if (> num-splits 2) - QUERY-TXN-MATCH-ALL - QUERY-TXN-MATCH-ANY)))) + ;; Now that we have built a query that finds matching splits + ;; in the old tree, run it and build a list of transactions + ;; from the results. + ;; + ;; If the transaction from the new tree has more than two + ;; splits, then we'll assume that it fully reflects what + ;; occurred, and only consider transactions in the old tree + ;; that match with every single split. + ;; + ;; All other new transactions could be incomplete, so we'll + ;; consider transactions from the old tree to be possible + ;; duplicates even if only one split matches. + ;; + ;; For more information, see bug 481528. - ;; Turn the resulting list of possibly duplicated - ;; transactions into an association list. - (set! old-xtns (map - (lambda (elt) - (cons elt #f)) old-xtns)) + (let ((old-xtns (map (lambda (elt) (cons elt #f)) + (xaccQueryGetTransactions + query (if (> num-splits 2) + QUERY-TXN-MATCH-ALL + 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" - ;; association list, keyed by the new-root transaction. - (if (not (null? old-xtns)) - (set! matches (cons (cons xtn old-xtns) matches)))) + ;; If anything matched the query, add it to our "matches" + ;; association list, keyed by the new-root transaction. + (if (not (null? old-xtns)) + (set! matches (cons (cons xtn old-xtns) matches)))) - (qof-query-destroy query)) - (update-progress)) - new-xtns) + (qof-query-destroy query)) + (update-progress)) + new-xtns) - ;; Finished. - (if progress-dialog - (gnc-progress-dialog-set-value progress-dialog 1)) + ;; Finished. + (when progress-dialog + (gnc-progress-dialog-set-value progress-dialog 1)) - ;; Return the matches. - matches) + ;; Return the matches. + matches)) - ;; Since there are either no accounts or no transactions in the old - ;; tree, duplicate checking is unnecessary. - (begin - ;; Finished. - (if progress-dialog - (gnc-progress-dialog-set-value progress-dialog 1)) - - ;; Return an empty list. - '())))) + ;; Since there are either no accounts or no transactions in the old + ;; tree, duplicate checking is unnecessary. + (else + (when progress-dialog (gnc-progress-dialog-set-value progress-dialog 1)) + '())))) ;; Safely do the work and return the result. (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) (for-each - (lambda (match) - (let ((new-xtn (car match)) - (matches (cdr match)) - (do-delete #f)) - (for-each - (lambda (old) - (if (cdr old) - (set! do-delete #t))) - matches) - (if do-delete - (begin - (xaccTransBeginEdit new-xtn) - (xaccTransDestroy new-xtn) - (xaccTransCommitEdit new-xtn))))) + (lambda (txn-match) + (let ((new-xtn (car txn-match)) + (matches (cdr txn-match))) + (when (any cdr matches) + (xaccTransBeginEdit new-xtn) + (xaccTransDestroy new-xtn) + (xaccTransCommitEdit new-xtn)))) match-list))