AUDIT: r16954 - gnucash/trunk/src/import-export/qif-import - Bug#516178: Prevent unresponsive QIF druid by cleaning up any existing progress
Charles Day
cedayiv at cvs.gnucash.org
Sat Feb 23 00:39:34 EST 2008
Author: cedayiv
Date: 2008-02-23 00:39:34 -0500 (Sat, 23 Feb 2008)
New Revision: 16954
Trac: http://svn.gnucash.org/trac/changeset/16954
Modified:
gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm
Log:
Bug#516178: Prevent unresponsive QIF druid by cleaning up any existing progress
dialog if a Scheme error should occur during conversion.
BP
Modified: gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm
===================================================================
--- gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm 2008-02-23 04:54:51 UTC (rev 16953)
+++ gnucash/trunk/src/import-export/qif-import/qif-to-gnc.scm 2008-02-23 05:39:34 UTC (rev 16954)
@@ -204,188 +204,193 @@
qif-acct-map qif-cat-map
qif-memo-map stock-map
default-currency-name window)
- (gnc:backtrace-if-exception
- (lambda ()
- (let* ((old-root (gnc-get-current-root-account))
- (new-root (xaccMallocAccount (gnc-get-current-book)))
- (gnc-acct-hash (make-hash-table 20))
- (separator (string-ref (gnc-get-account-separator-string) 0))
- (default-currency
- (gnc-commodity-table-find-full
- (gnc-commodity-table-get-table (gnc-get-current-book))
- GNC_COMMODITY_NS_CURRENCY default-currency-name))
- (sorted-accounts-list '())
- (markable-xtns '())
- (sorted-qif-files-list
- (sort qif-files-list
- (lambda (a b)
- (> (length (qif-file:xtns a))
- (length (qif-file:xtns b))))))
- (progress-dialog '())
- (work-to-do 0)
- (work-done 0))
+ (let ((progress-dialog '())
+ (retval #f))
+ (set! retval
+ (gnc:backtrace-if-exception
+ (lambda ()
+ (let* ((old-root (gnc-get-current-root-account))
+ (new-root (xaccMallocAccount (gnc-get-current-book)))
+ (gnc-acct-hash (make-hash-table 20))
+ (separator (string-ref (gnc-get-account-separator-string) 0))
+ (default-currency
+ (gnc-commodity-table-find-full
+ (gnc-commodity-table-get-table (gnc-get-current-book))
+ GNC_COMMODITY_NS_CURRENCY default-currency-name))
+ (sorted-accounts-list '())
+ (markable-xtns '())
+ (sorted-qif-files-list
+ (sort qif-files-list
+ (lambda (a b)
+ (> (length (qif-file:xtns a))
+ (length (qif-file:xtns b))))))
+ (work-to-do 0)
+ (work-done 0))
- ;; first, build a local account tree that mirrors the gnucash
- ;; accounts in the mapping data. we need to iterate over the
- ;; cat-map and the acct-map to build the list
- (hash-fold
- (lambda (k v p)
- (if (qif-map-entry:display? v)
- (set! sorted-accounts-list
- (cons v sorted-accounts-list)))
- #t)
- #t qif-acct-map)
+ ;; first, build a local account tree that mirrors the gnucash
+ ;; accounts in the mapping data. we need to iterate over the
+ ;; cat-map and the acct-map to build the list
+ (hash-fold
+ (lambda (k v p)
+ (if (qif-map-entry:display? v)
+ (set! sorted-accounts-list
+ (cons v sorted-accounts-list)))
+ #t)
+ #t qif-acct-map)
- (hash-fold
- (lambda (k v p)
- (if (qif-map-entry:display? v)
- (set! sorted-accounts-list
- (cons v sorted-accounts-list)))
- #t)
- #t qif-cat-map)
+ (hash-fold
+ (lambda (k v p)
+ (if (qif-map-entry:display? v)
+ (set! sorted-accounts-list
+ (cons v sorted-accounts-list)))
+ #t)
+ #t qif-cat-map)
- (hash-fold
- (lambda (k v p)
- (if (qif-map-entry:display? v)
- (set! sorted-accounts-list
- (cons v sorted-accounts-list)))
- #t)
- #t qif-memo-map)
+ (hash-fold
+ (lambda (k v p)
+ (if (qif-map-entry:display? v)
+ (set! sorted-accounts-list
+ (cons v sorted-accounts-list)))
+ #t)
+ #t qif-memo-map)
- ;; sort the account info on the depth of the account path. if a
- ;; short part is explicitly mentioned, make sure it gets created
- ;; before the deeper path, which will create the parent accounts
- ;; without the information about their type.
- (set! sorted-accounts-list
- (sort sorted-accounts-list
- (lambda (a b)
- (let ((a-depth
- (length
- (string-split (qif-map-entry:gnc-name a)
- separator)))
- (b-depth
- (length
- (string-split (qif-map-entry:gnc-name b)
- separator))))
- (< a-depth b-depth)))))
+ ;; sort the account info on the depth of the account path. if a
+ ;; short part is explicitly mentioned, make sure it gets created
+ ;; before the deeper path, which will create the parent accounts
+ ;; without the information about their type.
+ (set! sorted-accounts-list
+ (sort sorted-accounts-list
+ (lambda (a b)
+ (let ((a-depth
+ (length
+ (string-split (qif-map-entry:gnc-name a)
+ separator)))
+ (b-depth
+ (length
+ (string-split (qif-map-entry:gnc-name b)
+ separator))))
+ (< a-depth b-depth)))))
- ;; make all the accounts
- (for-each
- (lambda (acctinfo)
- (let* ((security
- (and stock-map
- (hash-ref stock-map
- (qif-import:get-account-name
- (qif-map-entry:qif-name acctinfo)))))
- (ok-types (qif-map-entry:allowed-types acctinfo))
- (equity? (memv GNC-EQUITY-TYPE ok-types))
- (stock? (or (memv GNC-STOCK-TYPE ok-types)
- (memv GNC-MUTUAL-TYPE ok-types))))
+ ;; make all the accounts
+ (for-each
+ (lambda (acctinfo)
+ (let* ((security
+ (and stock-map
+ (hash-ref stock-map
+ (qif-import:get-account-name
+ (qif-map-entry:qif-name acctinfo)))))
+ (ok-types (qif-map-entry:allowed-types acctinfo))
+ (equity? (memv GNC-EQUITY-TYPE ok-types))
+ (stock? (or (memv GNC-STOCK-TYPE ok-types)
+ (memv GNC-MUTUAL-TYPE ok-types))))
- ;; Debug
- ;; (for-each
- ;; (lambda (expr)
- ;; (display expr))
- ;; (list "Account: " acctinfo "\nsecurity = " security
- ;; "\nequity? = " equity?
- ;; "\n"))
+ ;; Debug
+ ;; (for-each
+ ;; (lambda (expr)
+ ;; (display expr))
+ ;; (list "Account: " acctinfo "\nsecurity = " security
+ ;; "\nequity? = " equity?
+ ;; "\n"))
- (cond ((and equity? security) ;; a "retained holdings" acct
- (qif-import:find-or-make-acct acctinfo #f
- security #t default-currency
- gnc-acct-hash
- old-root new-root))
- ((and security (or stock?
- (gnc-commodity-is-currency security)))
- (qif-import:find-or-make-acct
- acctinfo #f security #t default-currency
- gnc-acct-hash old-root new-root))
- (#t
- (qif-import:find-or-make-acct
- acctinfo #f default-currency #t default-currency
- gnc-acct-hash old-root new-root)))))
- sorted-accounts-list)
+ (cond ((and equity? security) ;; a "retained holdings" acct
+ (qif-import:find-or-make-acct acctinfo #f
+ security #t
+ default-currency
+ gnc-acct-hash
+ old-root new-root))
+ ((and security (or stock?
+ (gnc-commodity-is-currency security)))
+ (qif-import:find-or-make-acct
+ acctinfo #f security #t default-currency
+ gnc-acct-hash old-root new-root))
+ (#t
+ (qif-import:find-or-make-acct
+ acctinfo #f default-currency #t default-currency
+ gnc-acct-hash old-root new-root)))))
+ sorted-accounts-list)
- ;; before trying to mark transactions, prune down the list of
- ;; ones to match.
- (for-each
- (lambda (qif-file)
- (for-each
- (lambda (xtn)
- (set! work-to-do (+ 1 work-to-do))
- (let splitloop ((splits (qif-xtn:splits xtn)))
- (if (qif-split:category-is-account? (car splits))
- (begin
- (set! markable-xtns (cons xtn markable-xtns))
- (set! work-to-do (+ 1 work-to-do)))
- (if (not (null? (cdr splits)))
- (splitloop (cdr splits))))))
- (qif-file:xtns qif-file)))
- qif-files-list)
+ ;; before trying to mark transactions, prune down the list of
+ ;; ones to match.
+ (for-each
+ (lambda (qif-file)
+ (for-each
+ (lambda (xtn)
+ (set! work-to-do (+ 1 work-to-do))
+ (let splitloop ((splits (qif-xtn:splits xtn)))
+ (if (qif-split:category-is-account? (car splits))
+ (begin
+ (set! markable-xtns (cons xtn markable-xtns))
+ (set! work-to-do (+ 1 work-to-do)))
+ (if (not (null? (cdr splits)))
+ (splitloop (cdr splits))))))
+ (qif-file:xtns qif-file)))
+ qif-files-list)
- (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
- (_ "Importing transactions..."))))
+ (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
+ (_ "Importing transactions..."))))
- ;; now run through the markable transactions marking any
- ;; duplicates. marked transactions/splits won't get imported.
- (if (> (length markable-xtns) 1)
- (let xloop ((xtn (car markable-xtns))
- (rest (cdr markable-xtns)))
- (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)))
- (if (not (qif-xtn:mark xtn))
- (qif-import:mark-matching-xtns xtn rest))
- (if (not (null? (cdr rest)))
- (xloop (car rest) (cdr rest)))))
+ ;; now run through the markable transactions marking any
+ ;; duplicates. marked transactions/splits won't get imported.
+ (if (> (length markable-xtns) 1)
+ (let xloop ((xtn (car markable-xtns))
+ (rest (cdr markable-xtns)))
+ (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)))
+ (if (not (qif-xtn:mark xtn))
+ (qif-import:mark-matching-xtns xtn rest))
+ (if (not (null? (cdr rest)))
+ (xloop (car rest) (cdr rest)))))
- ;; iterate over files. Going in the sort order by number of
- ;; transactions should give us a small speed advantage.
- (for-each
- (lambda (qif-file)
- (for-each
- (lambda (xtn)
- (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)))
- (if (not (qif-xtn:mark xtn))
- (begin
- ;; create and fill in the GNC transaction
- (let ((gnc-xtn (xaccMallocTransaction
- (gnc-get-current-book))))
- (xaccTransBeginEdit gnc-xtn)
+ ;; iterate over files. Going in the sort order by number of
+ ;; transactions should give us a small speed advantage.
+ (for-each
+ (lambda (qif-file)
+ (for-each
+ (lambda (xtn)
+ (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)))
+ (if (not (qif-xtn:mark xtn))
+ (begin
+ ;; create and fill in the GNC transaction
+ (let ((gnc-xtn (xaccMallocTransaction
+ (gnc-get-current-book))))
+ (xaccTransBeginEdit gnc-xtn)
- ;; FIXME. This is probably wrong
- (xaccTransSetCurrency gnc-xtn
- (gnc-default-currency))
+ ;; FIXME. This is probably wrong
+ (xaccTransSetCurrency gnc-xtn (gnc-default-currency))
- ;; build the transaction
- (qif-import:qif-xtn-to-gnc-xtn
- xtn qif-file gnc-xtn gnc-acct-hash
- qif-acct-map qif-cat-map qif-memo-map)
-
- ;; rebalance and commit everything
- (xaccTransCommitEdit gnc-xtn)))))
- (qif-file:xtns qif-file)))
- sorted-qif-files-list)
-
- ;; get rid of the progress dialog
- (if (not (null? progress-dialog))
- (gnc-progress-dialog-destroy progress-dialog))
-
- new-root))))
+ ;; build the transaction
+ (qif-import:qif-xtn-to-gnc-xtn
+ xtn qif-file gnc-xtn gnc-acct-hash
+ qif-acct-map qif-cat-map qif-memo-map)
+ ;; rebalance and commit everything
+ (xaccTransCommitEdit gnc-xtn)))))
+ (qif-file:xtns qif-file)))
+ sorted-qif-files-list)
+
+ new-root))))
+
+ ;; Get rid of the progress dialog (if any).
+ (if (not (null? progress-dialog))
+ (gnc-progress-dialog-destroy progress-dialog))
+
+ retval))
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-import:qif-xtn-to-gnc-xtn
;; translate a single transaction to a set of gnucash splits and
More information about the gnucash-changes
mailing list