From 3a4e3bb6ca029bc8ec070ebd425c346139b9d273 Mon Sep 17 00:00:00 2001 From: Linas Vepstas Date: Wed, 4 Aug 1999 05:08:16 +0000 Subject: [PATCH] QIF import code from cbbrowne@godel.brownes.org git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1882 57a11ea4-9604-0410-9ed3-97b8803252fd --- src/scm/dates-qif.scm | 188 +++++++++++++++++++++++ src/scm/guess-category-qif.scm | 173 +++++++++++++++++++++ src/scm/importqif.scm | 46 ++++++ src/scm/parseqif.scm | 268 +++++++++++++++++++++++++++++++++ src/scm/split-qif.scm | 75 +++++++++ src/scm/sstring-qif.scm | 91 +++++++++++ 6 files changed, 841 insertions(+) create mode 100644 src/scm/dates-qif.scm create mode 100644 src/scm/guess-category-qif.scm create mode 100644 src/scm/importqif.scm create mode 100644 src/scm/parseqif.scm create mode 100644 src/scm/split-qif.scm create mode 100644 src/scm/sstring-qif.scm diff --git a/src/scm/dates-qif.scm b/src/scm/dates-qif.scm new file mode 100644 index 0000000000..f21b648c97 --- /dev/null +++ b/src/scm/dates-qif.scm @@ -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)))) diff --git a/src/scm/guess-category-qif.scm b/src/scm/guess-category-qif.scm new file mode 100644 index 0000000000..8ab226e492 --- /dev/null +++ b/src/scm/guess-category-qif.scm @@ -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 + diff --git a/src/scm/importqif.scm b/src/scm/importqif.scm new file mode 100644 index 0000000000..e5c5c127d9 --- /dev/null +++ b/src/scm/importqif.scm @@ -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" diff --git a/src/scm/parseqif.scm b/src/scm/parseqif.scm new file mode 100644 index 0000000000..855ae69ac3 --- /dev/null +++ b/src/scm/parseqif.scm @@ -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))) diff --git a/src/scm/split-qif.scm b/src/scm/split-qif.scm new file mode 100644 index 0000000000..977b3d2296 --- /dev/null +++ b/src/scm/split-qif.scm @@ -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))) diff --git a/src/scm/sstring-qif.scm b/src/scm/sstring-qif.scm new file mode 100644 index 0000000000..6aa900b081 --- /dev/null +++ b/src/scm/sstring-qif.scm @@ -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)))))))))