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