mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
657 lines
25 KiB
Scheme
657 lines
25 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; qif-parse.scm
|
|
;;; routines to parse values and dates in QIF files.
|
|
;;;
|
|
;;; Bill Gribble <grib@billgribble.com> 20 Feb 2000
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; This program is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation; either version 2 of
|
|
;; the License, or (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; if not, contact:
|
|
;;
|
|
;; Free Software Foundation Voice: +1-617-542-5942
|
|
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
|
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(use-modules (gnucash import-export string))
|
|
|
|
(define qif-category-compiled-rexp
|
|
(make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$"))
|
|
|
|
(define qif-date-compiled-rexp
|
|
(make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]).*$"))
|
|
|
|
(define qif-date-mdy-compiled-rexp
|
|
(make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])"))
|
|
|
|
(define qif-date-ymd-compiled-rexp
|
|
(make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])"))
|
|
|
|
(define decimal-radix-regexp
|
|
(make-regexp
|
|
"^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *$"))
|
|
|
|
(define comma-radix-regexp
|
|
(make-regexp
|
|
"^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$"))
|
|
|
|
(define integer-regexp (make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-split:parse-category
|
|
;; this one just gets nastier and nastier.
|
|
;; ATM we return a list of 6 elements:
|
|
;; parsed category name (without [] if it was an account name)
|
|
;; bool stating if it was an account name
|
|
;; class of account or #f
|
|
;; string representing the "miscx category" if any
|
|
;; bool if miscx category is an account
|
|
;; class of miscx cat or #f
|
|
;; gosh, I love regular expressions.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-split:parse-category self value)
|
|
(let ((match (regexp-exec qif-category-compiled-rexp value)))
|
|
(if match
|
|
(let ((rv
|
|
(list (match:substring match 2)
|
|
(if (and (match:substring match 1)
|
|
(match:substring match 3))
|
|
#t #f)
|
|
(if (match:substring match 4)
|
|
(match:substring match 5)
|
|
#f)
|
|
;; miscx category name
|
|
(if (match:substring match 6)
|
|
(match:substring match 8)
|
|
#f)
|
|
;; is it an account?
|
|
(if (and (match:substring match 7)
|
|
(match:substring match 9))
|
|
#t #f)
|
|
(if (match:substring match 10)
|
|
(match:substring match 11)
|
|
#f))))
|
|
rv)
|
|
(begin
|
|
;; Parsing failed. Bug detected!
|
|
(gnc:warn "qif-split:parse-category: can't parse [" value "].")
|
|
(throw 'bug
|
|
"qif-split:parse-category"
|
|
"Can't parse account or category ~A."
|
|
(list value)
|
|
#f)))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-parse:fix-year
|
|
;; this is where we handle y2k fixes etc. input is a string
|
|
;; containing the year ("00", "2000", and "19100" all mean the same
|
|
;; thing). output is an integer representing the year in the C.E.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:fix-year year-string y2k-threshold)
|
|
(let ((fixed-string #f)
|
|
(post-read-value #f)
|
|
(y2k-fixed-value #f))
|
|
|
|
;; quicken prints 2000 as "' 0" for at least some versions.
|
|
;; thanks dave p for reporting this.
|
|
(if (eq? (string-ref year-string 0) #\')
|
|
(begin
|
|
(gnc:warn "qif-file:fix-year: found weird QIF Y2K year ["
|
|
year-string "].")
|
|
(set! fixed-string
|
|
(substring year-string 2 (string-length year-string))))
|
|
(set! fixed-string year-string))
|
|
|
|
;; now the string should just have a number in it plus some
|
|
;; optional trailing space.
|
|
(set! post-read-value
|
|
(with-input-from-string fixed-string
|
|
(lambda () (read))))
|
|
|
|
(cond
|
|
;; 2-digit numbers less than the window size are interpreted to
|
|
;; be post-2000.
|
|
((and (integer? post-read-value)
|
|
(< post-read-value y2k-threshold))
|
|
(set! y2k-fixed-value (+ 2000 post-read-value)))
|
|
|
|
;; there's a common bug in printing post-2000 dates that
|
|
;; prints 2000 as 19100 etc.
|
|
((and (integer? post-read-value)
|
|
(> post-read-value 19000))
|
|
(set! y2k-fixed-value (+ 1900 (- post-read-value 19000))))
|
|
|
|
;; normal dates represented in unix years (i.e. year-1900, so
|
|
;; 2000 => 100.) We also want to allow full year specifications,
|
|
;; (i.e. 1999, 2001, etc) and there's a point at which you can't
|
|
;; determine which is which. this should eventually be another
|
|
;; field in the qif-file struct but not yet.
|
|
((and (integer? post-read-value)
|
|
(< post-read-value 1902))
|
|
(set! y2k-fixed-value (+ 1900 post-read-value)))
|
|
|
|
;; this is a normal, 4-digit year spec (1999, 2000, etc).
|
|
((integer? post-read-value)
|
|
(set! y2k-fixed-value post-read-value))
|
|
|
|
;; No idea what the string represents. Maybe a new bug in Quicken!
|
|
(#t
|
|
(gnc:warn "qif-file:fix-year: ay caramba! What is this? ["
|
|
year-string "].")))
|
|
|
|
y2k-fixed-value))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; parse-acct-type : set the type of the account, using gnucash
|
|
;; conventions.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:parse-acct-type read-value errorproc errortype)
|
|
(let ((mangled-string
|
|
(string-downcase! (string-remove-trailing-space
|
|
(string-remove-leading-space read-value)))))
|
|
(cond
|
|
((string=? mangled-string "bank")
|
|
(list GNC-BANK-TYPE))
|
|
((string=? mangled-string "port")
|
|
(list GNC-BANK-TYPE))
|
|
((string=? mangled-string "cash")
|
|
(list GNC-CASH-TYPE))
|
|
((string=? mangled-string "ccard")
|
|
(list GNC-CCARD-TYPE))
|
|
((string=? mangled-string "invst") ;; these are brokerage accounts.
|
|
(list GNC-BANK-TYPE))
|
|
((string=? mangled-string "401(k)/403(b)")
|
|
(list GNC-BANK-TYPE))
|
|
((string=? mangled-string "oth a")
|
|
(list GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE))
|
|
((string=? mangled-string "oth l")
|
|
(list GNC-LIABILITY-TYPE GNC-CCARD-TYPE))
|
|
((string=? mangled-string "oth s") ;; German asset account
|
|
(list GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE))
|
|
((string=? mangled-string "mutual")
|
|
(list GNC-BANK-TYPE))
|
|
(#t
|
|
(errorproc errortype
|
|
(format #f (_ "Unrecognized account type '~s'. Defaulting to Bank.")
|
|
read-value))
|
|
(list GNC-BANK-TYPE)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; parse-bang-field : the bang fields switch the parse context
|
|
;; for the qif file.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:parse-bang-field read-value)
|
|
(let ((bang-field (string-downcase!
|
|
(string-remove-trailing-space read-value))))
|
|
;; The QIF files output by the WWW site of Credit Lyonnais
|
|
;; begin by: !type bank
|
|
;; instead of: !Type:bank
|
|
(if (>= (string-length bang-field) 5)
|
|
(if (string=? (substring bang-field 0 5) "type ")
|
|
(string-set! bang-field 4 #\:)))
|
|
|
|
(string->symbol bang-field)))
|
|
|
|
|
|
(define (qif-parse:parse-action-field read-value errorproc errortype)
|
|
(if read-value
|
|
(let ((action-symbol (string-to-canonical-symbol read-value)))
|
|
(case action-symbol
|
|
;; buy
|
|
((buy cvrshrt kauf)
|
|
'buy)
|
|
((buyx cvrshrtx kaufx)
|
|
'buyx)
|
|
((cglong kapgew) ;; Kapitalgewinnsteuer
|
|
'cglong)
|
|
((cglongx kapgewx)
|
|
'cglongx)
|
|
((cgmid) ;; Kapitalgewinnsteuer
|
|
'cgmid)
|
|
((cgmidx)
|
|
'cgmidx)
|
|
((cgshort k.gewsp)
|
|
'cgshort)
|
|
((cgshortx k.gewspx)
|
|
'cgshortx)
|
|
((div) ;; dividende
|
|
'div)
|
|
((divx)
|
|
'divx)
|
|
; ((exercise)
|
|
; 'exercise)
|
|
; ((exercisx)
|
|
; 'exercisx)
|
|
; ((expire)
|
|
; 'expire)
|
|
; ((grant)
|
|
; 'grant)
|
|
((int intinc) ;; zinsen
|
|
'intinc)
|
|
((intx intincx)
|
|
'intincx)
|
|
((margint)
|
|
'margint)
|
|
((margintx)
|
|
'margintx)
|
|
((miscexp)
|
|
'miscexp)
|
|
((miscexpx)
|
|
'miscexpx)
|
|
((miscinc cash)
|
|
'miscinc)
|
|
((miscincx)
|
|
'miscincx)
|
|
((reinvdiv)
|
|
'reinvdiv)
|
|
((reinvint reinvzin)
|
|
'reinvint)
|
|
((reinvlg reinvkur)
|
|
'reinvlg)
|
|
((reinvmd)
|
|
'reinvmd)
|
|
((reinvsg reinvksp)
|
|
'reinvsg)
|
|
((reinvsh)
|
|
'reinvsh)
|
|
((reminder erinnerg)
|
|
'reminder)
|
|
((rtrncap)
|
|
'rtrncap)
|
|
((rtrncapx)
|
|
'rtrncapx)
|
|
((sell shtsell verkauf) ;; verkaufen
|
|
'sell)
|
|
((sellx shtsellx verkaufx)
|
|
'sellx)
|
|
((shrsin aktzu)
|
|
'shrsin)
|
|
((shrsout aktab)
|
|
'shrsout)
|
|
((stksplit aktsplit)
|
|
'stksplit)
|
|
((xin contribx)
|
|
'xin)
|
|
((xout withdrwx)
|
|
'xout)
|
|
; ((vest)
|
|
; 'vest)
|
|
(else
|
|
(errorproc errortype
|
|
(format #f (_ "Unrecognized action '~a'.") read-value))
|
|
#f)))
|
|
#f))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; parse-cleared-field : In a "C" (cleared status) QIF line,
|
|
;; * or C means cleared, X or R means reconciled, and ! or ?
|
|
;; mean some budget related stuff I don't understand.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:parse-cleared-field read-value errorproc errortype)
|
|
(if (and (string? read-value)
|
|
(not (string-null? read-value)))
|
|
(let ((secondchar (string-ref read-value 0)))
|
|
(case secondchar
|
|
;; Reconciled is the most likely, especially for large imports,
|
|
;; so check that first. Also allow for lowercase.
|
|
((#\X #\x #\R #\r)
|
|
'reconciled)
|
|
((#\* #\C #\c)
|
|
'cleared)
|
|
((#\? #\!)
|
|
'budgeted)
|
|
(else
|
|
(errorproc errortype
|
|
(format #f (_ "Unrecognized status '~a'. Defaulting to uncleared.")
|
|
read-value))
|
|
#f)))
|
|
#f))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; parse-check-date-format
|
|
;; given a match-triple (matches in spaces 1, 2, 3) and a
|
|
;; list of possible date formats, return the list of formats
|
|
;; that this date string could actually be.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (parse-check-date-format match possible-formats)
|
|
(let ((date-parts (list (match:substring match 1)
|
|
(match:substring match 2)
|
|
(match:substring match 3)))
|
|
(numeric-date-parts '())
|
|
(retval '()))
|
|
|
|
;;(define (print-list l)
|
|
;; (for-each (lambda (x) (display x) (display " ")) l))
|
|
|
|
;;(for-each (lambda (x) (if (list? x) (print-list x) (display x)))
|
|
;; (list "parsing: " date-parts " in " possible-formats "\n"))
|
|
|
|
;; get the strings into numbers (but keep the strings around)
|
|
(set! numeric-date-parts
|
|
(map (lambda (elt)
|
|
(with-input-from-string elt
|
|
(lambda () (read))))
|
|
date-parts))
|
|
|
|
(let ((possibilities possible-formats)
|
|
(n1 (car numeric-date-parts))
|
|
(n2 (cadr numeric-date-parts))
|
|
(n3 (caddr numeric-date-parts))
|
|
(s1 (car date-parts))
|
|
(s3 (caddr date-parts)))
|
|
|
|
;; filter the possibilities to eliminate (hopefully)
|
|
;; all but one
|
|
(if (or (not (number? n1)) (> n1 12))
|
|
(set! possibilities (delq 'm-d-y possibilities)))
|
|
(if (or (not (number? n1)) (> n1 31))
|
|
(set! possibilities (delq 'd-m-y possibilities)))
|
|
(if (or (not (number? n1)) (< n1 1))
|
|
(set! possibilities (delq 'd-m-y possibilities)))
|
|
(if (or (not (number? n1)) (< n1 1))
|
|
(set! possibilities (delq 'm-d-y possibilities)))
|
|
|
|
(if (or (not (number? n2)) (> n2 12))
|
|
(begin
|
|
(set! possibilities (delq 'd-m-y possibilities))
|
|
(set! possibilities (delq 'y-m-d possibilities))))
|
|
|
|
(if (or (not (number? n2)) (> n2 31))
|
|
(begin
|
|
(set! possibilities (delq 'm-d-y possibilities))
|
|
(set! possibilities (delq 'y-d-m possibilities))))
|
|
|
|
(if (or (not (number? n3)) (> n3 12))
|
|
(set! possibilities (delq 'y-d-m possibilities)))
|
|
(if (or (not (number? n3)) (> n3 31))
|
|
(set! possibilities (delq 'y-m-d possibilities)))
|
|
|
|
(if (or (not (number? n3)) (< n3 1))
|
|
(set! possibilities (delq 'y-m-d possibilities)))
|
|
(if (or (not (number? n3)) (< n3 1))
|
|
(set! possibilities (delq 'y-d-m possibilities)))
|
|
|
|
;; If we've got a 4-character year, make sure the date
|
|
;; is after 1930. Don't check the high value (perhaps
|
|
;; we should?).
|
|
(if (= (string-length s1) 4)
|
|
(if (or (not (number? n1)) (< n1 1930))
|
|
(begin
|
|
(set! possibilities (delq 'y-m-d possibilities))
|
|
(set! possibilities (delq 'y-d-m possibilities)))))
|
|
(if (= (string-length s3) 4)
|
|
(if (or (not (number? n3)) (< n3 1930))
|
|
(begin
|
|
(set! possibilities (delq 'm-d-y possibilities))
|
|
(set! possibilities (delq 'd-m-y possibilities)))))
|
|
|
|
(set! retval possibilities))
|
|
retval))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-parse:check-date-format
|
|
;; given a list of possible date formats, return a pruned list
|
|
;; of possibilities.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (qif-parse:check-date-format date-string possible-formats)
|
|
(let ((retval '()))
|
|
(if (or (not (string? date-string))
|
|
(not (> (string-length date-string) 0)))
|
|
(set! retval #f)
|
|
(let ((match (regexp-exec qif-date-compiled-rexp date-string)))
|
|
(if match
|
|
(if (match:substring match 1)
|
|
(set! retval (parse-check-date-format match possible-formats))
|
|
|
|
;; Uh oh -- this is a string XXXXXXXX; we don't know which
|
|
;; way to test.. So test both YYYYxxxx and xxxxYYYY,
|
|
;; and let the parser verify the year is valid.
|
|
(let* ((new-date-string (match:substring match 4))
|
|
(date-ymd (regexp-exec qif-date-ymd-compiled-rexp
|
|
new-date-string))
|
|
(date-mdy (regexp-exec qif-date-mdy-compiled-rexp
|
|
new-date-string))
|
|
(res1 '())
|
|
(res2 '()))
|
|
(if (or (memq 'y-d-m possible-formats)
|
|
(memq 'y-m-d possible-formats))
|
|
(set! res1 (parse-check-date-format date-ymd possible-formats)))
|
|
(if (or (memq 'd-m-y possible-formats)
|
|
(memq 'm-d-y possible-formats))
|
|
(set! res2 (parse-check-date-format date-mdy possible-formats)))
|
|
|
|
(set! retval (append res1 res2)))))))
|
|
|
|
retval))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-parse:parse-date/format
|
|
;; given a date-string and a format, convert the string to a
|
|
;; date and return a list of day, month, year
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:parse-date/format date-string format)
|
|
(let ((date-parts '())
|
|
(numeric-date-parts '())
|
|
(retval #f)
|
|
|
|
(match (regexp-exec qif-date-compiled-rexp date-string)))
|
|
(if match
|
|
(if (match:substring match 1)
|
|
(set! date-parts (list (match:substring match 1)
|
|
(match:substring match 2)
|
|
(match:substring match 3)))
|
|
;; This is of the form XXXXXXXX; split the string based on
|
|
;; whether the format is YYYYxxxx or xxxxYYYY
|
|
(let ((date-str (match:substring match 4)))
|
|
(case format
|
|
((d-m-y m-d-y)
|
|
(let ((m (regexp-exec qif-date-mdy-compiled-rexp date-str)))
|
|
(set! date-parts (list (match:substring m 1)
|
|
(match:substring m 2)
|
|
(match:substring m 3)))))
|
|
((y-m-d y-d-m)
|
|
(let ((m (regexp-exec qif-date-ymd-compiled-rexp date-str)))
|
|
(set! date-parts (list (match:substring m 1)
|
|
(match:substring m 2)
|
|
(match:substring m 3)))))
|
|
))))
|
|
|
|
;; get the strings into numbers (but keep the strings around)
|
|
(set! numeric-date-parts
|
|
(map (lambda (elt)
|
|
(with-input-from-string elt
|
|
(lambda () (read))))
|
|
date-parts))
|
|
|
|
;; if the date parts list doesn't have 3 parts, we're in trouble
|
|
(if (not (eq? 3 (length date-parts)))
|
|
(gnc:warn "qif-parse:parse-date/format: can't interpret date ["
|
|
date-string "]\nDate parts: " date-parts)
|
|
(case format
|
|
((d-m-y)
|
|
(let ((d (car numeric-date-parts))
|
|
(m (cadr numeric-date-parts))
|
|
(y (qif-parse:fix-year (caddr date-parts) 50)))
|
|
(if (and (integer? d) (integer? m) (integer? y)
|
|
(<= m 12) (<= d 31))
|
|
(set! retval (list d m y))
|
|
(gnc:warn "qif-parse:parse-date/format: "
|
|
"format is d/m/y, but date is ["
|
|
date-string "]."))))
|
|
|
|
((m-d-y)
|
|
(let ((m (car numeric-date-parts))
|
|
(d (cadr numeric-date-parts))
|
|
(y (qif-parse:fix-year (caddr date-parts) 50)))
|
|
(if (and (integer? d) (integer? m) (integer? y)
|
|
(<= m 12) (<= d 31))
|
|
(set! retval (list d m y))
|
|
(gnc:warn "qif-parse:parse-date/format: "
|
|
"format is m/d/y, but date is ["
|
|
date-string "]."))))
|
|
|
|
((y-m-d)
|
|
(let ((y (qif-parse:fix-year (car date-parts) 50))
|
|
(m (cadr numeric-date-parts))
|
|
(d (caddr numeric-date-parts)))
|
|
(if (and (integer? d) (integer? m) (integer? y)
|
|
(<= m 12) (<= d 31))
|
|
(set! retval (list d m y))
|
|
(gnc:warn "qif-parse:parse-date/format: "
|
|
"format is y/m/d, but date is ["
|
|
date-string "]."))))
|
|
|
|
((y-d-m)
|
|
(let ((y (qif-parse:fix-year (car date-parts) 50))
|
|
(d (cadr numeric-date-parts))
|
|
(m (caddr numeric-date-parts)))
|
|
(if (and (integer? d) (integer? m) (integer? y)
|
|
(<= m 12) (<= d 31))
|
|
(set! retval (list d m y))
|
|
(gnc:warn "qif-parse:parse-date/format: "
|
|
"format is y/d/m, but date is ["
|
|
date-string "]."))))))
|
|
retval))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; number format predicates
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (value-is-decimal-radix? value)
|
|
(if (regexp-exec decimal-radix-regexp value)
|
|
#t #f))
|
|
|
|
(define (value-is-comma-radix? value)
|
|
(if (regexp-exec comma-radix-regexp value)
|
|
#t #f))
|
|
|
|
(define (value-is-integer? value)
|
|
(if (regexp-exec integer-regexp value)
|
|
#t #f))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-parse:check-number-format
|
|
;; given a list of possible number formats, return a pruned list
|
|
;; of possibilities.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:check-number-format value-string possible-formats)
|
|
(let ((retval possible-formats))
|
|
(if (not (value-is-decimal-radix? value-string))
|
|
(set! retval (delq 'decimal retval)))
|
|
(if (not (value-is-comma-radix? value-string))
|
|
(set! retval (delq 'comma retval)))
|
|
(if (not (value-is-integer? value-string))
|
|
(set! retval (delq 'integer retval)))
|
|
retval))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; qif-parse:parse-number/format
|
|
;; assuming we know what the format is, parse the string.
|
|
;; returns a gnc-numeric; the denominator is set so as to exactly
|
|
;; represent the number
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (qif-parse:parse-number/format value-string format)
|
|
(let ((minus-index (string-index value-string #\-))
|
|
(filtered-string (gnc:string-delete-chars value-string "$'+-")))
|
|
(case format
|
|
((decimal)
|
|
(let* ((read-string (string-remove-char filtered-string #\,))
|
|
(read-val (with-input-from-string read-string
|
|
(lambda () (read)))))
|
|
(if (number? read-val)
|
|
(double-to-gnc-numeric
|
|
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
|
|
GNC-DENOM-AUTO
|
|
(logior (GNC-DENOM-SIGFIGS
|
|
(string-length (string-remove-char read-string #\.)))
|
|
GNC-RND-ROUND))
|
|
(gnc-numeric-zero))))
|
|
((comma)
|
|
(let* ((read-string (gnc:string-replace-char
|
|
(string-remove-char filtered-string #\.)
|
|
#\, #\.))
|
|
(read-val (with-input-from-string read-string
|
|
(lambda () (read)))))
|
|
(if (number? read-val)
|
|
(double-to-gnc-numeric
|
|
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
|
|
GNC-DENOM-AUTO
|
|
(logior (GNC-DENOM-SIGFIGS
|
|
(string-length (string-remove-char read-string #\.)))
|
|
GNC-RND-ROUND))
|
|
(gnc-numeric-zero))))
|
|
((integer)
|
|
(let ((read-val (with-input-from-string filtered-string
|
|
(lambda () (read)))))
|
|
(if (number? read-val)
|
|
(double-to-gnc-numeric
|
|
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
|
|
1 GNC-RND-ROUND)
|
|
(gnc-numeric-zero)))))))
|
|
|
|
(define (qif-parse:check-number-formats amt-strings formats)
|
|
(let ((retval formats))
|
|
(for-each
|
|
(lambda (amt)
|
|
(if amt
|
|
(set! retval (qif-parse:check-number-format amt retval))))
|
|
amt-strings)
|
|
retval))
|
|
|
|
(define (qif-parse:parse-numbers/format amt-strings format)
|
|
(let* ((all-ok #t)
|
|
(tmp #f)
|
|
(parsed
|
|
(map
|
|
(lambda (amt)
|
|
(if amt
|
|
(begin
|
|
(set! tmp (qif-parse:parse-number/format amt format))
|
|
(if (not tmp)
|
|
(set! all-ok #f))
|
|
tmp)
|
|
(gnc-numeric-zero)))
|
|
amt-strings)))
|
|
(if all-ok parsed #f)))
|
|
|
|
(define (qif-parse:print-date date-list)
|
|
(let ((tm (gnc-localtime (current-time))))
|
|
(set-tm:mday tm (car date-list))
|
|
(set-tm:mon tm (- (cadr date-list) 1))
|
|
(set-tm:year tm (- (caddr date-list) 1900))
|
|
(strftime "%a %B %d %Y" tm)))
|
|
|
|
(define (qif-parse:print-number num)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write num))))
|
|
|
|
(define (qif-parse:print-numbers num)
|
|
(with-output-to-string
|
|
(lambda ()
|
|
(write num))))
|