mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Bug#516178: Prevent unresponsive QIF druid by cleaning up any existing progress
dialog if a Scheme error should occur during conversion. BP git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@16954 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Charles Day
@@ -204,187 +204,192 @@
|
||||
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)
|
||||
|
||||
new-root))))
|
||||
|
||||
;; Get rid of the progress dialog (if any).
|
||||
(if (not (null? progress-dialog))
|
||||
(gnc-progress-dialog-destroy progress-dialog))
|
||||
|
||||
retval))
|
||||
|
||||
;; 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))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; qif-import:qif-xtn-to-gnc-xtn
|
||||
|
||||
Reference in New Issue
Block a user