1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;;  qif-file.scm
3;;;
4;;;  Read a QIF file into a <qif-file> object.
5;;;
6;;;  Bill Gribble <grib@billgribble.com> 20 Feb 2000
7;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9;; This program is free software; you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation; either version 2 of
12;; the License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful,
15;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17;; GNU General Public License for more details.
18;;
19;; You should have received a copy of the GNU General Public License
20;; along with this program; if not, contact:
21;;
22;; Free Software Foundation           Voice:  +1-617-542-5942
23;; 51 Franklin Street, Fifth Floor    Fax:    +1-617-542-2652
24;; Boston, MA  02110-1301,  USA       gnu@gnu.org
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27(define-module (gnucash qif-import qif-file))
28
29(eval-when (compile load eval expand)
30  (load-extension "libgnc-gnome" "scm_init_sw_gnome_module"))
31
32(use-modules (sw_gnome))
33(use-modules (gnucash core-utils))
34(use-modules (gnucash engine))
35(use-modules (gnucash utilities))
36(use-modules (gnucash string))
37(use-modules (gnucash app-utils))
38(use-modules (ice-9 regex))
39(use-modules (srfi srfi-1))
40(use-modules (srfi srfi-13))
41(use-modules (ice-9 rdelim))
42(use-modules (gnucash qif-import qif-objects))
43(use-modules (gnucash qif-import qif-utils))
44(use-modules (gnucash qif-import qif-parse))
45(use-modules (gnucash qif-import qif-dialog-utils))
46
47(export qif-file:check-from-acct)
48(export qif-file:parse-fields)
49(export qif-file:parse-fields-results)
50(export qif-file:read-file)
51(export qif-file:reparse-dates)
52
53(define qif-bad-numeric-rexp
54  (make-regexp "^\\.\\.\\."))
55
56(define (not-bad-numeric-string? input)
57  (not (regexp-exec qif-bad-numeric-rexp input)))
58
59
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;;  qif-file:read-file
62;;
63;;  Suck in all the lines. Don't do any string interpretation,
64;;  just store the fields "raw".
65;;
66;;  The return value will be:
67;;    success:   ()
68;;    failure:   (#f error-message)
69;;    warning:   (#t error-message)
70;;    cancel:    #t
71;;    exception: #f
72;;
73;; FIXME: This function really should be able to return multiple
74;;        errors and warnings rather than a single one.
75;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
76
77(define (qif-file:read-file self path ticker-map progress-dialog)
78
79  ;; This procedure does all the work. We'll define it, then call it safely.
80  (define (private-read)
81    (let ((qstate-type #f)
82          (current-xtn #f)
83          (current-split #f)
84          (current-account-name #f)
85          (last-seen-account-name #f)
86          (default-split #f)
87          (first-xtn #f)
88          (ignore-accounts #f)
89          (private-retval '())
90          (line-num 0)
91          (line #f)
92          (tag #f)
93          (value #f)
94          (abort-read #f)
95          (delimiters (string #\cr #\nl))
96          (file-stats #f)
97          (file-size 0)
98          (bytes-read 0))
99
100      ;; This procedure simplifies handling of warnings.
101      (define (mywarn . args)
102        (let ((str (gnc:list-display-to-string
103                     (append (list (G_ "Line") " " line-num ": ") args))))
104          (set! private-retval (list #t str))
105          (qif-import:log progress-dialog "qif-file:read-file" str)))
106
107
108      ;; This procedure simplifies handling of failures
109      (define (myfail . args)
110        (let ((str (gnc:list-display-to-string
111                         (append (list (G_ "Line") " " line-num ": ") args))))
112          (set! private-retval (list #f str))
113          (qif-import:log progress-dialog "qif-file:read-file"
114                          (string-append str "\n" (G_ "Read aborted.")))
115          (set! abort-read #t)))
116
117      (define (strip-bom)
118	(let ((c1 (read-char)))
119	  (if (char=? c1 (integer->char #xEF))
120	    (let ((c2 (read-char)))
121	      (if (char=? c2 (integer->char #xBB))
122		  (let ((c3 (read-char)))
123		    (if (char=? c3 (integer->char #xBF)) #t
124			(begin
125			  (unread-char c3)
126			  (unread-char c2)
127			  (unread-char c1)
128			#f)))
129		  (begin
130		    (unread-char c2)
131		    (unread-char c1)
132		    #f)))
133	    (begin
134	      (unread-char c1)
135	      #f))))
136
137      (define (qif-split-set-amount split value override?)
138        (when (and split
139                   (not-bad-numeric-string? value)
140                   (or override? (not (qif-split:amount split))))
141          (qif-split:set-amount! split value)))
142
143      (qif-file:set-path! self path)
144      (if (not (access? path R_OK))
145          ;; A UTF-8 encoded path won't succeed on some systems, such as
146          ;; Windows XP. Try encoding the path according to the locale.
147          (set! path (gnc-locale-from-utf8 path)))
148      (set! file-stats (stat path))
149      (set! file-size (stat:size file-stats))
150
151
152      (if progress-dialog
153          (gnc-progress-dialog-set-sub progress-dialog
154                                       (string-append (G_ "Reading") " " path)))
155
156      (with-input-from-file path
157        (lambda ()
158	  (strip-bom)
159          ;; loop over lines
160          (let line-loop ()
161            (set! line (read-delimited delimiters))
162            (set! line-num (+ 1 line-num))
163            (if (and (not (eof-object? line))
164                     (not (string=? line "")))
165                (begin
166                  ;; Add to the bytes-read tally.
167                  (set! bytes-read
168                        (+ bytes-read 1 (string-length line)))
169
170                  ;; Pick the 1-char tag off from the remainder of the line.
171                  (set! tag (string-ref line 0))
172                  (set! value (substring line 1))
173
174                  ;; If the line doesn't conform to UTF-8, try a default
175                  ;; character set conversion based on the locale. If that
176                  ;; fails, remove any invalid characters.
177                  (if (not (gnc-utf8? value))
178                      (let ((converted-value (gnc-locale-to-utf8 value)))
179                        (if (or (string=? converted-value "")
180                                (not (gnc-utf8? converted-value)))
181                            (begin
182                              (set! value (gnc-utf8-strip-invalid-strdup value))
183                              (mywarn
184                               (G_ "Some characters have been discarded.")
185                               " " (G_"Converted to: ") value))
186                            (begin
187                              (mywarn
188                               (G_ "Some characters have been converted according to your locale.")
189                               " " (G_"Converted to: ") converted-value)
190                              (set! value converted-value)))))
191
192                  (if (eq? tag #\!)
193                      ;; The "!" tag has the highest precedence and is used
194                      ;; to switch between different sections of the file.
195                      (let ((old-qstate qstate-type))
196                        (set! qstate-type (qif-parse:parse-bang-field value))
197                        (case qstate-type
198                          ;; Transaction list for a particular account
199                          ((type:bank type:cash type:ccard type:invst type:port
200                            #{type:oth a}#  #{type:oth l}# #{type:oth s}#)
201                           (if ignore-accounts
202                               (set! current-account-name
203                                     last-seen-account-name))
204                           (set! ignore-accounts #f)
205                           (set! current-xtn (make-qif-xtn))
206                           (set! default-split (make-qif-split))
207                           (set! first-xtn #t))
208
209                          ;; Class list
210                          ((type:class)
211                           (set! current-xtn (make-qif-class)))
212
213                          ;; Category list
214                          ((type:cat)
215                           (set! current-xtn (make-qif-cat)))
216
217                          ;; Account list
218                          ((account)
219                           (set! current-xtn (make-qif-acct)))
220
221                          ;; Security list
222                          ((type:security)
223                           (set! current-xtn (make-qif-stock-symbol)))
224
225                          ;; Memorized transaction list
226                          ((type:memorized)
227                           ;; Not supported. We really should warn the user.
228                           #f)
229
230                          ;; Security price list
231                          ((type:prices)
232                           ;; Not supported. We really should warn the user.
233                           #f)
234
235                          ((option:autoswitch)
236                           (set! ignore-accounts #t))
237
238                          ((clear:autoswitch)
239                           (set! ignore-accounts #f))
240
241                          (else
242                           ;; Ignore any other "option:" identifiers and
243                           ;; just return to the previously known !type
244                           (if (string-match "^option:"
245                                             (symbol->string qstate-type))
246                               (begin
247                                 (mywarn (G_ "Ignoring unknown option") " '"
248                                         qstate-type "'")
249                                 (set! qstate-type old-qstate))))))
250
251
252                      ;; It's not a "!" tag, so the meaning depends on what
253                      ;; type of section we are currently working on.
254                      (case qstate-type
255
256                        ;;;;;;;;;;;;;;;;;;;;;;
257                        ;; Transaction list ;;
258                        ;;;;;;;;;;;;;;;;;;;;;;
259
260                        ((type:bank type:cash type:ccard type:invst type:port
261                          #{type:oth a}#  #{type:oth l}# #{type:oth s}#)
262                         (case tag
263                           ;; D : transaction date
264                           ((#\D)
265                            (qif-xtn:set-date! current-xtn value))
266
267                           ;; T : total amount
268                           ((#\T)
269                            (qif-split-set-amount default-split value #f))
270
271                           ;; U : total amount (handle larger amount
272                           ;; than T; present in Quicken 2005
273                           ;; exports). See bug 798085
274                           ((#\U)
275                            (qif-split-set-amount default-split value #t))
276
277                           ;; P : payee
278                           ((#\P)
279                            (qif-xtn:set-payee! current-xtn value))
280
281                           ;; A : address
282                           ;; multiple "A" lines are appended together with
283                           ;; newlines; some Quicken files have a lot of
284                           ;; A lines.
285                           ((#\A)
286                            (qif-xtn:set-address!
287                             current-xtn
288                             (let ((current (qif-xtn:address current-xtn)))
289                               (if (not (string? current))
290                                   (set! current ""))
291                               (string-append current "\n" value))))
292
293                           ;; N : For transactions involving a security, this
294                           ;; is the investment action. For all others,  this
295                           ;; is a check number or transaction number.
296                           ((#\N)
297                            (if (or (eq? qstate-type 'type:invst)
298                                    (eq? qstate-type 'type:port))
299                                (qif-xtn:set-action! current-xtn value)
300                                (qif-xtn:set-number! current-xtn value)))
301
302                           ;; C : cleared flag
303                           ((#\C)
304                            (qif-xtn:set-cleared! current-xtn value))
305
306                           ;; M : memo
307                           ((#\M)
308                            (if default-split
309                                (qif-split:set-memo! default-split value)))
310
311                           ;; I : share price (stock transactions)
312                           ((#\I)
313                            (qif-xtn:set-share-price! current-xtn value))
314
315                           ;; Q : number of shares (stock transactions)
316                           ((#\Q)
317                            (qif-xtn:set-num-shares! current-xtn value))
318
319                           ;; Y : name of security (stock transactions)
320                           ((#\Y)
321                            (qif-xtn:set-security-name! current-xtn value))
322
323                           ;; O : commission (stock transactions)
324                           ((#\O)
325                            (qif-xtn:set-commission! current-xtn value))
326
327                           ;; L : category
328                           ((#\L)
329                            (if default-split
330                                (qif-split:set-category! default-split value)))
331
332                           ;; S : split category
333                           ;; At this point we are ignoring the default-split
334                           ;; completely, but save it for later -- we need it
335                           ;; to determine whether to reverse the split values.
336                           ((#\S)
337                            (set! current-split (make-qif-split))
338                            (if default-split
339                                (qif-xtn:set-default-split! current-xtn
340                                                            default-split))
341                            (set! default-split #f)
342                            (qif-split:set-category! current-split value)
343                            (qif-xtn:set-splits!
344                               current-xtn
345                               (cons current-split
346                                     (qif-xtn:splits current-xtn))))
347
348                           ;; E : split memo
349                           ((#\E)
350                            (if current-split
351                                (qif-split:set-memo! current-split value)))
352
353                           ;; $ : split amount (if there are splits)
354                           ((#\$)
355                            (if (and current-split
356                                     (not-bad-numeric-string? value))
357                                (qif-split:set-amount! current-split value)))
358
359                           ;; ^ : end-of-record
360                           ((#\^)
361                            (if (null? (qif-xtn:splits current-xtn))
362                                (qif-xtn:set-splits! current-xtn
363                                                     (list default-split)))
364                            (if first-xtn
365                                (let ((opening-balance-payee
366                                       (qif-file:process-opening-balance-xtn
367                                        self current-account-name current-xtn
368                                        qstate-type)))
369                                  (if (not current-account-name)
370                                      (set! current-account-name
371                                            opening-balance-payee))
372                                  (set! first-xtn #f)))
373
374                            (if (and (or (eq? qstate-type 'type:invst)
375                                         (eq? qstate-type 'type:port))
376                                     (not (qif-xtn:security-name current-xtn)))
377                                (qif-xtn:set-security-name! current-xtn ""))
378
379                            (qif-xtn:set-from-acct! current-xtn
380                                                    current-account-name)
381
382                            (if (qif-xtn:date current-xtn)
383                                (qif-file:add-xtn! self current-xtn)
384                                ;; The date is missing! Warn the user.
385                                (mywarn (G_ "Date required.") " "
386                                        (G_ "Discarding this transaction.")))
387
388                            ;;(write current-xtn) (newline)
389                            (set! current-xtn (make-qif-xtn))
390                            (set! current-split #f)
391                            (set! default-split (make-qif-split)))))
392
393
394                        ;;;;;;;;;;;;;;;;
395                        ;; Class list ;;
396                        ;;;;;;;;;;;;;;;;
397
398                        ((type:class)
399                         (case tag
400                           ;; N : name
401                           ((#\N)
402                            (qif-class:set-name! current-xtn value))
403
404                           ;; D : description
405                           ((#\D)
406                            (qif-class:set-description! current-xtn value))
407
408                           ;; R : tax copy designator (ignored for now)
409                           ((#\R)
410                            #t)
411
412                           ;; end-of-record
413                           ((#\^)
414                            (qif-file:add-class! self current-xtn)
415                            (set! current-xtn (make-qif-class)))
416
417                           (else
418                            (mywarn (G_ "Ignoring class line") ": " line))))
419
420
421                        ;;;;;;;;;;;;;;;;;;
422                        ;; Account List ;;
423                        ;;;;;;;;;;;;;;;;;;
424
425                        ((account)
426                         (case tag
427                           ((#\N)
428                            (qif-acct:set-name! current-xtn value)
429                            (set! last-seen-account-name value))
430                           ((#\D)
431                            (qif-acct:set-description! current-xtn value))
432                           ((#\T)
433                            (qif-acct:set-type! current-xtn value))
434                           ((#\L)
435                            (qif-acct:set-limit! current-xtn value))
436                           ((#\B)
437                            (qif-acct:set-budget! current-xtn value))
438                           ((#\^)
439                            (if (not ignore-accounts)
440                                (set! current-account-name
441                                      (qif-acct:name current-xtn)))
442                            (qif-file:add-account! self current-xtn)
443                            (set! current-xtn (make-qif-acct)))))
444
445
446                        ;;;;;;;;;;;;;;;;;;;
447                        ;; Category list ;;
448                        ;;;;;;;;;;;;;;;;;;;
449
450                        ((type:cat)
451                         (case tag
452                           ;; N : category name
453                           ((#\N)
454                            (qif-cat:set-name! current-xtn value))
455
456                           ;; D : category description
457                           ((#\D)
458                            (qif-cat:set-description! current-xtn value))
459
460                           ;; T : is this a taxable category?
461                           ((#\T)
462                            (qif-cat:set-taxable! current-xtn #t))
463
464                           ;; E : is this an expense category?
465                           ((#\E)
466                            (qif-cat:set-expense-cat! current-xtn #t))
467
468                           ;; I : is this an income category?
469                           ((#\I)
470                            (qif-cat:set-income-cat! current-xtn #t))
471
472                           ;; R : tax form/line designator
473                           ((#\R)
474                            (qif-cat:set-tax-class! current-xtn value))
475
476                           ;; B : budget amount.  not really supported.
477                           ((#\B)
478                            (qif-cat:set-budget-amt! current-xtn value))
479
480                           ;; end-of-record
481                           ((#\^)
482                            (qif-file:add-cat! self current-xtn)
483                            (set! current-xtn (make-qif-cat)))
484
485                           (else
486                            (mywarn (G_ "Ignoring category line") ": " line))))
487
488
489                        ;;;;;;;;;;;;;;;;;;;
490                        ;; Security list ;;
491                        ;;;;;;;;;;;;;;;;;;;
492
493                        ((type:security)
494                         (case tag
495                           ;; N : stock name
496                           ((#\N)
497                            (qif-stock-symbol:set-name! current-xtn value))
498
499                           ;; S : ticker symbol
500                           ((#\S)
501                            (qif-stock-symbol:set-symbol! current-xtn value))
502
503                           ;; T : type
504                           ((#\T)
505                            (qif-stock-symbol:set-type! current-xtn value))
506
507                           ;; G : asset class (ignored)
508                           ((#\G)
509                            #t)
510
511                           ;; end-of-record
512                           ((#\^)
513                            (qif-ticker-map:add-ticker! ticker-map current-xtn)
514                            (set! current-xtn (make-qif-stock-symbol)))
515
516                           (else
517                            (mywarn (G_ "Ignoring security line") ": " line))))
518
519
520                        ;; trying to sneak one by, eh?
521                        (else
522                          (if (and (not qstate-type)
523                                   (not (string=? (string-trim line) "")))
524                              (myfail
525                                (G_ "File does not appear to be in QIF format")
526                                ": " line)))))
527
528                  ;; Report the progress.
529                  (if (and progress-dialog
530                           (zero? (remainder line-num 32)))
531                      (begin
532                        (gnc-progress-dialog-set-value progress-dialog
533                                                       (/ bytes-read file-size))
534                        (qif-import:check-pause progress-dialog)
535                        (if qif-import:canceled
536                            (begin
537                              (set! private-retval #t)
538                              (set! abort-read #t)))))
539
540                  ;; This is if we read a normal (non-null, non-eof) line...
541                  (if (not abort-read)
542                      (line-loop)))
543
544                ;; ...and this is if we read a null or eof line.
545                (if (and (not abort-read)
546                         (not (eof-object? line)))
547                    (line-loop))))) #:encoding "UTF-8")
548
549      ;; Reverse the transaction list so xtns are in the same order that
550      ;; they appeared in the file.  This is important in a few cases.
551      (qif-file:set-xtns! self (reverse (qif-file:xtns self)))
552
553      private-retval))
554
555
556  (gnc:backtrace-if-exception
557    (lambda ()
558      (let ((retval #f))
559        ;; Safely read the file.
560        (set! retval (gnc:backtrace-if-exception private-read))
561
562        ;; Fill the progress dialog.
563        (if (and progress-dialog
564                 (list? retval))
565          (gnc-progress-dialog-set-value progress-dialog 1))
566
567        retval))))
568
569
570;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
571;;  qif-file:process-opening-balance-xtn
572;;
573;;  This gets called for the first transaction after a !Type: tag.
574;;
575;;  If the first transaction after a !Type: tag has a payee of
576;;  "Opening Balance", we have to massage the transaction a little.
577;;  The meaning of an OB transaction is "transfer from Equity to the
578;;  account specified in the L line." idiomatically, ms-money and some
579;;  others use this transaction instead of an Account record to
580;;  specify "this" account (the from-account for all following
581;;  transactions), so we have to allow for that.
582;;
583;;  Even if the payee isn't "Opening Balance", we know that if there's
584;;  no default from-account by this time, we need to set one.  In that
585;;  case, we set the default account based on the file name.
586;;
587;;  If we DO know the account already, and this is a transfer to it,
588;;  it's also an opening balance regardless of the payee.
589;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
590
591(define (qif-file:process-opening-balance-xtn self acct-name xtn type)
592  (let ((payee (qif-xtn:payee xtn))
593        (category (qif-split:category (car (qif-xtn:splits xtn))))
594        (cat-is-acct? (qif-split:category-is-account?
595                       (car (qif-xtn:splits xtn))))
596        (security (qif-xtn:security-name xtn)))
597    (if (or (and (not acct-name)
598                 (not security)
599                 payee (string? payee)
600                 (string=? (string-trim-right payee)
601                           "Opening Balance")
602                 cat-is-acct?)
603            (and acct-name (string? acct-name)
604                 (string=? acct-name category)
605                 (not security)))
606        ;; this is an explicit "Opening Balance" transaction.  we need
607        ;; to change the category to point to the equity account that
608        ;; the opening balance comes from.
609        (begin
610          (qif-split:set-category-private! (car (qif-xtn:splits xtn))
611                                           (default-equity-account))
612          (qif-split:set-category-is-account?! (car (qif-xtn:splits xtn)) #t)
613          (set! acct-name category)))
614    acct-name))
615
616;; return #t if all xtns have a non-#f from-acct otherwise, we will
617;; need to ask for an explicit account.
618(define (qif-file:check-from-acct self)
619  (let ((retval #t))
620    (for-each
621     (lambda (xtn)
622       (if (not (qif-xtn:from-acct xtn))
623           (set! retval #f)))
624     (qif-file:xtns self))
625    retval))
626
627;; if the date format was ambiguous, this will get called to reparse.
628(define (qif-file:reparse-dates self new-format)
629  (check-and-parse-field
630   qif-xtn:date qif-xtn:set-date! equal?
631   qif-parse:check-date-format (list new-format)
632   qif-parse:parse-date/format
633   (qif-file:xtns self)
634   qif-parse:print-date
635   'error-on-ambiguity (lambda (t e) e) 'date
636   (lambda (fraction) #t)))
637
638
639;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
640;;  qif-file:parse-fields
641;;
642;;  Take a previously-read qif file and convert fields from
643;;  strings to the appropriate type.
644;;
645;;  The return value will be:
646;;    success:   ()
647;;    failure:   (#f . ((type . error) ...))
648;;    warning:   (#t . ((type . error) ...))
649;;    cancel:    #t
650;;    exception: #f
651;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
652
653(define (qif-file:parse-fields self progress-dialog)
654
655  ;; This procedure does all the work. We'll define it, then call it safely.
656  (define (private-parse)
657   (let ((error #f)
658         (update-count 0)
659         (all-ok #f))
660
661     ;; This procedure sets a suboperation name.
662     (define (set-sub str)
663       (if progress-dialog
664           (gnc-progress-dialog-set-sub progress-dialog str))
665       #t)
666
667
668     ;; This procedure sets a suboperation weight.
669     (define (start-sub weight)
670       (if progress-dialog
671           (gnc-progress-dialog-push progress-dialog weight))
672       #t)
673
674
675     ;; This procedure finishes a suboperation.
676     (define (finish-sub)
677       (if progress-dialog
678           (gnc-progress-dialog-pop-full progress-dialog))
679       #t)
680
681
682     ;; This procedure handles progress reporting, pause, and cancel.
683     (define (update-progress fraction)
684       (set! update-count (+ 1 update-count))
685       (if (and progress-dialog
686                (zero? (remainder update-count 32)))
687           (begin
688             (gnc-progress-dialog-set-value progress-dialog fraction)
689             (qif-import:check-pause progress-dialog)
690             (if qif-import:canceled
691                 (throw 'cancel)))))
692
693
694     ;; This procedure is the generic error handler for parsing.
695     (define (add-error t e)
696       ;; Log the error message.
697       (if (string? e)
698           (qif-import:log progress-dialog
699                           "qif-file:parse-fields"
700                           (string-append (case t
701                                            ((date) (G_ "Transaction date"))
702                                            ((split-amounts) (G_ "Transaction amount"))
703                                            ((share-price) (G_ "Share price"))
704                                            ((num-shares) (G_ "Share quantity"))
705                                            ((action) (G_ "Investment action"))
706                                            ((cleared) (G_ "Reconciliation status"))
707                                            ((commission) (G_ "Commission"))
708                                            ((acct-type) (G_ "Account type"))
709                                            ((tax-class) (G_ "Tax class"))
710                                            ((budget-amt) (G_ "Category budget amount"))
711                                            ((budget) (G_ "Account budget amount"))
712                                            ((limit) (G_ "Credit limit"))
713                                            (else (symbol->string t)))
714                                          ": " e)))
715       ;; Save the error condition.
716       (if (not error)
717           (set! error (list (cons t e)))
718           (set! error (cons (cons t e) error))))
719
720
721     (and
722      ;;
723      ;; Fields of categories.
724      ;;
725      (set-sub (G_ "Parsing categories"))
726      ;; The category tasks will be 5% of the overall parsing effort.
727      (start-sub 0.05)
728
729      ;; Tax classes; assume this is 50% of the category parsing effort.
730      (start-sub 0.5)
731      (check-and-parse-field
732       qif-cat:tax-class qif-cat:set-tax-class! gnc-numeric-equal
733       qif-parse:check-number-format '(decimal comma)
734       qif-parse:parse-number/format (qif-file:cats self)
735       qif-parse:print-number
736       'guess-on-ambiguity add-error 'tax-class
737       update-progress)
738      (finish-sub)
739
740      ;; Budget amounts; this is the last task for category parsing.
741      (start-sub 1)
742      (check-and-parse-field
743       qif-cat:budget-amt qif-cat:set-budget-amt! gnc-numeric-equal
744       qif-parse:check-number-format '(decimal comma)
745       qif-parse:parse-number/format (qif-file:cats self)
746       qif-parse:print-number
747       'guess-on-ambiguity add-error 'budget-amt
748       update-progress)
749      (finish-sub)
750
751      (finish-sub)
752
753
754      ;;
755      ;; Fields of accounts
756      ;;
757      (set-sub (G_ "Parsing accounts"))
758      ;; The account tasks will be 5% of the overall parsing effort.
759      (start-sub 0.05)
760
761      ;; Account limits; assume this is 20% of the account parsing effort.
762      (start-sub 0.2)
763      (check-and-parse-field
764       qif-acct:limit qif-acct:set-limit! gnc-numeric-equal
765       qif-parse:check-number-format '(decimal comma)
766       qif-parse:parse-number/format (qif-file:accounts self)
767       qif-parse:print-number
768       'guess-on-ambiguity add-error 'limit
769       update-progress)
770      (finish-sub)
771
772      ;; Budget amounts; assume this is 20% of the account parsing effort.
773      (start-sub 0.2)
774      (check-and-parse-field
775       qif-acct:budget qif-acct:set-budget! gnc-numeric-equal
776       qif-parse:check-number-format '(decimal comma)
777       qif-parse:parse-number/format (qif-file:accounts self)
778       qif-parse:print-number
779       'guess-on-ambiguity add-error 'budget
780       update-progress)
781      (finish-sub)
782
783      ;; Account types; this is the last task for account parsing.
784      (start-sub 1)
785      (parse-field
786       qif-acct:type qif-acct:set-type!
787       qif-parse:parse-acct-type (qif-file:accounts self)
788       add-error 'acct-type
789       update-progress)
790      (finish-sub)
791
792      (finish-sub)
793
794
795      ;;
796      ;; fields of transactions
797      ;;
798      (set-sub (G_ "Parsing transactions"))
799      ;; Transaction parsing takes up the rest of the overall parsing effort.
800      (start-sub 1)
801
802      ;; Dates; assume this is 15% of the transaction effort.
803      (start-sub 0.15)
804      (check-and-parse-field
805       qif-xtn:date qif-xtn:set-date! equal?
806       qif-parse:check-date-format '(m-d-y d-m-y y-m-d y-d-m)
807       qif-parse:parse-date/format
808       (qif-file:xtns self)
809       qif-parse:print-date
810       'error-on-ambiguity add-error 'date
811       update-progress)
812      (finish-sub)
813
814      ;; Clear flags; assume this is 5% of the transaction effort.
815      (start-sub 0.05)
816      (parse-field
817       qif-xtn:cleared qif-xtn:set-cleared!
818       qif-parse:parse-cleared-field (qif-file:xtns self)
819       add-error 'cleared
820       update-progress)
821      (finish-sub)
822
823      ;; Investment actions; assume this is 10% of the transaction effort.
824      (start-sub 0.1)
825      (parse-field
826       qif-xtn:action qif-xtn:set-action!
827       qif-parse:parse-action-field (qif-file:xtns self)
828       add-error 'action
829       update-progress)
830      (finish-sub)
831
832      ;; Share prices; assume this is 10% of the transaction effort.
833      (start-sub 0.1)
834      (check-and-parse-field
835       qif-xtn:share-price qif-xtn:set-share-price! gnc-numeric-equal
836       qif-parse:check-number-format '(decimal comma)
837       qif-parse:parse-number/format (qif-file:xtns self)
838       qif-parse:print-number
839       'guess-on-ambiguity add-error 'share-price
840       update-progress)
841      (finish-sub)
842
843      ;; Share quantities; assume this is 10% of the transaction effort.
844      (start-sub 0.1)
845      (check-and-parse-field
846       qif-xtn:num-shares qif-xtn:set-num-shares! gnc-numeric-equal
847       qif-parse:check-number-format '(decimal comma)
848       qif-parse:parse-number/format (qif-file:xtns self)
849       qif-parse:print-number
850       'guess-on-ambiguity add-error 'num-shares
851       update-progress)
852      (finish-sub)
853
854      ;; Commissions; assume this is 10% of the transaction effort.
855      (start-sub 0.1)
856      (check-and-parse-field
857       qif-xtn:commission qif-xtn:set-commission! gnc-numeric-equal
858       qif-parse:check-number-format '(decimal comma)
859       qif-parse:parse-number/format (qif-file:xtns self)
860       qif-parse:print-number
861       'guess-on-ambiguity add-error 'commission
862       update-progress)
863      (finish-sub)
864
865      ;; Splits; this is the rest of the transaction effort.
866      (start-sub 1)
867      ;; this one's a little tricky... it checks and sets all the
868      ;; split amounts for the transaction together.
869      (check-and-parse-field
870       qif-xtn:split-amounts qif-xtn:set-split-amounts! gnc-numeric-equal
871       qif-parse:check-number-formats '(decimal comma)
872       qif-parse:parse-numbers/format (qif-file:xtns self)
873       qif-parse:print-numbers
874       'guess-on-ambiguity add-error 'split-amounts
875       update-progress)
876      (finish-sub)
877
878      (finish-sub)
879
880
881      (begin
882        (set! all-ok #t)
883        #t))
884
885     ;; Determine what to return.
886     (cond (qif-import:canceled
887            #t)
888           (error
889            (cons all-ok error))
890           (else '()))))
891
892
893  ;; Safely read the file and return the result.
894  (gnc:backtrace-if-exception
895    (lambda () (catch 'cancel private-parse (lambda (key . args) #t)))))
896
897
898;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
899;;  parse-field
900;;
901;;  A simplified version of check-and-parse-field which just
902;;  calls the parser on every instance of the field in the set
903;;  of objects.
904;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
905
906(define (parse-field getter setter parser objects errorproc errortype reporter)
907  (let ((work-to-do (length objects))
908        (work-done 0)
909        (unparsed #f))
910    (for-each
911     (lambda (obj)
912       (set! unparsed (getter obj))
913       (if (and unparsed (string? unparsed))
914           (setter obj (parser unparsed errorproc errortype)))
915       (set! work-done (+ 1 work-done))
916       (reporter (/ work-done work-to-do)))
917     objects))
918  #t)
919
920
921;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
922;;  check-and-parse-field
923;;
924;;  This is a semi-generic routine to apply a format check and
925;;  parsing routine to fields that can have multiple possible
926;;  formats.  In this case, any amount field cam be decimal or
927;;  comma radix and the date field can be any of several possible
928;;  types.
929;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
930
931(define (check-and-parse-field getter setter equiv-thunk checker
932                               formats parser objects printer
933                               on-error errorproc errortype
934                               reporter)
935  (let* ((do-parsing #f)
936         (retval #t)
937         (format #f)
938         (len (length objects))
939         (work-to-do (* len 2))
940         (work-done 0))
941
942    ;; first find the right format for the field
943    ;; loop over objects.  If the formats list ever gets down
944    ;; to 1 element, we can stop right there.
945    (if (not (null? objects))
946        (let loop ((current (car objects))
947                   (rest (cdr objects)))
948          (let ((val (getter current)))
949            (if val
950                (begin
951                  (set! do-parsing #t)
952                  (set! formats (checker val formats))))
953            (set! work-done (+ 1 work-done))
954            (reporter (/ work-done work-to-do)))
955          (if (and (not (null? formats))
956                   ;; (not (null? (cdr formats)))
957                   (not (null? rest)))
958              (loop (car rest) (cdr rest)))))
959
960    ;; if there's nothing left in formats, there's no format that will
961    ;; fit all the values for a given field.  We have to give up at
962    ;; that point.
963
964    ;; If there are multiple items in formats, we look at the on-error
965    ;; arg.  If it's 'guess-on-ambiguity, we take the default (first)
966    ;; item in the list.  This is not super great.  if it's
967    ;; 'fail-on-ambiguity (or anything else, actually) we return the
968    ;; list of acceptable formats.
969
970    (cond
971     ((or (not formats)
972          (null? formats))
973      ;; Data was not in any of the supplied formats.
974      (errorproc errortype (G_ "Unrecognized or inconsistent format."))
975      (set! retval #f)
976      (set! do-parsing #f))
977
978     ((and (not (null? (cdr formats))) do-parsing)
979      ;; There are multiple formats that fit.  If they all produce the
980      ;; same interpretation for every data point in the set, then
981      ;; just ignore the format ambiguity.  Otherwise, it's really an
982      ;; error.  ATM since there's no way to correct the error let's
983      ;; just leave it be.
984      (if (or (eq? on-error 'guess-on-ambiguity)
985              (all-formats-equivalent? getter parser equiv-thunk formats
986                                       objects printer errorproc errortype))
987          (set! format (car formats))
988          (begin
989            (errorproc errortype formats)
990            (set! do-parsing #f)
991            ;; NOTE: It seems like this ought to be (set! retval #f) instead,
992            ;;       but that would stop all parsing dead in its tracks. Not
993            ;;       sure that this can happen to anything other than dates,
994            ;;       and those will get reparsed anyway.
995            (set! retval #t))))
996     (else
997      (set! format (car formats))))
998
999    ;; do-parsing is false if there were no objects with non-#f values
1000    ;; in the field, or the data format is ambiguous and
1001    ;; 'fail-on-ambiguity was passed.  We would have had to look at
1002    ;; all of them once, but at least not twice.
1003    (if do-parsing
1004        (for-each
1005          (lambda (current)
1006            (let ((val (getter current))
1007                  (parsed #f))
1008              (if val
1009                  (begin
1010                    (set! parsed (parser val format))
1011                    (if parsed
1012                        (setter current parsed)
1013                        (begin
1014                          (set! retval #f)
1015                          (errorproc errortype
1016                           (G_ "Parsing failed.")))))))
1017            (set! work-done (+ 1 work-done))
1018            (reporter (/ work-done work-to-do)))
1019         objects))
1020
1021    (if retval
1022        (reporter 1))
1023
1024    retval))
1025
1026
1027;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1028;;  all-formats-equivalent?
1029;;
1030;;  This predicate checks for the off chance that even though
1031;;  there are multiple possible interpretations they are all the
1032;;  same. (i.e. the numbers "1000 2000 3000 4000" could be
1033;;  interpreted as decimal or comma radix, but who cares?  The
1034;;  values will be the same).
1035;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1036
1037(define (all-formats-equivalent? getter parser equiv-thunk formats objects
1038                                 printer errorproc errortype)
1039  (let ((all-ok #t))
1040    (let obj-loop ((objlist objects))
1041      (let* ((unparsed (getter (car objlist)))
1042             (parsed #f))
1043        (if (string? unparsed)
1044            (begin
1045              ;; Parse using the first format in the list.
1046              (set! parsed (parser unparsed (car formats)))
1047              ;; For each remaining format, see if the result is the same.
1048              (for-each
1049               (lambda (fmt)
1050                 (let ((this-parsed (parser unparsed fmt)))
1051                   (if (not (equiv-thunk parsed this-parsed))
1052                       (begin
1053                         (set! all-ok #f)
1054                         (if (not (eq? errortype 'date))
1055                             (errorproc errortype
1056                                        (gnc:list-display-to-string (list
1057                              (G_ "Parse ambiguity between formats") " "
1058                              formats "\n"
1059                              (format #f (G_ "Value '~a' could be ~a or ~a.")
1060                                       parsed
1061                                       (printer parsed)
1062                                       (printer this-parsed))))))))))
1063               (cdr formats))))
1064        (if (and all-ok (not (null? (cdr objlist))))
1065            (obj-loop (cdr objlist)))))
1066    all-ok))
1067
1068
1069;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1070;;  qif-file:parse-fields-results
1071;;
1072;;  Take the results from qif-file:parse fields and find the
1073;;  first result for a particular type of parse.
1074;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1075
1076(define (qif-file:parse-fields-results results type)
1077  (define (test-results results)
1078    (if (null? results) #f
1079        (let* ((this-res (car results))
1080               (this-type (car this-res)))
1081          (if (eq? this-type type)
1082              (cdr this-res)
1083              (test-results (cdr results))))))
1084
1085  (if results (test-results results) #f))
1086