IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

QIF import code from cbbrowne@godel.brownes.org

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1882 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Linas Vepstas 1999-08-04 05:08:16 +00:00
parent 199e236ccf
commit 3a4e3bb6ca
6 changed files with 841 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

188
src/scm/dates-qif.scm Normal file
View File

@ -0,0 +1,188 @@
;;;;;;; Date-related code
(define findspace (substring-search-maker " "))
(define findslash (substring-search-maker "/"))
;;; Replace spaces in date fields with zeros so
;;; "4/ 7/99" transforms to "4/07/99"
(define (replacespace0 string)
(let
((slen (string-length string))
(spacepos (findspace string)))
(if spacepos
(replacespace0
(string-append
(substring string 0 spacepos)
"0"
(substring string (+ 1 spacepos) slen)))
string)))
;;;; Check the way the dates look; figure out whether it's
;;;; DD/MM/YY, MM/DD/YY, YY/MM/DD, or whatever...
(define date-low #f)
(define date-med #f)
(define date-high #f)
(define min-date-low #f)
(define min-date-med #f)
(define min-date-high #f)
(define max-date-low #f)
(define max-date-med #f)
(define max-date-high #f)
(define (resetdates)
(set! date-low #f)
(set! date-med #f)
(set! date-high #f)
(set! min-date-low 9999)
(set! min-date-med 9999)
(set! min-date-high 9999)
(set! max-date-low 0)
(set! max-date-med 0)
(set! max-date-high 0))
(define (newdatemaxes dpieces)
(let
((p1 (string->number (car dpieces)))
(p2 (string->number (cadr dpieces)))
(p3 (string->number (caddr dpieces))))
(if (< p1 min-date-low)
(set! min-date-low p1))
(if (< p2 min-date-med)
(set! min-date-med p2))
(if (< p3 min-date-high)
(set! min-date-high p3))
(if (> p1 max-date-low)
(set! max-date-low p1))
(if (> p2 max-date-med)
(set! max-date-med p2))
(if (> p3 max-date-high)
(set! max-date-high p3))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (checkdatemaxes) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a fairly "intelligent" routine that examines the date
;;; ranges in min-date-low, max-date-low, min-date-med, max-date-med,
;;; min-date-med, max-date-med, and determines which of these fields
;;; corresponds to Day, Month, and Year.
;;; Results are stored in date-low, date-med, date-high, assigning the
;;; symbols 'mm, 'dd, and 'yy appropriately.
;;; It uses the considerations that:
;;; - There are a maximum of 12 months in a year
;;; - There are a maximum of 31 days in a month
;;; - Year "0" likely indicates "Year 2000."
;;; At the point at which "Problem: Range occurs twice!" is indicated,
;;; it would be a reasonable idea to pop up a dialog to the user
;;; indicating such things as the ranges that were found (e.g. - 1-12,
;;; 2-11, 94-99), provide the "best guess" default of mm/dd/yy, and
;;; allow the user the option of overriding this as desired.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (checkdatemaxes)
(define (favor min max)
(cond
((> max 31) 'yy) ;;; [max > 31] --> Year
((and (< max 32) (> max 12)) 'dd) ;;; Max in [13,31] --> Day
((= min 0) 'yy) ;;; [min=0] --> Year xx00
(else 'mm)))
(let
((vl (favor min-date-low max-date-low))
(vm (favor min-date-med max-date-med))
(vh (favor min-date-high max-date-high)))
(begin
(if (or (eq? vl vm) (eq? vl vh) (eq? vm vh))
(begin
(display "Problem: Range occurs twice!") ; Problem! A range appears twice!
(newline)
(display "Low Values:(Low Medium High)")
(display (list min-date-low min-date-med min-date-high)) (newline)
(display "High Values:(Low Medium High)")
(display (list max-date-low max-date-med max-date-high)) (newline)
(display
(string-append
"(VL VM VH) ("
(number->string v1)
" "
(number->string v2)
" " (number->string v3) ")" ))
(newline)
(display "Assuming common default of MM/DD/YY")
(newline)
(set! date-low 'mm)
(set! date-med 'dd)
(set! date-high yy)
;; This would be a great place to put a "hook" to allow the
;; user to interactively set (date-low, date-med, date-high)
;; to their favorite permuatation of ('mm 'dd 'yy)
)
(begin
(set! date-low vl)
(set! date-med vm)
(set! date-high vh))))))
(define (atom? x)
(and
(not (pair? x))
(not (null? x))))
(define (rewrite-dates txn)
(cond
((atom? txn) txn)
((pair? txn) ; If it's a pair, see if it's a date...
(if (eq? (car txn) 'date)
(cons 'date (reformat-date (cdr txn)))
txn))
((list? txn) ; List? - Split and process pieces
(cons (rewrite-dates (car txn))
(rewrite-dates (cdr txn))))))
(define (reformat-date date-as-string)
(let*
((datesplitup (split-on-somechar date-as-string #\/))
(p1 (string->number (car datesplitup)))
(p2 (string->number (cadr datesplitup)))
(p3 (string->number (caddr datesplitup)))
(YEAR 0)
(MONTH 0)
(DAY 0)
(dropin (lambda (yy-or-mm-or-dd value)
(cond
((eq? yy-or-mm-or-dd 'yy)
(set! YEAR value))
((eq? yy-or-mm-or-dd 'mm)
(set! MONTH value))
((eq? yy-or-mm-or-dd 'dd)
(set! DAY value))))))
(begin
(dropin date-low p1)
(dropin date-med p2)
(dropin date-high p3)
(set! YEAR
(let ((window-range 80) ;;;; Date adjustment window
(first-century 100) ;;;; First century
(next-century 2000) ;;;; Add this to year values that are
;;;; less than the value of
;;;; window-range.
(this-century 1900)) ;;;; Add this-century to year values
;;;; that are greater than window-range,
;;;; and less than first-century
;Based on this set of parameters, the following year substitutions
; would take place:
;YEAR --> New Value
; 00 --> 2000
; 70 --> 2070
; 85 --> 1985
; 99 --> 1999
; 100 --> 100
;1102 --> 1102
;1932 --> 1932
;
; Changing window-range changes the cut-off between last
; century and this one; somewhere around 100 years from
; now, it will probably be appropriate to change
; next-century to 2100, and this-century to 2000.
(cond
((< YEAR window-range)
(+ YEAR next-century))
((and (> YEAR window-range) (< YEAR first-century))
(+ YEAR this-century))
(else ;;; Otherwise, do nothing to the year.
YEAR))))
(list YEAR MONTH DAY))))

173
src/scm/guess-category-qif.scm Normal file
View File

@ -0,0 +1,173 @@
(define (guess-cat inputcat gnucash-cats gnucash-accs)
;;; Need a bunch of metrics, and probably to vectorize this...
;;; 1. Braces --> pick gnucash entries from account list
;;; No braces --> pick gnucash entries from category list
;;; 2. Exact match of names -->
;;; 3. a contains b, b contains a --> end of list
;;; 4. First 2 letters match --> end of list
;;; 5. First letter matches --> end of list
;;; g) I'd like a "similarity match" of some sort
;;; h) Is it in old-matches? If so, toss that to front of list.
;;; Lastly, shorten the list to no more than 4 items.
(let*
((picklist '())
(size-of-list 4) ;; Find the 4 lowest items...
(lowestn '())
(catlength (string-length inputcat)) ; How long is incat?
(is-acct? (and ; as the list to compare to
(>= catlength 2)
(string=? (substring inputcat 0 1) "[")
(string=? (substring inputcat (- catlength 1) catlength) "]")))
(acctlist ; Pick either gnucash-cats/gnucash-accs
(if
is-acct?
gnucash-accs
gnucash-cats))
(incat (if is-acct?
(substring inputcat 1 (- catlength 1))
inputcat))
; (null (if is-acct? (write (string-append "Account!" incat))))
(add-to-picklist
(lambda (string value)
(let
((inlist? (assoc string picklist)))
(if
inlist?
(let
((oldvalue (cdr inlist?)))
(if
(> oldvalue value)
(set-cdr! inlist? value)))
(set! picklist (cons (cons string value) picklist))))))
(match-against-list
(lambda (itemstring)
(if (string=? itemstring incat) ;;; Exact match
(add-to-picklist itemstring 1))
(if (or ((substring-search-maker incat) itemstring) ;;; Inclusion
((substring-search-maker itemstring) incat))
(add-to-picklist itemstring 3))
(if (string=?
(substring incat 0 (min 2 (string-length incat))) ;; Match first 2 chars
(substring itemstring 0 (min 2 (string-length itemstring))) )
(add-to-picklist itemstring 5))
(if (string=?
(substring incat 0 (min 1 (string-length incat))) ;; Match first 1 char
(substring itemstring 0 (min 1 (string-length itemstring))) )
(add-to-picklist itemstring 7)))))
;;;;;;;; Now, apply the matching...
(for-each match-against-list acctlist)
(write (string-append "Match-against list: " incat)) (write picklist) (newline)
;;;;;;;; Shorten picklist, keeping top 4 items
(let ((shortened '()))
(let loop ((count size-of-list))
(if (> count 0)
(let
((bestitem (find-min-cdr picklist)))
(if bestitem
(begin
(if (> 99 (cdr bestitem))
(set! shortened (cons (car bestitem) shortened)))
(set-cdr! bestitem 999) ;;;; Force off list...
(loop (- count 1)))))))
shortened)))
(define (find-min-cdr mlist)
(if
(null? mlist)
#f
(let
((first (car mlist))
(rest (find-min-cdr (cdr mlist))))
(if
rest ;;; Found a value for rest
(if (> (cdr first) (cdr rest))
rest
first)
first))))
(define (guess-corresponding-categories import-cats gnucash-cats
gnucash-accs)
(define (apply-guess-cat incat)
(guess-cat (car incat) gnucash-cats gnucash-accs))
(map apply-guess-cat import-cats))
;;; Make use of "old-matches," which is an association list
;;; containing the correspondences that have been used previously.
;;; These are almost sure-fire "best matches"
;;;;; (define best-guesses
;;;;; (guess-corresponding-categories
;;;;; kept-categories categories-from-gnucash))
;;;;;
;;;;; The next step would be to ask the user to verify the category
;;;;; matching, thus establishing an association list to be used to
;;;;; translate from QIF to GnuCash. This alist should be merged with
;;;;; whatever is out on disk from "last time," and will become
;;;;; "old-matches" to provide a high quality set of "best guesses"
;;;;; for next time.
;;;;; (define (fix-category-translation best-guesses))
;;;;; which is used thus:
;;;;; (define category-translations (fix-category-translation
;;;;; best-guesses))
;;;;; category-translations is then an alist that is then used to pick
;;;;; off categories for use thus:
;;;;; (let ((use-category (assoc (assoc 'category transaction)
;;;;; category-translations))
;;;;; (date (assoc 'date transaction))
;;;;; (amount (assoc 'amount transaction)))
;;;;; (add-transaction use-category date amount)
;;;;;
;;;;; - Transactions should not be marked off as being finally reconciled on
;;;;; the GnuCash side, as the reconciliation hasn't been done there.
;;;;;
;;;;; Bad Things would happen if we double-load a batch of QIF transactions,
;;;;; and treat it as if it were fully reconciled.
;;;;; This returns the "thunk" that should be used to translate statuses
(define (status-handling tlist)
(define cleared? #f)
(define (look-for-cleared txn)
(if
(string=? "X" (cdr (assoc 'status txn)))
(set! cleared #t)))
(for-each look-for-cleared tlist)
(if cleared?
(begin
(display "Warning: This transaction list includes transactions marked as cleared.")
(display "Are you *completely* confident of the correctness of that")
(display "reconciliation, and that it is *truly* safe to mark them as reconciled")
(display "in GnuCash?")
(display "It is suggested that you indicate ``No,'' which will result in those")
(display "transactions being statused as ``marked,'' which should make the")
(display "reconciliation in GnuCash take place reasonably quickly.")
;;;; Now ask if the user is certain...
;;;; Need some code here...
(if (not certain?)
(set! cleared #f))))
(let*
((cleared-to-what (if cleared? 'cleared 'marked))
(ttable
;;; QIF Status translation table
;;; The CARs are values expected from Quicken.
;;; The CDRs are the values that gnc:transaction-put-status requires...
'(("X" cleared-to-what)
("*" 'marked)
("?" 'budgeted-new)
("!" 'budgeted-old)
("" 'unmarked))))
;;; And here's the "thunk" that is to be returned. It translates QIF statuses
;;; into the form GnuCash expects to pass to gnc:transaction-put-status
(lambda (status)
(let
((a (assoc status ttable)))
(if
a
(cdr a) ;;; If the value was found, use it..
(cdr (assoc "" ttable))))))) ;;; No value? Take the null value from ttable

46
src/scm/importqif.scm Normal file
View File

@ -0,0 +1,46 @@
;;; Parse QIF
(gnc:load "sstring-qif.scm")
(gnc:load "dates-qif.scm")
(gnc:load "split-qif.scm")
(gnc:load "parseqif.scm")
(gnc:load "guess-category-qif.scm")
(gnc:load "analytical-qifs.scm")
(gnc:load "gc-import-qifs.scm")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; Now, let's actually execute the code...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(for-each process-possible-qif-file indir)
;;;;; Open Issues:
;;;;;
;;;;; - What account do we load into?
;;;;; 1. Hopefully this can be determined in an implicit manner...
;;;;; 2. The alternative is that something interactive must be done for
;;;;; a group of transactions, querying the user to select the appropriate
;;;;; account.
;;;;;
;;;;; - What to do with transfers?
;;;;;
;;;;; A transaction where the category is [AA Chequing] or [ACM MasterCard]
;;;;; is obviously a transfer to/from that account. Unfortunately, there is
;;;;; no guarantee that an account by the same exact name exists in GnuCash.
;;;;; Probably ought to cons up a list of categories, agree them to GnuCash,
;;;;; and, most crucially, construct a "category translation table"
;;;;; to indicate what to do with them.
;;;;;
;;;;; The same is true, albeit less critical, for income/expense categories.
;;;;;
;;;;; - Further transfer issue:
;;;;;
;;;;; Note that a QIF load may provide duplicate transactions for transfers,
;;;;; once you load in the amounts for both sides of the transaction.
;;;;;
;;;;; - Category management:
;;;;;
;;;;; What should we do if there are categories in the QIF file that don't
;;;;; exist in GnuCash? Create the new category, maybehaps, but probably
;;;;; by collecting up a list, and giving the option of converting QIF
;;;;; categories to "something new." Again, reference back to the
;;;;; "category translation table"

268
src/scm/parseqif.scm Normal file
View File

@ -0,0 +1,268 @@
;;;;;;;;;;; QIF Parsing ;;;;;;;;;;;;;;
(define tlist '())
(define atrans '())
(define addresslist '())
(define process-qif-file
(lambda (file account-group)
; Opens file, rewrites all the lines, closes files
(display (string-append "rewriting file:" file)) (newline)
(set! tlist '()) ; Reset the transaction list...
(set! atrans '())
(reset-categories)
(resetdates) ; Reset the date checker
(let*
;((infile (open-input-file (string-append srcdir file)))
((infile (open-input-file file))
; (outfile (open-output-file (string-append destdir file) 'replace))
(outfile (open-output-file (string-append file ".XAC")))
(write-to-output-thunk
(lambda (txn)
(write (rewrite-dates txn) outfile)
(newline outfile))))
(begin
(display (string-append ";;;; Data from " file) outfile)
(newline outfile)
(newline outfile))
(let loop
((line (read-line infile)))
(if
(eof-object? line) #f
(let
((newline (rewrite-line line)))
(loop (read-line infile)))))
(if
(checkdatemaxes)
#f
(begin
(display "Problem: Illegal date format!") (newline)
(display ";;;; Problem - date format conflict!" outfile)
(newline outfile)))
(display ";;; Transactional data:" outfile)
(newline outfile)
(display "(define transactions '(" outfile)
(newline outfile)
(for-each write-to-output-thunk tlist)
(display (string-append
"Total transactions: "
(number->string (length tlist))))
(newline)
(display ")) ;;; End of transaction data" outfile)
(newline outfile)
(display "(define categories '" outfile)
(write kept-categories outfile)
(display ")" outfile)
(newline outfile)
(display (string-append
"Total categories: "
(number->string (length kept-categories))))
(newline)
(display "(define acclist")
(display (acclist account-group))
(display ")")
(newline)
(display "(define acclist")
(display (catlist account-group))
(display ")")
(newline)
(let*
((acclist (acclist account-group))
(catlist (catlist account-group))
(guesses (guess-corresponding-categories kept-categories catlist acclist)))
(display "(define cattrans '" outfile)
(write guesses outfile)
(display ")" outfile)
(newline outfile))
(close-input-port infile)
(close-output-port outfile))))
;;; Rewrite a line
(define qifstate '())
(define rewrite-line
(lambda (line)
(if
(string=? (substring line 0 1) "!") ;;; Starts with a !
(newstate line)) ;;; Jump to a new state...
(if (equal? qifstate 'txn) ;;; If it's a transaction
(rewrite-txn-line (striptrailingwhitespace line))))) ;;; Rewrite it
;;; otherwise, do nothing...
(define QIFstates
'(("!Type:Cat" . 'category)
("!Option:AutoSwitch" . 'accounts)
("!Clear:AutoSwitch" . 'account)
("!Account" . 'accounts)
("!Type:Memorized" . 'memorized)
("!Type:Bank" . 'txn)
("!Type:CCard" . 'txn)
("!Type:Oth A" . 'txn)))
;;;; Strip off trailing whitespace
(define (striptrailingwhitespace line)
(let
((stringsize (string-length line)))
(if
(< stringsize 1)
""
(let*
((lastchar (string-ref line (- stringsize 1))))
(if
(char-whitespace? lastchar)
(striptrailingwhitespace (substring line 0 (- stringsize 1)))
line)))))
(define (newstate line)
(let*
((statepair (assoc (striptrailingwhitespace line) QIFstates)))
(begin
(if
(pair? statepair)
(set! qifstate (car (cddr statepair)))
#f))))
(define (transnull line)
#f) ; do nothing with line
(define (oops-new-command-type line)
(write "Oops: New command type!")
(write line))
(define (rewrite-txn-line line)
(let*
((fchar (substring line 0 1))
(found (assoc fchar trans-jumptable)))
(if
found
(let
((tfunction (cdr found)))
(tfunction line))
(oops-new-command-type line))))
;;;; Category management
(define kept-categories '())
(define (reset-categories) ;; reset the list
(set! kept-categories '()))
;;;;(keep-category-for-summary category)
(define (keep-category-for-summary category)
(let
((found (assoc category kept-categories)))
(if
found
(set-cdr! found (+ (cdr found) 1))
(set! kept-categories (cons (cons category 1) kept-categories)))))
;;; Is the account a QIF "category"?
(define (account-category? category)
(and
(string=? (substring category 0 1) "[")
(let
((len (string-length category)))
(string=?
(substring category (- len 1) len) "]"))))
;;;; "numerizeamount" takes the commaed string that QIF provides,
;;;; removes commas, and turns it into a number.
(define (numerizeamount amount-as-string)
(let*
((commasplit (split-on-somechar amount-as-string #\,))
(decommaed (apply string-append commasplit))
(numeric (string->number decommaed)))
(if
numeric ; did the conversion succeed?
numeric ; Yup. Return the value
amount-as-string))) ; Nope. Return the original value.
;;;; At the end of a transaction,
;;;; Insert queued material into "atrans" (such as splits, address)
;;;; Add "atrans" to the master list of transactions,
;;;; And then clear stateful variables.
(define (end-of-transaction line) ; End of transaction
(if (not (null? addresslist))
(set! atrans (cons (cons 'address addresslist) atrans)))
(if splits?
(begin
(set! atrans (cons (cons 'splits splitlist) atrans))
(ensure-split-adds-up)))
(set! tlist (cons atrans tlist))
(set! addresslist '())
(resetsplits)
(set! atrans '()))
;;;;;;;;;;; Various "trans" functions for different
;;;;;;;;;;; sorts of QIF lines
(define (transmemo line)
(let*
((linelen (string-length line))
(memo (substring line 1 linelen)))
(set! atrans (cons (cons 'memo memo) atrans))))
(define (transaddress line)
(let*
((linelen (string-length line))
(addline (substring line 1 linelen)))
(set! addresslist (cons addline addresslist))))
(define (transdate line)
(let*
((linelen (string-length line))
(date (replacespace0 (substring line 1 linelen)))
(dpieces (split-on-somechar date #\/)))
(set! atrans (cons (cons 'date date) atrans))
(newdatemaxes dpieces))) ; collect info on date field ordering
; so we can guess the date format at
; the end based on what the population
; looks like
(define (transamt line)
(let*
((linelen (string-length line))
(amount (numerizeamount (substring line 1 linelen))))
(set! atrans (cons (cons 'amount amount) atrans))))
(define (transid line)
(let*
((linelen (string-length line))
(id (substring line 1 linelen)))
(set! atrans (cons (cons 'id id) atrans))))
(define (transstatus line)
(let*
((linelen (string-length line))
(status (substring line 1 linelen)))
(set! atrans (cons (cons 'status status) atrans))))
(define (transpayee line)
(let*
((linelen (string-length line))
(payee (substring line 1 linelen)))
(set! atrans (cons (cons 'payee payee) atrans))))
(define (transcategory line)
(let*
((linelen (string-length line))
(category (substring line 1 linelen)))
(keep-category-for-summary category)
(set! atrans (cons (cons 'category category) atrans))))
(define
trans-jumptable
(list
(cons "^" end-of-transaction)
(cons "D" transdate)
(cons "T" transamt)
(cons "N" transid)
(cons "C" transstatus)
(cons "P" transpayee)
(cons "L" transcategory)
(cons "M" transmemo)
(cons "!" transnull)
(cons "U" transnull)
(cons "S" transsplitcategory)
(cons "A" transaddress)
(cons "$" transsplitamt)
(cons "%" transsplitpercent)
(cons "E" transsplitmemo)))

75
src/scm/split-qif.scm Normal file
View File

@ -0,0 +1,75 @@
;;;;;;;;;;; QIF Split Management ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Variables used to handle splits ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define splits? #f)
(define splitlist '())
(define splitcategory #f)
(define splitamount #f)
(define splitmemo #f)
(define splitpercent #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; And functions to nuke out the splits ;;;;
;;;; at the start/end of each transaction ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (resetsplits) ;;; Do this at end of whole txn
(set! splits? #f)
(set! splitlist '())
(resetsplit))
(define (resetsplit) ;;; After each split item
(set! splitcategory #f)
(set! splitmemo #f)
(set! splitpercent #f))
;;;; This function *should* validate that a split adds up to
;;;; the same value as the transaction, and gripe if it's not.
;;;; I'm not sure how to usefully gripe, so I leave this as a stub.
(define (ensure-split-adds-up)
(let*
((txnamount (cdr (assoc 'amount atrans)))
(find-amount (lambda (txnlist) (cdr (assoc 'amount txnlist))))
(total-of-split
(apply + (map find-amount splitlist))))
(if
(< (abs (- txnamount total-of-split)) 0.01) ; Difference tiny
#t
(begin
(display
(string-append "Error - Transaction amount, "
(number->string txnamount)
" not equal to sum of split amount, "
(number->string total-of-split)))
#f))))
(define (transsplitamt line)
(set! splits? #T)
(let*
((linelen (string-length line))
(amount (numerizeamount (substring line 1 linelen)))
(amtlist (cons 'amount amount))
(catlist (cons 'category splitcategory))
(entry (list amtlist catlist)))
;;; And now, add amount and memo to splitlist
(set! splitlist
(cons entry splitlist))))
;;;; percentages only occur as parts of memorized transactions
(define (transsplitpercent line)
(set! splits? #T)
#f) ;;;; Do nothing; percentages only occur in memorized transactions
(define (transsplitmemo line)
(set! splits? #T)
(let*
((linelen (string-length line))
(memo (substring line 1 linelen)))
(set! splitmemo memo)))
(define (transsplitcategory line)
(set! splits? #T)
(let*
((linelen (string-length line))
(category (substring line 1 linelen)))
(keep-category-for-summary category)
(set! splitcategory category)))

91
src/scm/sstring-qif.scm Normal file
View File

@ -0,0 +1,91 @@
; IMPLEMENTS Substring search
; AUTHOR Ken Dickey
; DATE 1991 August 6
; LAST UPDATED
; NOTES
;Based on "A Very Fast Substring Search Algorithm", Daniel M. Sunday,
;CACM v33, #8, August 1990.
;;
;; SUBSTRING-SEARCH-MAKER takes a string (the "pattern") and returns a function
;; which takes a string (the "target") and either returns #f or the index in
;; the target in which the pattern first occurs as a substring.
;;
;; E.g.: ((substring-search-maker "test") "This is a test string") -> 10
;; ((substring-search-maker "test") "This is a text string") -> #f
(define (substring-search-maker pattern-string)
(define num-chars-in-charset 256) ;; update this, e.g. for iso latin 1
(define (build-shift-vector pattern-string)
(let* ((pat-len (string-length pattern-string))
(shift-vec (make-vector num-chars-in-charset
(+ pat-len 1)))
(max-pat-index (- pat-len 1)))
(let loop ((index 0))
(vector-set! shift-vec
(char->integer
(string-ref pattern-string index))
(- pat-len index))
(if (< index max-pat-index)
(loop (+ index 1))
shift-vec))))
(let ((shift-vec (build-shift-vector pattern-string))
(pat-len (string-length pattern-string)))
(lambda (target-string)
(let* ((tar-len (string-length target-string))
(max-tar-index (- tar-len 1))
(max-pat-index (- pat-len 1)))
(let outer ( (start-index 0))
(if (> (+ pat-len start-index) tar-len)
#f
(let inner ( (p-ind 0) (t-ind start-index) )
(cond
((> p-ind max-pat-index) ; nothing left to check
#f) ; fail
((char=? (string-ref pattern-string p-ind)
(string-ref target-string t-ind))
(if (= p-ind max-pat-index)
start-index ;; success -- return start index of match
(inner (+ p-ind 1) (+ t-ind 1)) ; keep checking
))
((> (+ pat-len start-index) max-tar-index) #f) ; fail
(else
(outer (+ start-index
(vector-ref
shift-vec
(char->integer
(string-ref target-string
(+ start-index pat-len)))))))))))))))
;;; Functions to split up strings
;;; Provides the generic facility to split based on *any* character
;;; We make use of splitting on spaces and on colons...
;;; Find the next occurance of [somechar] in the string [string]
;;; starting at [startpos]
(define (split-on-somechar sourcestring somechar)
(define (next-somechar string startpos endpos somechar)
(let loop
; initialize
((pos startpos))
(cond
((>= pos endpos) endpos) ; Reached end of string
((char=? (string-ref string pos) somechar) pos) ; Reached "somechar"
(else
(loop (+ pos 1))))))
(let loop
((pos 0)
(endpos (string-length sourcestring))
(result '()))
(cond
((>= pos endpos) result)
(else
(let ((nextwhatever
(next-somechar sourcestring pos endpos somechar)))
(loop
(+ nextwhatever 1)
endpos
(append result
(list
(substring sourcestring pos nextwhatever)))))))))