"Fossies" - the Fresh Open Source Software Archive  

Source code changes of the file "gnucash/import-export/qif-imp/qif-parse.scm" between
gnucash-3.6.tar.bz2 and gnucash-3.7.tar.bz2

About: GnuCash is personal and small-business financial-accounting software.

qif-parse.scm  (gnucash-3.6.tar.bz2):qif-parse.scm  (gnucash-3.7.tar.bz2)
skipping to change at line 27 skipping to change at line 27
;; ;;
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact: ;; along with this program; if not, contact:
;; ;;
;; Free Software Foundation Voice: +1-617-542-5942 ;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652 ;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org ;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (gnucash import-export string)) (use-modules (gnucash import-export string))
(use-modules (srfi srfi-13))
(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 ;; qif-split:parse-category
;; this one just gets nastier and nastier. ;; this one just gets nastier and nastier.
;; ATM we return a list of 6 elements: ;; ATM we return a list of 6 elements:
;; parsed category name (without [] if it was an account name) ;; parsed category name (without [] if it was an account name)
;; bool stating if it was an account name ;; bool stating if it was an account name
;; class of account or #f ;; class of account or #f
;; string representing the "miscx category" if any ;; string representing the "miscx category" if any
;; bool if miscx category is an account ;; bool if miscx category is an account
;; class of miscx cat or #f ;; class of miscx cat or #f
;; gosh, I love regular expressions. ;; gosh, I love regular expressions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define qif-category-compiled-rexp
(make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))
? *$"))
(define (qif-split:parse-category self value) (define (qif-split:parse-category self value)
(let ((match (regexp-exec qif-category-compiled-rexp value))) ;; example category regex matches (excluding initial 'L'):
(if match ;; field1
(let ((rv ;; field1/field2
(list (match:substring match 2) ;; field1/|field3
(if (and (match:substring match 1) ;; field1/|field3/field4
(match:substring match 3))
#t #f) ;; where field1 is a category or [account]
(if (match:substring match 4) ;; and field2 is a class
(match:substring match 5) ;; and field3 is a miscx-category or [miscx-account]
#f) ;; and field4 is a miscx-class
;; miscx category name (cond
(if (match:substring match 6) ((regexp-exec qif-category-compiled-rexp value) =>
(match:substring match 8) (lambda (rmatch)
#f) (list (match:substring rmatch 2)
;; is it an account? (and (match:substring rmatch 1)
(if (and (match:substring match 7) (match:substring rmatch 3)
(match:substring match 9)) #t)
#t #f) (and (match:substring rmatch 4)
(if (match:substring match 10) (match:substring rmatch 5))
(match:substring match 11) ;; miscx category name
#f)))) (and (match:substring rmatch 6)
rv) (match:substring rmatch 8))
(begin ;; is it an account?
;; Parsing failed. Bug detected! (and (match:substring rmatch 7)
(gnc:warn "qif-split:parse-category: can't parse [" value "].") (match:substring rmatch 9)
(throw 'bug #t)
"qif-split:parse-category" (and (match:substring rmatch 10)
"Can't parse account or category ~A." (match:substring rmatch 11)))))
(list value) (else
#f))))) ;; 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 ;; qif-parse:fix-year
;; this is where we handle y2k fixes etc. input is a string ;; this is where we handle y2k fixes etc. input is a string
;; containing the year ("00", "2000", and "19100" all mean the same ;; containing the year ("00", "2000", and "19100" all mean the same
;; thing). output is an integer representing the year in the C.E. ;; thing). output is an integer representing the year in the C.E.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:fix-year year-string y2k-threshold) (define (qif-parse:fix-year year-string y2k-threshold)
(let ((fixed-string #f) (let* ((fixed-string
(post-read-value #f) (cond
(y2k-fixed-value #f)) ((char=? (string-ref year-string 0) #\')
(gnc:warn "qif-file:fix-year: weird QIF year [" year-string "].")
;; quicken prints 2000 as "' 0" for at least some versions. (substring year-string 2 (string-length year-string)))
;; thanks dave p for reporting this. (else year-string)))
(if (eq? (string-ref year-string 0) #\') (post-read-value (with-input-from-string fixed-string read)))
(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 (cond
;; 2-digit numbers less than the window size are interpreted to ;; 2-digit numbers less than the window size are interpreted to
;; be post-2000. ;; be post-2000.
((and (integer? post-read-value) ((and (integer? post-read-value) (< post-read-value y2k-threshold))
(< post-read-value y2k-threshold)) (+ 2000 post-read-value))
(set! y2k-fixed-value (+ 2000 post-read-value)))
;; there's a common bug in printing post-2000 dates that prints
;; there's a common bug in printing post-2000 dates that ;; 2000 as 19100 etc.
;; prints 2000 as 19100 etc. ((and (integer? post-read-value) (> post-read-value 19000))
((and (integer? post-read-value) (+ 1900 (- post-read-value 19000)))
(> post-read-value 19000))
(set! y2k-fixed-value (+ 1900 (- post-read-value 19000))))
;; normal dates represented in unix years (i.e. year-1900, so ;; normal dates represented in unix years (i.e. year-1900, so
;; 2000 => 100.) We also want to allow full year specifications, ;; 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 ;; (i.e. 1999, 2001, etc) and there's a point at which you can't
;; determine which is which. this should eventually be another ;; determine which is which. this should eventually be another
;; field in the qif-file struct but not yet. ;; field in the qif-file struct but not yet.
((and (integer? post-read-value) ((and (integer? post-read-value) (< post-read-value 1902))
(< post-read-value 1902)) (+ 1900 post-read-value))
(set! y2k-fixed-value (+ 1900 post-read-value)))
;; this is a normal, 4-digit year spec (1999, 2000, etc). ;; this is a normal, 4-digit year spec (1999, 2000, etc).
((integer? post-read-value) ((integer? post-read-value) post-read-value)
(set! y2k-fixed-value post-read-value))
;; No idea what the string represents. Maybe a new bug in Quicken! ;; No idea what the string represents. Maybe a new bug in Quicken!
(#t (else
(gnc:warn "qif-file:fix-year: ay caramba! What is this? [" (gnc:warn "qif-file:fix-year: ay! What is this? [" year-string "].")
year-string "]."))) #f))))
y2k-fixed-value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-acct-type : set the type of the account, using gnucash ;; parse-acct-type : set the type of the account, using gnucash
;; conventions. ;; conventions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-acct-type read-value errorproc errortype) (define (qif-parse:parse-acct-type read-value errorproc errortype)
(let ((mangled-string (define string-map-alist
(string-downcase! (string-remove-trailing-space (list (list "bank" GNC-BANK-TYPE)
(string-remove-leading-space read-value))))) (list "port" GNC-BANK-TYPE)
(cond (list "cash" GNC-CASH-TYPE)
((string=? mangled-string "bank") (list "ccard" GNC-CCARD-TYPE)
(list GNC-BANK-TYPE)) (list "invst" GNC-BANK-TYPE)
((string=? mangled-string "port") (list "401(k)/403(b)" GNC-BANK-TYPE)
(list GNC-BANK-TYPE)) (list "oth a" GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE)
((string=? mangled-string "cash") (list "oth l" GNC-LIABILITY-TYPE GNC-CCARD-TYPE)
(list GNC-CASH-TYPE)) (list "oth s" GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE)
((string=? mangled-string "ccard") (list "mutual" GNC-BANK-TYPE)))
(list GNC-CCARD-TYPE)) (or (assoc-ref string-map-alist (string-downcase! (string-trim-both read-value
((string=? mangled-string "invst") ;; these are brokerage accounts. )))
(list GNC-BANK-TYPE)) (let ((msg (format #f (_ "Unrecognized account type '~s'. Defaulting to Ba
((string=? mangled-string "401(k)/403(b)") nk.")
(list GNC-BANK-TYPE)) read-value)))
((string=? mangled-string "oth a") (errorproc errortype msg)
(list GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE)) (list GNC-BANK-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 Ba
nk.")
read-value))
(list GNC-BANK-TYPE)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-bang-field : the bang fields switch the parse context ;; parse-bang-field : the bang fields switch the parse context
;; for the qif file. ;; for the qif file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-bang-field read-value) (define (qif-parse:parse-bang-field read-value)
(let ((bang-field (string-downcase! (let ((bang-field (string-downcase! (string-trim-right read-value))))
(string-remove-trailing-space read-value)))) ;; The QIF files output by the WWW site of Credit Lyonnais
;; The QIF files output by the WWW site of Credit Lyonnais ;; begin by: !type bank
;; begin by: !type bank ;; instead of: !Type:bank
;; instead of: !Type:bank
(if (>= (string-length bang-field) 5) (if (>= (string-length bang-field) 5)
(if (string=? (substring bang-field 0 5) "type ") (if (string=? (substring bang-field 0 5) "type ")
(string-set! bang-field 4 #\:))) (string-set! bang-field 4 #\:)))
(string->symbol bang-field))) (string->symbol bang-field)))
(define (qif-parse:parse-action-field read-value errorproc errortype) (define (qif-parse:parse-action-field read-value errorproc errortype)
(if read-value (define action-map
(let ((action-symbol (string-to-canonical-symbol read-value))) '((buy cvrshrt kauf)
(case action-symbol (buyx cvrshrtx kaufx)
;; buy (cglong cglong kapgew)
((buy cvrshrt kauf) (cglongx cglongx kapgewx)
'buy) (cgmid cgmid)
((buyx cvrshrtx kaufx) (cgmidx cgmidx)
'buyx) (cgshort cgshort k.gewsp)
((cglong kapgew) ;; Kapitalgewinnsteuer (cgshortx cgshortx k.gewspx)
'cglong) (div div)
((cglongx kapgewx) (divx divx)
'cglongx) ;; (exercise exercise)
((cgmid) ;; Kapitalgewinnsteuer ;; (exercisx exercisx)
'cgmid) ;; (expire expire)
((cgmidx) ;; (grant grant)
'cgmidx) (intinc int intinc)
((cgshort k.gewsp) (intincx intx intincx)
'cgshort) (margint margint)
((cgshortx k.gewspx) (margintx margintx)
'cgshortx) (miscexp miscexp)
((div) ;; dividende (miscexpx miscexpx)
'div) (miscinc miscinc cash)
((divx) (miscincx miscincx)
'divx) (reinvdiv reinvdiv)
; ((exercise) (reinvint reinvint reinvzin)
; 'exercise) (reinvlg reinvlg reinvkur)
; ((exercisx) (reinvmd reinvmd)
; 'exercisx) (reinvsg reinvsg reinvksp)
; ((expire) (reinvsh reinvsh)
; 'expire) (reminder reminder erinnerg)
; ((grant) (rtrncap rtrncap)
; 'grant) (rtrncapx rtrncapx)
((int intinc) ;; zinsen (sell sell shtsell verkauf)
'intinc) (sellx sellx shtsellx verkaufx)
((intx intincx) (shrsin shrsin aktzu)
'intincx) (shrsout shrsout aktab)
((margint) (stksplit stksplit aktsplit)
'margint) (xin xin contribx)
((margintx) (xout xout withdrwx)))
'margintx) (and read-value
((miscexp) (let ((sym (string->symbol (string-downcase (string-trim-both read-value)
'miscexp) ))))
((miscexpx) (or (any (lambda (lst) (and (memq sym lst) (car lst))) action-map)
'miscexpx) (let ((msg (format #f (_ "Unrecognized action '~a'.") read-value)))
((miscinc cash) (errorproc errortype msg))))))
'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, ;; parse-cleared-field : In a "C" (cleared status) QIF line,
;; * or C means cleared, X or R means reconciled, and ! or ? ;; * or C means cleared, X or R means reconciled, and ! or ?
;; mean some budget related stuff I don't understand. ;; mean some budget related stuff I don't understand.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-cleared-field read-value errorproc errortype) (define (qif-parse:parse-cleared-field read-value errorproc errortype)
(if (and (string? read-value) (define maplist
(not (string-null? read-value))) '((reconciled #\X #\x #\R #\r)
(let ((secondchar (string-ref read-value 0))) (cleared #\* #\C #\c)
(case secondchar (budgeted #\? #\!)))
;; Reconciled is the most likely, especially for large imports, (and
;; so check that first. Also allow for lowercase. (string? read-value)
((#\X #\x #\R #\r) (not (string-null? read-value))
'reconciled) (let* ((secondchar (string-ref read-value 0)))
((#\* #\C #\c) (or (any (lambda (m) (and (memq secondchar (cdr m)) (car m))) maplist)
'cleared) (let ((msg (format #f (_ "Unrecognized status '~a'. Defaulting to uncle
((#\? #\!) ared.")
'budgeted) read-value)))
(else (errorproc errortype msg))))))
(errorproc errortype
(format #f (_ "Unrecognized status '~a'. Defaulting to un
cleared.")
read-value))
#f)))
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-check-date-format ;; parse-check-date-format
;; given a match-triple (matches in spaces 1, 2, 3) and a ;; given a match-triple (matches in spaces 1, 2, 3) and a
;; list of possible date formats, return the list of formats ;; list of possible date formats, return the list of formats
;; that this date string could actually be. ;; that this date string could actually be.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-check-date-format match possible-formats) (define (parse-check-date-format match possible-formats)
(let ((date-parts (list (match:substring match 1) (define (date? d m y ys)
(match:substring match 2) (and (number? d) (<= 1 d 31)
(match:substring match 3))) (number? m) (<= 1 m 12)
(numeric-date-parts '()) (number? y) (or (not (= 4 (string-length ys)))
(retval '())) (> y 1930))))
(let* ((date-parts (list (match:substring match 1)
;;(define (print-list l) (match:substring match 2)
;; (for-each (lambda (x) (display x) (display " ")) l)) (match:substring match 3)))
(numeric-date-parts (map (lambda (elt) (with-input-from-string elt read
;;(for-each (lambda (x) (if (list? x) (print-list x) (display x))) ))
;; (list "parsing: " date-parts " in " possible-formats "\n")) date-parts))
(n1 (car numeric-date-parts))
;; get the strings into numbers (but keep the strings around) (n2 (cadr numeric-date-parts))
(set! numeric-date-parts (n3 (caddr numeric-date-parts))
(map (lambda (elt) (s1 (car date-parts))
(with-input-from-string elt (s3 (caddr date-parts))
(lambda () (read)))) (format-alist (list (list 'd-m-y n1 n2 n3 s3)
date-parts)) (list 'm-d-y n2 n1 n3 s3)
(list 'y-m-d n3 n2 n1 s1)
(let ((possibilities possible-formats) (list 'y-d-m n2 n3 n1 s1))))
(n1 (car numeric-date-parts))
(n2 (cadr numeric-date-parts)) (let lp ((possible-formats possible-formats)
(n3 (caddr numeric-date-parts)) (res '()))
(s1 (car date-parts)) (cond
(s3 (caddr date-parts))) ((null? possible-formats) (reverse res))
(else
;; filter the possibilities to eliminate (hopefully) (lp (cdr possible-formats)
;; all but one (let ((args (assq (car possible-formats) format-alist)))
(if (or (not (number? n1)) (> n1 12)) (if (apply date? (cdr args)) (cons (car args) res) res))))))))
(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 ;; qif-parse:check-date-format
;; given a list of possible date formats, return a pruned list ;; given a list of possible date formats, return a pruned list
;; of possibilities. ;; of possibilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:check-date-format date-string possible-formats) (define qif-date-compiled-rexp
(let ((retval '())) (make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9
(if (or (not (string? date-string)) ][0-9][0-9][0-9][0-9][0-9][0-9]).*$"))
(not (> (string-length date-string) 0)))
(set! retval #f) (define qif-date-mdy-compiled-rexp
(let ((match (regexp-exec qif-date-compiled-rexp date-string))) (make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])"))
(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-format
s)))
(if (or (memq 'd-m-y possible-formats)
(memq 'm-d-y possible-formats))
(set! res2 (parse-check-date-format date-mdy possible-format
s)))
(set! retval (append res1 res2))))))) (define qif-date-ymd-compiled-rexp
(make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])"))
retval)) (define (qif-parse:check-date-format date-string possible-formats)
(and (string? date-string)
(not (string-null? date-string))
(let ((rmatch (regexp-exec qif-date-compiled-rexp date-string)))
(if rmatch
(if (match:substring rmatch 1)
(parse-check-date-format rmatch 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* ((newstr (match:substring rmatch 4))
(date-ymd (regexp-exec qif-date-ymd-compiled-rexp newstr
))
(date-mdy (regexp-exec qif-date-mdy-compiled-rexp newstr
)))
(append
(if (or (memq 'y-d-m possible-formats)
(memq 'y-m-d possible-formats))
(parse-check-date-format date-ymd possible-formats))
(if (or (memq 'd-m-y possible-formats)
(memq 'm-d-y possible-formats))
(parse-check-date-format date-mdy possible-formats))))))
)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:parse-date/format ;; qif-parse:parse-date/format
;; given a date-string and a format, convert the string to a ;; given a date-string and a format, convert the string to a
;; date and return a list of day, month, year ;; date and return a list of day, month, year
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-date/format date-string format) (define (qif-parse:parse-date/format date-string dateformat)
(let ((date-parts '()) (define (date? d m y)
(numeric-date-parts '()) (and (number? d) (<= 1 d 31)
(retval #f) (number? m) (<= 1 m 12)))
(let* ((rmatch (regexp-exec qif-date-compiled-rexp date-string))
(match (regexp-exec qif-date-compiled-rexp date-string))) (date-parts
(if match (if rmatch
(if (match:substring match 1) (if (match:substring rmatch 1)
(set! date-parts (list (match:substring match 1) (list (match:substring rmatch 1)
(match:substring match 2) (match:substring rmatch 2)
(match:substring match 3))) (match:substring rmatch 3))
;; This is of the form XXXXXXXX; split the string based on ;; This is of the form XXXXXXXX; split the string based on
;; whether the format is YYYYxxxx or xxxxYYYY ;; whether the format is YYYYxxxx or xxxxYYYY
(let ((date-str (match:substring match 4))) (let ((date-str (match:substring rmatch 4)))
(case format (case dateformat
((d-m-y m-d-y) ((d-m-y m-d-y)
(let ((m (regexp-exec qif-date-mdy-compiled-rexp date-str))) (let ((m (regexp-exec qif-date-mdy-compiled-rexp date-str
(set! date-parts (list (match:substring m 1) )))
(match:substring m 2) (list (match:substring m 1)
(match:substring m 3))))) (match:substring m 2)
((y-m-d y-d-m) (match:substring m 3))))
(let ((m (regexp-exec qif-date-ymd-compiled-rexp date-str))) ((y-m-d y-d-m)
(set! date-parts (list (match:substring m 1) (let ((m (regexp-exec qif-date-ymd-compiled-rexp date-str
(match:substring m 2) )))
(match:substring m 3))))) (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 ;; get the strings into numbers (but keep the strings around)
(map (lambda (elt) (numeric-date-parts (map (lambda (elt) (with-input-from-string elt read
(with-input-from-string elt ))
(lambda () (read)))) date-parts)))
date-parts))
(define (refs->list dd mm yy)
(let ((d (list-ref numeric-date-parts dd))
(m (list-ref numeric-date-parts mm))
(y (qif-parse:fix-year (list-ref date-parts yy) 50)))
(cond
((date? d m y) (list d m y))
(else (gnc:warn "qif-parse:parse-date/format: format is " dateformat
" but date is [" date-string "].") #f))))
;; if the date parts list doesn't have 3 parts, we're in trouble ;; if the date parts list doesn't have 3 parts, we're in trouble
(if (not (eq? 3 (length date-parts))) (cond
(gnc:warn "qif-parse:parse-date/format: can't interpret date [" ((not (= 3 (length date-parts)))
date-string "]\nDate parts: " date-parts) (gnc:warn "qif-parse:parse-date/format: can't interpret date ["
(case format date-string "]\nDate parts: " date-parts) #f)
((d-m-y) ((eq? dateformat 'd-m-y) (refs->list 0 1 2))
(let ((d (car numeric-date-parts)) ((eq? dateformat 'm-d-y) (refs->list 1 0 2))
(m (cadr numeric-date-parts)) ((eq? dateformat 'y-m-d) (refs->list 2 1 0))
(y (qif-parse:fix-year (caddr date-parts) 50))) ((eq? dateformat 'y-d-m) (refs->list 2 0 1)))))
(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 ;; number format predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (value-is-decimal-radix? value) ;; eg 1000.00 or 1,500.00 or 2'000.00
(if (regexp-exec decimal-radix-regexp value) (define decimal-radix-regexp
#t #f)) (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?(
[,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *
(define (value-is-comma-radix? value) $"))
(if (regexp-exec comma-radix-regexp value)
#t #f)) ;; eg 5.000,00 or 4'500,00
(define comma-radix-regexp
(define (value-is-integer? value) (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?(
(if (regexp-exec integer-regexp value) [\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$"
#t #f)) ))
;; eg 456 or 123
(define integer-regexp
(make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:check-number-format ;; qif-parse:check-number-format
;; given a list of possible number formats, return a pruned list ;; given a list of possible number formats, return a pruned list
;; of possibilities. ;; of possibilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:check-number-format value-string possible-formats) (define (qif-parse:check-number-format value-string possible-formats)
(let ((retval possible-formats)) (define numtypes-alist
(if (not (value-is-decimal-radix? value-string)) (list (cons 'decimal decimal-radix-regexp)
(set! retval (delq 'decimal retval))) (cons 'comma comma-radix-regexp)
(if (not (value-is-comma-radix? value-string)) (cons 'integer integer-regexp)))
(set! retval (delq 'comma retval))) (filter (lambda (fmt) (regexp-exec (assq-ref numtypes-alist fmt) value-string)
(if (not (value-is-integer? value-string)) )
(set! retval (delq 'integer retval))) possible-formats))
retval))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:parse-number/format ;; qif-parse:parse-number/format
;; assuming we know what the format is, parse the string. ;; assuming we know what the format is, parse the string.
;; returns a gnc-numeric; the denominator is set so as to exactly ;; returns a gnc-numeric; the denominator is set so as to exactly
;; represent the number ;; represent the number
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following is a working refactored function
(define (qif-parse:parse-number/format value-string format) (define (qif-parse:parse-number/format value-string format)
(let ((minus-index (string-index value-string #\-)) (let* ((filtered-string (gnc:string-delete-chars value-string "$'+"))
(filtered-string (gnc:string-delete-chars value-string "$'+-"))) (read-string (case format
(case format ((decimal) (gnc:string-delete-chars filtered-string ",")
((decimal) )
(let* ((read-string (string-remove-char filtered-string #\,)) ((comma) (gnc:string-replace-char
(read-val (with-input-from-string read-string (gnc:string-delete-chars filtered-string ".")
(lambda () (read))))) #\, #\.))
(if (number? read-val) ((integer) filtered-string))))
(double-to-gnc-numeric (or (string->number (string-append "#e" read-string)) 0)))
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
GNC-DENOM-AUTO ;; input: list of numstrings eg "10.50" "20.54"
(logior (GNC-DENOM-SIGFIGS ;; input: formats to test '(decimal comma integer)
(string-length (string-remove-char read-string #\.))) ;; output: list of formats applicable eg '(decimal)
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) (define (qif-parse:check-number-formats amt-strings formats)
(let ((retval formats)) (let lp ((amt-strings amt-strings)
(for-each (formats formats))
(lambda (amt) (if (null? amt-strings)
(if amt formats
(set! retval (qif-parse:check-number-format amt retval)))) (lp (cdr amt-strings)
amt-strings) (if (car amt-strings)
retval)) (qif-parse:check-number-format (car amt-strings) formats)
formats)))))
;; list of number-strings and format -> list of numbers eg '("1,00"
;; "2,50" "3,99") 'comma --> '(1 5/2 399/100) this function would
;; formerly attempt to return #f if a list element couldn't be parsed;
;; but in practice always returns a list, with unparsed numbers as 0.
(define (qif-parse:parse-numbers/format amt-strings format) (define (qif-parse:parse-numbers/format amt-strings format)
(let* ((all-ok #t) (map (lambda (amt) (if amt (qif-parse:parse-number/format amt format) 0))
(tmp #f) amt-strings))
(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) (define (qif-parse:print-date date-list)
(let ((tm (gnc-localtime (current-time)))) (let ((tm (gnc-localtime (current-time))))
(set-tm:mday tm (car date-list)) (set-tm:mday tm (car date-list))
(set-tm:mon tm (- (cadr date-list) 1)) (set-tm:mon tm (- (cadr date-list) 1))
(set-tm:year tm (- (caddr date-list) 1900)) (set-tm:year tm (- (caddr date-list) 1900))
(gnc-print-time64 (gnc-mktime tm) "%a %B %d %Y"))) (gnc-print-time64 (gnc-mktime tm) "%a %B %d %Y")))
(define (qif-parse:print-number num) (define (qif-parse:print-number num)
(with-output-to-string (with-output-to-string
 End of changes. 25 change blocks. 
499 lines changed or deleted 297 lines changed or added

Home  |  About  |  Features  |  All  |  Newest  |  Dox  |  Diffs  |  RSS Feeds  |  Screenshots  |  Comments  |  Imprint  |  Privacy  |  HTTP(S)