r16972 - gnucash/branches/2.2/src/import-export/qif-import - [r16954] Bug#516178: Prevent unresponsive QIF druid by cleaning up any existing progress

Andreas Köhler andi5 at cvs.gnucash.org
Thu Feb 28 17:08:55 EST 2008


Author: andi5
Date: 2008-02-28 17:08:55 -0500 (Thu, 28 Feb 2008)
New Revision: 16972
Trac: http://svn.gnucash.org/trac/changeset/16972

Modified:
   gnucash/branches/2.2/src/import-export/qif-import/qif-to-gnc.scm
Log:
[r16954] Bug#516178: Prevent unresponsive QIF druid by cleaning up any existing progress
dialog if a Scheme error should occur during conversion.

Committed by cedayiv.


Modified: gnucash/branches/2.2/src/import-export/qif-import/qif-to-gnc.scm
===================================================================
--- gnucash/branches/2.2/src/import-export/qif-import/qif-to-gnc.scm	2008-02-28 22:08:45 UTC (rev 16971)
+++ gnucash/branches/2.2/src/import-export/qif-import/qif-to-gnc.scm	2008-02-28 22:08:55 UTC (rev 16972)
@@ -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