-
Notifications
You must be signed in to change notification settings - Fork 761
/
qif-merge-groups.scm
194 lines (173 loc) · 8.08 KB
/
qif-merge-groups.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; qif-merge-groups.scm
;;; eliminate duplicate xtns in a new (imported) account group
;;;
;;; Copyright 2001 Bill Gribble <grib@billgribble.com>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 qif-import qif-merge-groups))
(eval-when (compile load eval expand)
(load-extension "libgnc-gnome" "scm_init_sw_gnome_module"))
(use-modules (sw_gnome))
(use-modules (gnucash core-utils))
(use-modules (gnucash engine))
(use-modules (gnucash app-utils))
(use-modules (srfi srfi-1))
(use-modules (gnucash qif-import qif-utils))
(export gnc:account-tree-catenate-and-merge)
(export gnc:account-tree-find-duplicates)
(export gnc:prune-matching-transactions)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-find-duplicates
;;
;; Given two account trees, old-root and new-root, a search is
;; performed to determine, for each transaction in new-root,
;; whether there are any transactions in old-root that may be
;; duplicated by it.
;;
;; The search results are returned in an association list, with
;; new-root transactions as the keys. The value associated with
;; each key is a second association list of possibly duplicated
;; transactions in the old-root, taking the form:
;; ( (old-xtn . #f) (old-xtn . #f) (old-xtn . #f) ... )
;;
;; The druid can then ask the user for a final determination,
;; and change #f to #t where duplication is found.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-find-duplicates old-root new-root progress-dialog)
(define old-accounts (gnc-account-get-descendants-sorted old-root))
(define (progress v)
(when progress-dialog (gnc-progress-dialog-set-value progress-dialog v)))
;; This procedure does all the work. We'll define it, then call it safely.
(define (private-find)
(cond
((any (compose pair? xaccAccountGetSplitList) old-accounts)
;; Get all the splits in the new tree, then iterate over them
;; trying to find matches in the old tree. If there are
;; matches, push the splits' parent onto a list.
(let ((WeekSecs (* 60 60 24 7)))
(define new-splits
(let ((q (qof-query-create-for-splits))
(accounts (gnc-account-get-descendants-sorted new-root)))
(qof-query-set-book q (gnc-account-get-book new-root))
(xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(let ((new-splits (qof-query-run q)))
(qof-query-destroy q)
new-splits)))
(define old-splits
(let ((q (qof-query-create-for-splits))
(dates (map (compose xaccTransGetDate xaccSplitGetParent) new-splits)))
(qof-query-set-book q (gnc-account-get-book old-root))
(xaccQueryAddAccountMatch q old-accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q
#t (decdate (apply min dates) WeekDelta)
#t (incdate (apply max dates) WeekDelta)
QOF-QUERY-AND)
(let ((splits (qof-query-run q)))
(qof-query-destroy q)
splits)))
(define work-to-do (length new-splits))
(define (update-progress work-done)
(when (and progress-dialog (zero? (modulo work-done 8)))
(progress (/ work-done work-to-do))
(qif-import:check-pause progress-dialog)
(if qif-import:canceled (throw 'cancel))))
(when progress-dialog
(gnc-progress-dialog-set-sub progress-dialog
(G_ "Finding duplicate transactions")))
(let loop ((new-splits new-splits)
(work-done 0)
(matches '()))
(cond
((null? new-splits)
(progress 1)
matches)
((assoc (xaccSplitGetParent (car new-splits)) matches)
;; txn has already been matched, by another split within same txn
(loop (cdr new-splits)
(1+ work-done)
matches))
(else
(let* ((new-split (car new-splits))
(candidate-old-splits
(filter
(lambda (old-split)
(and
;; split value matches
(= (xaccSplitGetValue old-split)
(xaccSplitGetValue new-split))
;; account name matches
(string=?
(gnc-account-get-full-name (xaccSplitGetAccount old-split))
(gnc-account-get-full-name (xaccSplitGetAccount new-split)))
;; maximum 1 week date difference
(<= (abs (- (xaccTransGetDate (xaccSplitGetParent old-split))
(xaccTransGetDate (xaccSplitGetParent new-split))))
WeekSecs)))
old-splits)))
(update-progress work-done)
(loop (cdr new-splits)
(1+ work-done)
(if (null? candidate-old-splits)
matches
(cons (cons (xaccSplitGetParent new-split)
(map (lambda (s) (cons (xaccSplitGetParent s) #f))
candidate-old-splits))
matches)))))))))
;; Since there are either no accounts or no transactions in the old
;; tree, duplicate checking is unnecessary.
(else
(progress 1)
'())))
;; Safely do the work and return the result.
(gnc:backtrace-if-exception
(lambda () (catch 'cancel private-find (const #t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:prune-matching-transactions
;;
;; The parameter, match-list, is an association list of the form
;; returned by gnc:account-tree-find-duplicates. This procedure
;; looks through the list and discards any transaction that has
;; been definitively determined to be a duplicate of one of the
;; possible matches.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:prune-matching-transactions match-list)
(for-each
(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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-catenate-and-merge
;;
;; The procedure moves the entire contents of one account tree,
;; new-root, to a second account tree, old-root, and merges any
;; duplicated accounts.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-catenate-and-merge old-root new-root)
;; stuff the new accounts into the old account tree and merge the accounts
(gnc-account-join-children old-root new-root)
(xaccAccountBeginEdit new-root)
(xaccAccountDestroy new-root)
(gnc-account-merge-children old-root))