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

patches from Dave Peticolas <peticola@morpheus.cs.ucdavis.edu>

Browse Source 
Date: Sun, 17 Oct 1999 18:01:53 -0700

Includes new files from Christopher Browne <cbbrowne@hex.net>
Date: Sun, 17 Oct 1999 18:42:39 -0500

It doesn't yet quite completely work, but this moves several steps ahead:
a) Currency handling for both US "1,234,567.89" and European "1.234.567.89"
formats, as per a recent bug report, with "regression tests" for this;
b) Much added documentation to gnc.gwp
c) Several new files attached that all go into GNUCASHROOT/src/scm


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1940 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Linas Vepstas
1999-10-18 03:18:20 +00:00
parent 1b257312ea
commit abc39f0557
18 changed files with 1061 additions and 579 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/scm/bs-interp.scm Normal file
View File

@@ -0,0 +1,9 @@
;;;; startup-interpreter.scm -*-scheme-*-
;; Load the necessary files for use in interpreter mode.
(primitive-load "bootstrap.scm")
(gnc:load "startup.scm")
(gnc:load "main.scm")
(gnc:startup)

38
src/scm/convenience-wrappers.scm
View File

@@ -1,38 +0,0 @@
(define (gnc:query-dialog message default-answer
yes-button? ok-button? no-button? cancel-button?)
;; Show yes/no/cancel dialog box with given message.
;;
;; display message, and wait for a yes, no, or cancel, depending on
;; the arguments. Each of the *-button? arguments indicates whether
;; or not the dialog should contain a button of that type.
;; default-answer may be set to 'yes, 'ok, 'no or 'cancel. If you
;; allow both yes and OK buttons, and set 'yes or 'ok as the default
;; answer, which button is the default is undefined, but the result
;; is the same either way, and why would be doing that anyhow?
;;
;; This function returns 'yes for yes (or OK), 'no for no, or 'cancel.
;; If there was an unrecoverable error, this function returns #f.
;;
;; NOTE: This function does not return until the dialog is closed.")
(let* ((default (case default-answer
((yes) 1)
((ok) 1)
((no) 2)
((cancel) 3)))
(result
(gnc:_query-dialog-lowlev_
message default yes-button? ok-button? no-button? cancel-button?)))
(cond
((< result 0) #f)
(else
(case result
((1) 'yes)
((2) 'no)
((3) 'cancel))))))
(define (gnc:message-dialog message)
(let ((result (gnc:query-dialog message 'ok #f #t #f #f)))
#t))

183
src/scm/dates-qif.scm
View File

@@ -1,6 +1,6 @@
;; $Id$
;;;;;;; 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"
@@ -16,6 +16,28 @@
(substring string (+ 1 spacepos) slen)))
string)))
(if testing?
(begin
(display "Check replacespace0:")
(let* ((v1 "4/ 7/99")
(v1res (replacespace0 v1))
(v1exp "4/07/99")
(v2 " 1234 ")
(v2res (replacespace0 v2))
(v2exp "00012340"))
(display (string-append "Rewrite:" v1 " Expect:" v1exp " Got:" v1res))
(newline)
(if (string=? v1res v1exp)
'ok
(begin
(display "ERROR - Unexpected results!!!")(newline)))
(display (string-append "Rewrite:" v2 " Expect:" v2exp " Got:" v2res))
(newline)
(if (string=? v2res v2exp)
'ok
(begin
(display "ERROR - Unexpected results!!!")(newline))))))
;;;; 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)
@@ -88,7 +110,7 @@
(begin
(if (or (eq? vl vm) (eq? vl vh) (eq? vm vh))
(begin
(display "Problem: Range occurs twice!") ; Problem! A range appears twice!
(display "Problem: Range occurs twice!")
(newline)
(display "Low Values:(Low Medium High)")
(display (list min-date-low min-date-med min-date-high)) (newline)
@@ -97,16 +119,16 @@
(display
(string-append
"(VL VM VH) ("
(number->string v1)
(symbol->string vl)
" "
(number->string v2)
" " (number->string v3) ")" ))
(symbol->string vm)
" " (symbol->string vh) ")" ))
(newline)
(display "Assuming common default of MM/DD/YY")
(newline)
(set! date-low 'mm)
(set! date-med 'dd)
(set! date-high yy)
(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)
@@ -116,11 +138,6 @@
(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)
@@ -132,9 +149,75 @@
(cons (rewrite-dates (car txn))
(rewrite-dates (cdr txn))))))
(define (date-window 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))))
;;; does string contain #\- or #\/ or #\.???
(define date-delimiters-list '(#\- #\/ #\.))
(define (which-delimiter str charlist)
(let ((len (string-length str))) ;;; Compute length once
(let loop ((pos 0))
(let ((cchar (string-ref str pos)))
(if (member cchar charlist)
cchar
(if (< pos len)
(loop (+ pos 1))))))))
(testing "which-delimiter"
"99/01/03"
#\/
(which-delimiter "99/01/03" date-delimiters-list))
(testing "which-delimiter"
"99/01/03"
#\/
(which-delimiter "99/01/03" date-delimiters-list))
(testing "which-delimiter"
"99.02.03"
#\.
(which-delimiter "99.02.03" date-delimiters-list))
(testing "which-delimiter"
"12345-"
#\-
(which-delimiter "12345-" date-delimiters-list))
(define (reformat-date date-as-string)
(let*
((datesplitup (split-on-somechar date-as-string #\/))
((delimiter (which-delimiter date-as-string date-delimiters-list))
(datesplitup (split-on-somechar date-as-string delimiter))
(p1 (string->number (car datesplitup)))
(p2 (string->number (cadr datesplitup)))
(p3 (string->number (caddr datesplitup)))
@@ -153,36 +236,48 @@
(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
(list (date-window YEAR) MONTH DAY))))
(if testing?
(begin
(let
((ambdatelist ; ambiguous; date-versus-month
'(("00" "01" "02") ; is not clear, as both are < 12
("97" "02" "03")
("99" "04" "07"))))
(resetdates)
(for-each newdatemaxes ambdatelist)
(display "Testing date conversion based on ambiguous date list:") (newline)
(display "(ambdatelist ") (display ambdatelist) (display ")") (newline)
(checkdatemaxes)
(display "Results: ")
(display (list date-low date-med date-high)) (newline))
(let
((ambdatelist ; also ambiguous
'(("13" "02" "02")
("02" "03" "03")
("03" "04" "07"))))
(resetdates)
(for-each newdatemaxes ambdatelist)
(display "Testing date conversion based on ambiguous date list:") (newline)
(display "(ambdatelist ") (display ambdatelist) (display ")") (newline)
(checkdatemaxes)
(display "Results: ")
(display (list date-low date-med date-high)) (newline))
(let
((datelist ; not ambiguous
'(("13" "00" "02")
("02" "03" "03")
("03" "04" "07"))))
(resetdates)
(for-each newdatemaxes datelist)
(display "Testing date conversion based on ambiguous date list:") (newline)
(display "(datelist ") (display datelist) (display ")") (newline)
(checkdatemaxes)
(display "Results: ")
(display (list date-low date-med date-high)) (newline))))
;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))))

40
src/scm/extensions.scm
View File

@@ -7,6 +7,12 @@
(gnc:debug "Setting up extensions menu " win "\n")
(gnc:extensions-menu-add-item
"Test Account creation"
"Creates three accounts and adds them to the top group"
(lambda ()
(gnc:test-creation)))
(gnc:extensions-menu-add-item "Export data as text"
"Export data as text hint"
(lambda ()
@@ -15,7 +21,7 @@
(gnc:extensions-menu-add-item "Test error dialog"
"Test error dialog hint"
(lambda ()
(gnc:error-message-dialog
(gnc:error-dialog
"Some error didn't occur.")))
(gnc:extensions-menu-add-item "QIF Import"
@@ -45,40 +51,30 @@
(cond
((eq? result #f)
(gnc:error-message-dialog
(gnc:error-dialog
"Fatal error in choose item from list dialog."))
((eq? result 'cancel)
(gnc:error-message-dialog "Choose item from list dialog canceled."))
(gnc:error-dialog "Choose item from list dialog canceled."))
(else
(gnc:error-message-dialog
(gnc:error-dialog
(call-with-output-string (lambda (string-port)
(display "Choose item result: " string-port)
(display "Choose item result: "
string-port)
(write result string-port)))))))))
(gnc:extensions-menu-add-item
"Test verify dialog"
"Test verify dialog hint"
(lambda ()
(let ((result (gnc:verify-dialog "Would you like to play a game?")))
(let ((result (gnc:verify-dialog "Would you like to play a game?" #t)))
(if result
(gnc:error-message-dialog "You said yes.")
(gnc:error-message-dialog "You said no.")))))
(gnc:info-dialog "You said yes.")
(gnc:info-dialog "You said no.")))))
(gnc:extensions-menu-add-item
"Test query dialog"
"Test query dialog hint"
(lambda ()
(let ((result (gnc:query-dialog
"Would you like to play a game?"
'yes
#t #f #t #t)))
(case result
((yes) (gnc:message-dialog "You said yes."))
((no) (gnc:message-dialog "You said no."))
((cancel) (gnc:message-dialog "You said cancel."))
(else
(gnc:message-dialog "Something awful happened."))))))
"Test info dialog"
"Test info dialog hint"
(lambda () (gnc:info-dialog "This is information.")))
(gnc:extensions-menu-add-item "Simple extension test"
"Simple extension test hint"

192
src/scm/gc-import-qifs.scm Normal file
View File

@@ -0,0 +1,192 @@
;;; $Id$
(display "Started gc-impor.scm")
(newline)
(define (gnc:get-account-list account-group)
(if testing?
gc-accts
(let ((fullacclist
(flatten
(gnc:group-map-accounts get-names-of-accounts
account-group))))
(display "acclist:")
(display fullacclist)
(newline)
(filteroutnulls fullacclist))))
(define gnc:account-types (initialize-lookup))
(define (account-type->number symbol)
(let
((s (lookup symbol gnc:account-types)))
(if s
(cdr s)
#f)))
(display (account-type->number 'INCOME)) (newline)
(define (gnc:get-incomes-list account-group)
(if testing?
gc-cats
(filteroutnulls
(flatten
(gnc:group-map-accounts
get-names-of-incomes
account-group)))))
(define gnc-asset-account-types
'(0 1 2 3 4 7))
; (map account-type->number
; '(CASH CREDIT ASSET LIABILITY CURRENCY)))
(if testing?
(begin
(display "gnc-asset-account-types:")
(display gnc-asset-account-types)
(newline)))
;;; '(1 2 3 4 7))
;;;;;;;;;;;;;;;;;;;;;;; add, eventually, 11 12 13 14))
;;; aka CHECKING SAVINGS MONEYMRKT CREDITLINE))
;(define gnc-income-account-types '(8 9))
(define gnc-income-account-types
(map account-type->number '(INCOME EXPENSE)))
(if testing?
(begin
(display "gnc-income-account-types:")
(display gnc-income-account-types)
(newline)))
(define gnc-invest-account-types '(5 6 10))
(define gnc-invest-account-types
(map account-type->number '(EQUITY STOCK MUTUAL)))
(if testing?
(begin
(display "gnc-invest-account-types:")
(display gnc-invest-account-types)
(newline)))
(define (get-names-of-accounts a)
(list
(if (member (gnc:account-get-type a) gnc-asset-account-types)
(gnc:account-get-name a)
#f))
(gnc:group-map-accounts get-names-of-accounts
(gnc:account-get-children a)))
(define (get-names-of-incomes a)
(list
(if (member (gnc:account-get-type a) gnc-income-account-types)
(gnc:account-get-name a)
#f))
(gnc:group-map-accounts get-names-of-incomes
(gnc:account-get-children a)))
(define (get-names-of-expenses a)
(list
(if (member (gnc:account-get-type a) gnc-expense-account-types)
(gnc:account-get-name a)
#f))
(gnc:group-map-accounts get-names-of-expenses
(gnc:account-get-children a)))
(define (gnc:import-file-into-account-group account-group)
;(sample-dialog)
(let ((file-name
(gnc:file-selection-dialog "Select file for QIF import" "*.qif")))
(if file-name
(begin
(gnc:debug "Loading data from file " file-name)
(let* ((txn-list (read-qif-file file-name account-group))
(category-analysis (analyze-qif-transaction-categories txn-list)))
;;; Now, take steps:
(qif-to-gnucash txn-list file-name)
(list txn-list category-analysis))))))
;;; Set up QIF Category
(define (get-all-types)
(set! gnc:account-types (initialize-lookup))
(let loop
((i 0))
(let ((typesymbol (gnc:account-type->symbol i)))
(set! gnc:account-types
(lookup-set! gnc:account-types typesymbol i))
(if (< i 14)
(loop (+ i 1))))))
(define (gnc:create-account AccPtr name description notes type)
(gnc:init-account AccPtr)
(gnc:account-begin-edit AccPtr 0)
(gnc:account-set-name AccPtr name)
(gnc:account-set-description AccPtr description)
(gnc:account-set-notes AccPtr notes)
(gnc:account-set-type AccPtr type)
(gnc:account-commit-edit AccPtr))
;;;;;;;;;;; This one's REAL IMPORTANT!!! ;;;;;;;;;;;;
(display (account-type->number 'CASH))
(display (account-type->number 'INCOME))
(define (gnc:create-transaction Account txnlist)
(define (associt type)
(let
((result (lookup type txnlist)))
(if result
(cdr result)
#f)))
(let
((Txn (gnc:transaction-create))
(Category (associt 'category))
(Payee (associt 'payee))
(Id (associt 'id))
(Date (associt 'date))
(Status (associt 'status))
(Amount (associt 'amount))
(Memo (associt 'memo))
(Splits (associt 'splits)))
(gnc:trans-begin-edit Txn 1)
(let ((source-split (gnc:transaction-get-split Txn 0))
(build-split-entry
(lambda (splitentry)
(define (assocsplit type)
(let
((result (assoc type splitentry)))
(if result
(cdr result)
#f)))
(let
((Split (gnc:split-create))
(Category (assocsplit 'category))
(Amount (assocsplit 'amount))
(Memo (assocsplit 'memo)))
(if Category
(gnc:account-insert-split
(gnc:xaccGetXferQIFAccount Account Category)
Split))
(if Amount
(gnc:split-set-value Split (- Amount)))
(if Memo
(gnc:split-set-memo Split Memo))))))
(if Category
(gnc:account-insert-split
(gnc:xaccGetXFerQIFAccount Account Category)
source-split))
(if Payee
(gnc:transaction-set-description Txn Payee))
(if Id
(gnc:transaction-set-xnum Txn Id))
(if Status
(gnc:split-set-reconcile source-split (string-ref Status 0)))
(if Date
(gnc:trans-set-datesecs
Txn
(gnc:gnc_dmy2timespec (caddr Date) (cadr Date) (car Date))))
(if Amount
(gnc:split-set-value source-split Amount))
(if Memo
(gnc:transaction-set-memo Txn Memo))
(if Splits
;;;; Do something with split
(for-each build-split-entry Splits)))
(gnc:trans-commit-edit Txn)))

148
src/scm/guess-category-qif.scm
View File

@@ -1,4 +1,4 @@
(define (guess-cat inputcat gnucash-cats gnucash-accs)
;;; $Id$
;;; 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
@@ -6,94 +6,68 @@
;;; 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.
;;; 6. I'd like a "similarity match" of some sort
;;; 7. Is it in old-matches? If so, toss that to front of list.
;;; Lastly, shorten the list to no more than 4 items.
(define (guess-gnucash-category
inputcat gc-income-categories gc-account-categories)
(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
((picklist (initialize-lookup))
(qifname (inputcat 'get 'name))
(catlength (string-length (qifname)))
(is-acct? (and
(>= catlength 2)
(string=? (substring inputcat 0 1) "[")
(string=? (substring inputcat (- catlength 1) catlength) "]")))
(acctlist ; Pick either gnucash-cats/gnucash-accs
(string=? (substring inputcat
(- catlength 1) catlength) "]")))
(netdebit? (< (inputcat 'get 'value)))
(acctlist ; Pick either gc-income-categories/gc-account-categories
(if
is-acct?
gnucash-accs
gnucash-cats))
gc-account-categories
gc-income-categories))
(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))))))
(set! picklist (lookup-set! picklist string value))))
(match-against-list
(lambda (itemstring)
(if (string=? itemstring incat) ;;; Exact match
(add-to-picklist itemstring 1))
(if (or ((substring-search-maker incat) itemstring) ;;; Inclusion
(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 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))) )
(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)))
(shorten-to-best 4 picklist)))
(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-categories
gc-income-categories gc-account-categories)
(define apply-guess-category
(lambda (incat)
(list incat
(guess-gnucash-category (car incat)
gc-income-categories
gc-account-categories))))
(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))
(map apply-guess-category import-categories))
;;; Make use of "old-matches," which is an association list
;;; containing the correspondences that have been used previously.
@@ -121,53 +95,9 @@
;;;;; (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
(define (guess-results account-group kept-categories)
(guess-corresponding-categories
kept-categories
(gnc:get-incomes-list account-group)
(gnc:get-account-list account-group)))

7
src/scm/hooks.scm
View File

@@ -61,7 +61,12 @@
(define gnc:*shutdown-hook*
(gnc:hook-define
'shutdown-hook
"Functions to run at shutdown. Hook args: ()"))
"Functions to run at guile shutdown. Hook args: ()"))
(define gnc:*ui-shutdown-hook*
(gnc:hook-define
'ui-shutdown-hook
"Functions to run at ui shutdown. Hook args: ()"))
(define gnc:*main-window-opened-hook*
(gnc:hook-define

69
src/scm/importqif.scm
View File

@@ -1,11 +1,40 @@
;;; 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")
;;; $Id$
;;; Import QIF File
(define testing? #f) ;;; Should we do testing?
(define favorite-currency "USD") ;;;; This may need to change...
(define (gnc:extensions-qif-import win)
(let ((account-group #f)
(session (gnc:main-window-get-session)))
(if session (set! account-group (gnc:session-get-group session)))
(if (not account-group)
(gnc:error-message-dialog
"No account group available for text export.")
(begin
(display "account-group:") (display account-group) (newline)
(gnc:load "testbed.scm")
(gnc:load "sstring-qif.scm")
(gnc:load "qifutils.scm")
(gnc:load "structure.scm")
(gnc:load "dates-qif.scm")
(gnc:load "split-qif.scm")
(gnc:load "qifcats.scm")
(gnc:load "parseqif.scm")
(gnc:load "qifstate.scm")
(gnc:load "qifstat.scm")
(gnc:load "qif2gc.scm")
(gnc:load "guess-category-qif.scm")
(gnc:load "analytical-qifs.scm")
(gnc:load "test.scm")
(gnc:load "gc-import-qifs.scm")
(begin
(get-all-types)
(display "Account type list:")
(display gnc:account-types)
(newline))
(test-load account-group) ;;;;; This tries to create some accounts
(gnc:import-file-into-account-group account-group)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; Now, let's actually execute the code...
@@ -21,26 +50,4 @@
;;;;; 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"

27
src/scm/main.scm
View File

@@ -6,11 +6,11 @@
;; Now we can load a bunch of files.
(gnc:load "hooks.scm")
(gnc:load "doc.scm")
(gnc:load "extensions.scm") ; Should this be here or somewhere else?
(gnc:load "text-export.scm")
(gnc:load "importqif.scm")
(gnc:load "test.scm")
;; Load the system and user configs
(if (not (gnc:load-system-config-if-needed))
@@ -30,9 +30,22 @@
(define (gnc:shutdown exit-status)
(gnc:debug "Shutdown -- exit-status: " exit-status)
(gnc:hook-run-danglers gnc:*shutdown-hook*)
(gnc:_shutdown_ exit-status)
(exit exit-status))
(cond ((gnc:ui-is-running?)
(if (not (gnc:ui-is-terminating?))
(begin
(gnc:hook-run-danglers gnc:*ui-shutdown-hook*)
(gnc:ui-shutdown))))
(else
(gnc:hook-run-danglers gnc:*shutdown-hook*)
(gnc:ui-destroy)
(exit exit-status))))
(define (gnc:ui-finish)
(gnc:debug "UI Shutdown hook.")
(gnc:file-query-save)
(gnc:file-quit))
(define (gnc:main)
@@ -47,6 +60,10 @@
;; You can only open single files right now...
(gnc:ui-open-file (car gnc:*command-line-files*)))
(gnc:lowlev-app-main)
(gnc:hook-add-dangler gnc:*ui-shutdown-hook* gnc:ui-finish)
(gnc:ui-main)
(gnc:hook-remove-dangler gnc:*ui-shutdown-hook* gnc:ui-finish)
(gnc:shutdown 0))

366
src/scm/parseqif.scm
View File

@@ -1,126 +1,104 @@
;;; $Id$
;;;;;;;;;;; QIF Parsing ;;;;;;;;;;;;;;
(define tlist '())
(define atrans '())
(define qif-txn-list '())
(define qif-txn-structure
(define-mystruct '(memo date id payee addresslist amount status category splitlist)))
(define thetxn
(build-mystruct-instance qif-txn-structure))
(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)
(define (read-qif-file file account-group)
(set! qif-txn-list '()) ; Reset the transaction list...
(set! thetxn (build-mystruct-instance qif-txn-structure))
(resetdates) ; Reset the date checker
(let*
((statepair (assoc (striptrailingwhitespace line) QIFstates)))
(begin
((infile (open-input-file file)))
(let loop
((line (read-line infile)))
(if
(pair? statepair)
(set! qifstate (car (cddr statepair)))
#f))))
(eof-object? line) #f
(let
((newline (read-qiffile-line line)))
(loop (read-line infile)))))
(if
(checkdatemaxes)
#f ;;; Do nothing; all is ok
(begin
(display "Problem with dating - ambiguous data!")
(newline)))
;;; Now, return results:
qif-txn-list))
(define (process-qif-file file account-group)
; Opens file, rewrites all the lines, closes files
(display (string-append "rewriting file:" file)) (newline)
(let*
((qif-txn-list (read-qif-file file account-group))
(category-analysis (analyze-qif-transaction-categories qif-txn-list))
(outfile (open-output-file (string-append file ".XAC") 'replace))
; (outfile (open-output-file (string-append file ".XAC")))
(write-to-output-thunk
(lambda (txn)
(write (cdr (txn 'geteverything 'nil)) outfile)
(newline outfile))))
(display (string-append ";;;; Data from " file) outfile)
(newline outfile)
(newline outfile)
(display ";;; Transactional data:" outfile)
(newline outfile)
(display "(define transactions '(" outfile)
(newline outfile)
(for-each write-to-output-thunk qif-txn-list)
(display (string-append
"Total transactions: "
(number->string (length qif-txn-list))))
(newline)
(display ")) ;;; End of transaction data" outfile)
(newline outfile)
(newline outfile)
(display "(define acclist")
(display (gnc:get-account-list account-group))
(display ")")
(newline)
(display "(define acclist")
(display (gnc:get-incomes-list account-group))
(display ")")
(newline)
(display "(define category-analysis '" outfile)
(for-each (lambda (x) (display "(" outfile)
(write (car x) outfile)
(display " " outfile)
(write ((cdr x) 'list 'all) outfile)
(display ")" outfile)
(newline outfile)) category-analysis)
(display ")" outfile)
(display "(define category-analysis '")
(for-each (lambda (x)
(display "(")
(write (car x))
(display " ")
(write ((cdr x) 'list 'all))
(display ")")
(newline)) category-analysis)
(display ")")
(newline outfile)
(close-output-port outfile)))
(define (read-qiffile-line line)
(display (string-append "Line:" line)) (newline)
(if
(char=? (string-ref line 0) #\!) ;;; Starts with a !
(newqifstate line)) ;;; Jump to a new state...
(cond
((eq? qifstate 'txn) ;;; If it's a transaction
(rewrite-txn-line (striptrailingwhitespace line)))
(else
(display "Ignoring non-transaction:") (display qifstate)(newline))))
(define (transnull line)
#f) ; do nothing with line
@@ -132,7 +110,7 @@
(define (rewrite-txn-line line)
(let*
((fchar (substring line 0 1))
(found (assoc fchar trans-jumptable)))
(found (lookup fchar trans-jumptable)))
(if
found
(let
@@ -140,129 +118,91 @@
(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,
;;;; Insert queued material into "thetxn" (such as splits, address)
;;;; Add "thetxn" 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)))
(thetxn 'put 'addresslist addresslist))
(if splits?
(begin
(set! atrans (cons (cons 'splits splitlist) atrans))
(ensure-split-adds-up)))
(set! tlist (cons atrans tlist))
(thetxn 'put 'splitslist splitlist)
(ensure-split-adds-up)
(resetsplits)))
(set! qif-txn-list (cons thetxn qif-txn-list))
(set! addresslist '())
(resetsplits)
(set! atrans '()))
(set! thetxn (build-mystruct-instance qif-txn-structure)))
;;;;;;;;;;; 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))))
(thetxn 'put 'memo (strip-qif-header line)))
(define (transaddress line)
(let*
((linelen (string-length line))
(addline (substring line 1 linelen)))
(set! addresslist (cons addline addresslist))))
(set! addresslist (cons (strip-qif-header line) addresslist)))
(define (transdate line)
(let*
((linelen (string-length line))
(date (replacespace0 (substring line 1 linelen)))
((date (replacespace0 (strip-qif-header line)))
(dpieces (split-on-somechar date #\/)))
(set! atrans (cons (cons 'date date) atrans))
(thetxn 'put 'date date)
(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 (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.
(thetxn 'put 'amount (numerizeamount (strip-qif-header line))))
(define (transid line)
(let*
((linelen (string-length line))
(id (substring line 1 linelen)))
(set! atrans (cons (cons 'id id) atrans))))
(thetxn 'put 'id (strip-qif-header line)))
(define (transstatus line)
(let*
((linelen (string-length line))
(status (substring line 1 linelen)))
(set! atrans (cons (cons 'status status) atrans))))
(thetxn 'put 'status (strip-qif-header line)))
(define (transpayee line)
(let*
((linelen (string-length line))
(payee (substring line 1 linelen)))
(set! atrans (cons (cons 'payee payee) atrans))))
(thetxn 'put 'payee (strip-qif-header line)))
(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))))
(thetxn 'put 'category (strip-qif-header line)))
(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)))
(define trans-jumptable (initialize-lookup))
(let*
((ltable
'(("^" end-of-transaction)
("D" transdate)
("T" transamt)
("N" transid)
("C" transstatus)
("P" transpayee)
("L" transcategory)
("M" transmemo)
("!" transnull)
("U" transnull)
("S" transsplitcategory)
("A" transaddress)
("$" transsplitamt)
("%" transsplitpercent)
("E" transsplitmemo)))
(setter
(lambda (lst)
(let ((command (car lst))
(function (eval (cadr lst))))
(set! trans-jumptable
(lookup-set! trans-jumptable command function))))))
(for-each setter ltable))
(display "trans-jumptable")
(display trans-jumptable)
(newline)

184
src/scm/qif2gc.scm Normal file
View File

@@ -0,0 +1,184 @@
;;; $Id$
;;;; Take the set of stuff from a QIF file, and turn it into the
;;;; structures expected by GnuCash.
;;; In each of these, "gncpointer" should be populated with the
;;; address of the object. This way the object can be maintained
;;; on both sides of the Lisp<==>C boundary
;;; For instance:
; (define (initialize-split) ;;; Returns a gnc-split-structure
; (let ((ptr (gnc:split-create))
; (splitstruct (build-mystruct-instance gnc-split-structure)))
; (splitstruct 'put 'gncpointer ptr)
; splitstruct))
(define gnc-account-structure
(define-mystruct '(id name flags type code description
notes currency security splitlist
parentaccountgroup
childrenaccountgroup)))
(define gnc-account-group-structure
(define-mystruct '(parentaccount peercount
peerlist)))
(define gnc-txn-structure
(define-mystruct '(num date-posted date-entered description
docref splitlist)))
(define gnc-split-structure
(define-mystruct '(memo action reconcile-state
reconciled-date docref share-amount
share-price account parenttransaction)))
(define gnc-txn-list (initialize-lookup))
(define gnc-acc-list (initialize-lookup))
(define gnc-split-list (initialize-lookup))
(define (add-qif-transaction-to-gnc-lists txn curtxn cursplitlist)
(define txnref (gensym))
(set! gnc-txn-list (lookup-set! gnc-txn-list txnref curtxn))
;;; Fill in gnc-txn-list, gnc-acc-list, gnc-split-list
;;; First, let's fill in curtxn with some values from txn
(curtxn 'put 'num (txn 'get 'id))
(curtxn 'put 'date-posted (txn 'get 'date))
(curtxn 'put 'date-entered '(1999 0903)) ;;; Which should get replaced!
(curtxn 'put 'description (txn 'get 'memo))
(curtxn 'put 'docref (txn 'get 'id))
;;; Now, set up the list of splits...
(let ((mainref (gensym))
(mainsplit (build-mystruct-instance gnc-split-structure)))
(mainsplit 'put 'memo (txn 'get 'memo))
(mainsplit 'put 'share-amount (txn 'get 'amount))
(mainsplit 'put 'reconcile-state (txn 'get 'status))
(mainsplit 'put 'reconcile-state
(if (string=? (txn 'get 'status) "*")
'(1999 09 03) #f))
(mainsplit 'put 'docref (txn 'get 'id))
(mainsplit 'put 'parenttransaction txnref)
(mainsplit 'put 'account accountname)
(set! gnc-split-list (lookup-set! gnc-split-list mainref mainsplit)))
;;;; Chunk of missing code:
;;;; ---> Take a look at the split list in (txn 'get 'splitlist)
;;;; Add a split for each one of these
;;;; Alternatively, add a split for (txn 'get 'category)
;;;; ---> Attach all the accounts to the corresponding splits
(curtxn 'put 'splitlist lookup-keys cursplitlist))
(define (qif-to-gnucash txnlist accountname)
(letrec
((curtxn (build-mystruct-instance gnc-txn-structure))
(cursplitlist (initialize-lookup))
(process-txn (lambda (x) (add-qif-transaction-to-gnc-lists x curtxn cursplitlist))))
(for-each process-txn txnlist)))
; QIF essentially provides a structure that sort of looks like
; (chequing
; (deposit 500 salary)
; (withdraw 300 rent)
; (transfer 200 mastercard))
; Asset account
; --> Bunch of transactions, implicitly associated with it
; --> That are also associated with income/expense accounts
; This must be transformed to something more like:
;;; Account points to vector of splits, each split points to a transaction
; Accounts look like:
; ('chequing
; (500 'chequing 'deposit)
; (-300 'chequing 'withdraw)
; (-200 'chequing 'transfer))
; ('mastercard
; (200 'mastercard 'transfer))
; ('salary
; (-500 'salary 'deposit))
; ('rent
; (-500 'rent 'withdraw))
; Transactions look like:
; ('deposit
; (500 'chequing 'deposit)
; (-500 'salary 'deposit))
; (withdraw
; (-300 'chequing 'withdraw)
; (-500 'rent 'withdraw))
; (transfer
; (200 'mastercard 'transfer)
; (-200 'chequing 'transfer))
; And the splits are the subordinates in both cases...
;;; Thus, the approach should be:
; -- For each QIF transaction QT
; -- Create transaction
; -- Construct the splits for the current transaction
; If there's no QIF split, then there's two:
; - One for the [current account]
; - Offset by the [category]
; Alternatively:
; - One for the [current account]
; - Offset by the set of QIF split items
; - Link splits to transaction
; - Link transaction to split list
; - Link each splits to appropriate account
; - Add each split to the account-to-splits list for the account
(define (initialize-split) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:split-create))
(splitstruct (build-mystruct-instance gnc-split-structure)))
(splitstruct 'put 'gncpointer ptr)
splitstruct))
(define (gnc:set-split-values q-txn q-split)
(let ((g:split (initialize-split))
(g:memo (q-split 'get 'memo))
(g:amount (q-split 'get 'amount))
(g:docref (q-split 'get 'id))
(g:action (q-txn 'get 'status)))
(if g:amount (gnc:split-set-value g:split g:amount))
(if g:memo (gnc:split-set-memo g:split g:memo))
(if g:action (gnc:split-set-action g:split g:action))
(if g:docref (gnc:split-set-docref g:split g:docref))))
(define (gnc:link-split-to-parents g:split g:account g:transaction)
(gnc:transaction-append-split g:transaction g:split)
(gnc:account-insert-split g:account g:split))
(define (initialize-account) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:malloc-account))
(accstruct (build-mystruct-instance gnc-account-structure)))
(accstruct 'put 'gncpointer ptr)
accstruct))
(define (initialize-txn) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:transaction-create))
(txnstruct (build-mystruct-instance gnc-transaction-structure)))
(txnstruct 'put 'gncpointer ptr)
txnstruct))
(if testing?
(begin
(display "need test scripts in qif2gc.scm")))
(define best-guesses (initialize-lookup))
(define (add-best-guess qif gnc)
(set! best-guesses (lookup-set! best-guesses qif gnc)))
(define (find-best-guess qif)
(lookup qif best-guesses))
(define qif-to-gnc-acct-xlation-table (initialize-lookup))
(define (improve-qif-to-gnc-translation qif gnc)
(set! qif-to-gnc-acct-xlation-table
(lookup-set! qif-to-gnc-acct-xlation-table
qif gnc)))diff -u /dev/null 'gnucash/src/scm/qifcats.scm'

58
src/scm/qifcats.scm Normal file
View File

@@ -0,0 +1,58 @@
;;; $Id$
;;;;; Category management
(define qif-cat-list (initialize-lookup))
(define qif-category-structure
(define-mystruct '(name count value)))
(define (analyze-qif-categories)
(define (analyze-qif-category item)
(let*
((id (car item))
(q (cdr item))
(gc (build-mystruct-instance gnc-account-structure))
(positive? (<= 0 (q 'get 'amount)))
(balance-sheet? (char=? (string-ref id 0) #\[))
(propername (if balance-sheet?
(substring 1 (- (string-length id) 1))
id)))
(gc 'put 'type
(if positive?
(if balance-sheet?
'BANK
'CREDIT)
(if balance-sheet?
'INCOME
'EXPENSE)))
(gc 'put 'description id)
(gc 'put 'currency favorite-currency)))
(set! qif-analysis (initialize-lookup))
(for-each analyze-qif-category qif-category-list))
(define (analyze-qif-transaction-categories qif-txn-list)
(define (analyze-qif-txn-category txn)
(collect-cat-stats (txn 'get 'category)
(txn 'get 'amount))
(let ((splits (txn 'get 'splitlist)))
(if splits
(for-each analyze-qif-split-category splits))))
(set! qif-cat-list (initialize-lookup))
(for-each analyze-qif-txn-category qif-txn-list)
qif-cat-list)
(define (analyze-qif-split-category split)
(collect-cat-stats (split 'get 'category) (split 'get 'amount)))
(define (collect-cat-stats category amount)
(let* ((s (lookup category qif-cat-list)))
(if s ;;; Did we find it in qif-cat-list?
(let ((sc (cdr s)))
(sc 'put 'value (+ amount (sc 'get 'value)))
(sc 'put 'count (+ 1 (sc 'get 'count))))
(begin ;;; Nope; need to add new entry to qif-cat-list
(let ((nc (build-mystruct-instance qif-category-structure)))
(nc 'put 'name category)
(nc 'put 'count 1)
(nc 'put 'value amount)
(set! qif-cat-list (lookup-set! qif-cat-list category nc)))))))

39
src/scm/qifstate.scm Normal file
View File

@@ -0,0 +1,39 @@
;;; $Id$
(define qifstate #f)
(define (newqifstate line)
(let*
((QIFstates
'(("!Type:Cat" . category)
("!Option:AutoSwitch" . accounts)
("!Clear:AutoSwitch" . accounts)
("!Account" . accounts)
("!Type:Memorized" . memorized)
("!Type:Bank" . txn)
("!Type:CCard" . txn)
("!Type:Oth A" . txn)))
(name (striptrailingwhitespace line))
(statepair (assoc name QIFstates)))
(if (pair? statepair)
(begin
(display "New qifstate:") (display (cdr statepair))
(newline)
(set! qifstate (cdr statepair))
(cdr statepair))
(begin
(display "No new QIF state") (newline)))))
(testing "newqifstate"
"!Account"
'accounts
(newqifstate "!Account"))
(testing "newqifstate"
"!Type:Cat "
'category
(newqifstate "!Type:Cat"))
(testing "newqifstate"
"nothing"
#f
(newqifstate "nothing"))

55
src/scm/split-qif.scm
View File

@@ -1,13 +1,15 @@
;;; $Id$
;;;;;;;;;;; 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)
(define qif-split-structure
(define-mystruct '(category memo amount percent)))
(define thesplit (build-mystruct-instance qif-split-structure))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; And functions to nuke out the splits ;;;;
;;;; at the start/end of each transaction ;;;;
@@ -15,44 +17,38 @@
(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))
(set! thesplit (build-mystruct-instance qif-split-structure)))
;;;; 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))))
((txnamount (thetxn 'get 'amount))
(find-amount (lambda (splitstructure) (splitstructure 'get 'amount)))
(total-of-split
(apply + (map find-amount splitlist))))
(if
(< (abs (- txnamount total-of-split)) 0.01) ; Difference tiny
#t
(begin
#t ;;; OK - adds up to near enough zero.
(begin ;;; Problem: Doesn't add up
(display
(string-append "Error - Transaction amount, "
(number->string txnamount)
(number->string txnamount)
" not equal to sum of split amount, "
(number->string total-of-split)))
(newline)
(display splitlist)
(newline)
#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))))
(thesplit 'put 'amount (numerizeamount (strip-qif-header line)))
;;; And now, add amount and memo to splitlist
(display (thesplit 'what 'what)) (newline)
(set! splitlist (cons thesplit splitlist))
(set! thesplit (build-mystruct-instance qif-split-structure)))
;;;; percentages only occur as parts of memorized transactions
(define (transsplitpercent line)
@@ -61,15 +57,8 @@
(define (transsplitmemo line)
(set! splits? #T)
(let*
((linelen (string-length line))
(memo (substring line 1 linelen)))
(set! splitmemo memo)))
(thesplit 'put 'memo (strip-qif-header line)))
(define (transsplitcategory line)
(set! splits? #T)
(let*
((linelen (string-length line))
(category (substring line 1 linelen)))
(keep-category-for-summary category)
(set! splitcategory category)))
(thesplit 'put 'category (strip-qif-header line)))

1
src/scm/sstring-qif.scm
View File

@@ -1,3 +1,4 @@
;;; $Id$
; IMPLEMENTS Substring search
; AUTHOR Ken Dickey
; DATE 1991 August 6

1
src/scm/startup.scm
View File

@@ -11,4 +11,5 @@
(gnc:load "prefs.scm")
(gnc:load "command-line.scm")
(gnc:load "convenience-wrappers.scm")
(gnc:load "hooks.scm")
(gnc:load "main.scm")

73
src/scm/structure.scm Normal file
View File

@@ -0,0 +1,73 @@
;;; $Id$
;;; Some functions to help build structures
;;; define-mystruct is used to build an association list that defines
;;; the layout of a structure...
(define (define-mystruct lst)
(define alist '()) ;; Association list
(define count 0) ;; Number of entries
(define (add-item item)
(set! alist (cons (cons item count) alist))
(set! count (+ 1 count)))
(add-item 'gensymid)
(for-each add-item lst)
alist)
;;; Use as follows:
;;; (define qif-split-structure (define-mystruct '(category memo
;;; amount percent)))
;;;
(define (build-mystruct-instance structinfo)
;;; struct-instance is the vector for the data...
(define struct-instance (make-vector (length structinfo) #f))
(define (get-item field-id) ;;; Look up entry based on ID
(let ((assocv (assoc field-id structinfo)))
(if assocv
(vector-ref struct-instance (cdr assocv))
(begin
(display (string-append "No such field as "
(symbol->string field-id)
" in "))
(display structinfo)
(newline)
#f))))
(define (set-item! field-id value) ;;; Plunk in new value
(let ((assocv (assoc field-id structinfo)))
(if assocv
(vector-set! struct-instance (cdr assocv) value)
#f)))
(define (actions action field . value) ;;; now, methods to be applied
(cond
((eq? action 'get)
(let ((item (get-item field)))
(if item
(car item)
#f)))
((eq? action 'put)
(set-item! field value))
(else
(list structinfo struct-instance))))
(set-item! 'gensymid (list (gensym))) ;;; Attach a unique identifier
actions)
(if testing?
(begin
(display "Testing structur.scm - define-mystruct, build-mystruct-instance")
(newline)
(let* ((ms (define-mystruct '(f1 f2 f3)))
(mi (build-mystruct-instance ms)))
(mi 'put 'f1 122)
(mi 'put 'f3 "hello")
(display "Empty list entry:") (display (mi 'get 'f2)) (newline)
(display "and two that aren't (f1 f3):")
(display (list (mi 'get 'f1) (mi 'get 'f3))) (newline)
(display "Whole thang:")
(display (mi 'whole 'thang)) (newline)
(display "Overlay 'f3 with 42, add to 'f1 value")
(mi 'put 'f3 42)
(display (number->string (+ (mi 'get 'f1) (mi 'get 'f3)))) (newline))))

132
src/scm/text-export.scm
View File

@@ -1,6 +1,5 @@
;;; $Id$
(require 'pretty-print)
(define (gnc:group-map-accounts thunk group)
(let loop ((num-accounts (gnc:group-get-num-accounts group))
(i 0))
@@ -26,45 +25,13 @@
; (loop num-splits (+ i 1))))))
(define (gnc:transaction-map-splits thunk transaction)
(let loop ((num-splits (gnc:transaction-get-split-count transaction))
(i 0))
(if (< i num-splits)
(cons
(thunk (gnc:transaction-get-split transaction i))
(loop num-splits (+ i 1)))
'())))
(define (gnc:split->output-form split)
(list
'split
(gnc:split-get-memo split)
(gnc:split-get-action split)
(gnc:split-get-reconcile-state split)
(gnc:split-get-reconciled-date split)
(gnc:split-get-docref split)
(gnc:split-get-share-amount split)
(gnc:split-get-share-price split)
(gnc:split-get-share-price split)
(let ((xfer-account (gnc:split-get-account split))
(xfer-account-id #f))
(if (not (pointer-token-null? xfer-account))
(set! xfer-account-id (gnc:account-get-id xfer-account)))
xfer-account-id)))
(define (gnc:transaction->output-form transaction)
(list
'transaction
(gnc:transaction-get-num transaction)
(gnc:transaction-get-date-posted transaction)
(gnc:transaction-get-date-entered transaction)
(gnc:transaction-get-description transaction)
(gnc:transaction-get-docref transaction)
(gnc:transaction-map-splits gnc:split->output-form transaction)
))
(define (gnc:main-win-export-data-as-text win)
(let ((account-group (gnc:get-current-group)))
(if (not account-group)
(gnc:error-dialog "No account group available for text export.")
(gnc:account-group-export-as-text account-group))))
(define (gnc:account->output-form a)
@@ -89,6 +56,25 @@
gnc:account->output-form
(gnc:account-get-children a)))))
(define (gnc:account-group-export-as-text account-group)
(let ((file-name (gnc:file-selection-dialog
"Select file for text export" "")))
(if file-name
(begin
(gnc:debug "Running text exporting to (not really) " file-name)
(pretty-print 'gnucash-data-file)
(pretty-print '(version "1.0"))
(display "\n\n;;; Account information\n")
;; Print all the accounts
(pretty-print
(gnc:group-map-accounts
gnc:account->output-form
account-group))
(display "\n\n;;; Transactions\n\n")
;; Now print all the transactions
(gnc:group-begin-staged-transaction-traversals account-group)
(gnc:group-map-accounts gnc:account-transactions-export-as-text
account-group)))))
(define (gnc:account-transactions-export-as-text account)
(gnc:account-staged-transaction-traversal
@@ -96,40 +82,38 @@
1
(lambda (t) (pretty-print (gnc:transaction->output-form t)))))
(define (gnc:transaction->output-form transaction)
(list
'transaction
(gnc:transaction-get-num transaction)
(gnc:transaction-get-date-posted transaction)
(gnc:transaction-get-date-entered transaction)
(gnc:transaction-get-description transaction)
(gnc:transaction-get-docref transaction)
(gnc:transaction-map-splits gnc:split->output-form transaction)))
(define (gnc:main-win-export-data-as-text win)
(let ((account-group #f)
; (session (gnc:main-window-get-session win)))
(session (gnc:main-window-get-session)))
(define (gnc:transaction-map-splits thunk transaction)
(let loop ((num-splits (gnc:transaction-get-split-count transaction))
(i 0))
(if (< i num-splits)
(cons
(thunk (gnc:transaction-get-split transaction i))
(loop num-splits (+ i 1)))
'())))
(if session (set! account-group (gnc:session-get-group session)))
(if (not account-group)
(gnc:error-message-dialog "No account group available for text export.")
(gnc:account-group-export-as-text account-group))))
(define (gnc:account-group-export-as-text account-group)
(let ((file-name (gnc:file-selection-dialog "Select file for text export" "")))
(if file-name
(begin
(gnc:debug "Running text exporting to (not really) " file-name)
(pretty-print 'gnucash-data-file)
(pretty-print '(version "1.0"))
(display "\n\n;;; Account information\n")
;; Print all the accounts
(pretty-print
(gnc:group-map-accounts
gnc:account->output-form
account-group))
(display "\n\n;;; Transactions\n\n")
;; Now print all the transactions
(gnc:group-begin-staged-transaction-traversals account-group)
(gnc:group-map-accounts
gnc:account-transactions-export-as-text
account-group)))))
(define (gnc:split->output-form split)
(list
'split
(gnc:split-get-memo split)
(gnc:split-get-action split)
(gnc:split-get-reconcile-state split)
(gnc:split-get-reconciled-date split)
(gnc:split-get-docref split)
(gnc:split-get-share-amount split)
(gnc:split-get-share-price split)
(gnc:split-get-share-price split)
(let ((xfer-account (gnc:split-get-account split))
(xfer-account-id #f))
(if (not (pointer-token-null? xfer-account))
(set! xfer-account-id (gnc:account-get-id xfer-account)))
xfer-account-id)))