mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
updates from cbbrowne
Subject: Patch of Docs, QIF/Guile Date: Sat, 27 Nov 1999 11:37:04 -0600 git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@1991 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Linas Vepstas
parent
882eabf200
commit
49d51b4432
130
src/scm/acc-create.scm
Normal file
130
src/scm/acc-create.scm
Normal file
@ -0,0 +1,130 @@
|
||||
;;; Account creation utilities
|
||||
(define gnc:account-types (initialize-hashtable 29)) ;; Need not be large...
|
||||
(define (account-type->number symbol)
|
||||
(let
|
||||
((s (hashv-ref gnc:account-types symbol)))
|
||||
(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 (get-all-types)
|
||||
(set! gnc:account-types (initialize-hashtable 29)) ;; Need not be a big table
|
||||
(let loop
|
||||
((i 0))
|
||||
(let ((typesymbol (gnc:account-type->symbol i)))
|
||||
(hashv-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))
|
||||
|
||||
;;;;; And now, a "test bed"
|
||||
(define (gnc:test-load-accs group)
|
||||
(let ((cash
|
||||
(list (gnc:malloc-account)
|
||||
"Sample Cash"
|
||||
"Sample Cash Description"
|
||||
"No notes - this is just a sample"
|
||||
1))
|
||||
(inc1
|
||||
(list (gnc:malloc-account)
|
||||
"Misc Income"
|
||||
"Miscellaneous Income"
|
||||
"Just a dumb income account"
|
||||
8))
|
||||
(exp1
|
||||
(list (gnc:malloc-account)
|
||||
"Misc Exp"
|
||||
"Miscellaneous Expenses"
|
||||
"Just a dumb expense account"
|
||||
9)))
|
||||
(display "Samples: ") (newline)
|
||||
(display (list cash inc1 exp1)) (newline)
|
||||
(apply gnc:create-account cash)
|
||||
(apply gnc:create-account inc1)
|
||||
(apply gnc:create-account exp1)
|
||||
(display "group:") (display group) (newline)
|
||||
(gnc:group-insert-account group (car cash))
|
||||
(gnc:group-insert-account group (car inc1))
|
||||
(gnc:group-insert-account group (car exp1))
|
||||
(gnc:refresh-main-window))
|
||||
(display "Tried creation")(newline))
|
||||
@ -7,6 +7,37 @@
|
||||
|
||||
;; (use-modules (gnc))
|
||||
|
||||
(define (build-path firstelement . restofpath)
|
||||
(define separator "/")
|
||||
(define (bp first rest)
|
||||
(if (null? rest)
|
||||
first
|
||||
(bp
|
||||
(string-append first separator (car rest))
|
||||
(cdr rest))))
|
||||
(if (null? restofpath)
|
||||
firstelement
|
||||
(bp
|
||||
(string-append firstelement separator
|
||||
(car restofpath))
|
||||
(cdr restofpath))))
|
||||
|
||||
;;; This is a for-each function for use with Guile hash tables.
|
||||
;;; It is equally usable with all three forms (hash, hashv, hashq)
|
||||
;;; and is reasonably efficient, effectively being a loop that does
|
||||
;;; an iteration for each element in the base vector plus an iteration
|
||||
;;; for each hashed item found. There should not exist an algorithm
|
||||
;;; with lower time complexity.
|
||||
(define (hash-for-each fun hashtable)
|
||||
(array-for-each
|
||||
(lambda (x)
|
||||
(if (null? x)
|
||||
#f
|
||||
(for-each (lambda (y)
|
||||
(fun y))
|
||||
x)))
|
||||
hashtable))
|
||||
|
||||
;; In pre 1.3 guile's you have to do this manually, unless you call
|
||||
;; scm_shell, which we can't.
|
||||
(if (or (string=? (version) "1.2")
|
||||
|
||||
@ -18,43 +18,52 @@
|
||||
(gnc:error-dialog
|
||||
"Some error didn't occur.")))
|
||||
|
||||
(gnc:extensions-menu-add-item "QIF Import"
|
||||
"Import QIF hint"
|
||||
(gnc:extensions-menu-add-item "QIF File Import"
|
||||
"Import QIF File - Scripted in Guile"
|
||||
(lambda ()
|
||||
(gnc:extensions-qif-import win)))
|
||||
|
||||
(gnc:extensions-menu-add-item
|
||||
"Test choose item from list dialog"
|
||||
"Test choose item from list dialog"
|
||||
(lambda ()
|
||||
(let ((result (gnc:choose-item-from-list-dialog
|
||||
"Choose item from list test dialog"
|
||||
(list
|
||||
(cons "Item 1"
|
||||
(lambda ()
|
||||
(display "Item 1 selected") (newline)
|
||||
#f))
|
||||
(cons "Item 2"
|
||||
(lambda ()
|
||||
(display "Item 2 selected") (newline)
|
||||
#f))
|
||||
(cons "Item 3 (and close dialog)"
|
||||
(lambda ()
|
||||
(display "Item 3 selected -- close") (newline)
|
||||
'some-interesting-result))))))
|
||||
|
||||
(cond
|
||||
((eq? result #f)
|
||||
(gnc:error-dialog
|
||||
"Fatal error in choose item from list dialog."))
|
||||
((eq? result 'cancel)
|
||||
(gnc:error-dialog "Choose item from list dialog canceled."))
|
||||
(else
|
||||
(gnc:error-dialog
|
||||
(call-with-output-string (lambda (string-port)
|
||||
(display "Choose item result: "
|
||||
string-port)
|
||||
(write result string-port)))))))))
|
||||
(gnc:extensions-menu-add-item "Test Adding Transactions"
|
||||
"Test Bed"
|
||||
(lambda ()
|
||||
(gnc:extensions-test-add-txns win)))
|
||||
|
||||
(gnc:extensions-menu-add-item "Test Adding Accounts"
|
||||
"Test Bed"
|
||||
(lambda ()
|
||||
(gnc:extensions-test-add-accs win)))
|
||||
|
||||
(gnc:extensions-menu-add-item "Test choose item from list dialog"
|
||||
"Test choose item from list dialog"
|
||||
(lambda ()
|
||||
(let ((result (gnc:choose-item-from-list-dialog
|
||||
"Choose item from list test dialog"
|
||||
(list
|
||||
(cons "Item 1"
|
||||
(lambda ()
|
||||
(display "Item 1 selected") (newline)
|
||||
#f))
|
||||
(cons "Item 2"
|
||||
(lambda ()
|
||||
(display "Item 2 selected") (newline)
|
||||
#f))
|
||||
(cons "Item 3 (and close dialog)"
|
||||
(lambda ()
|
||||
(display "Item 3 selected -- close") (newline)
|
||||
'some-interesting-result))))))
|
||||
|
||||
(cond
|
||||
((eq? result #f)
|
||||
(gnc:error-dialog
|
||||
"Fatal error in choose item from list dialog."))
|
||||
((eq? result 'cancel)
|
||||
(gnc:error-dialog "Choose item from list dialog canceled."))
|
||||
(else
|
||||
(gnc:error-dialog
|
||||
(call-with-output-string (lambda (string-port)
|
||||
(display "Choose item result: "
|
||||
string-port)
|
||||
(write result string-port)))))))))
|
||||
|
||||
(gnc:extensions-menu-add-item
|
||||
"Test verify dialog"
|
||||
|
||||
@ -13,82 +13,6 @@
|
||||
(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)
|
||||
@ -105,88 +29,4 @@
|
||||
|
||||
;;; 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)))
|
||||
|
||||
@ -13,7 +13,7 @@
|
||||
(define (guess-gnucash-category
|
||||
inputcat gc-income-categories gc-account-categories)
|
||||
(let*
|
||||
((picklist (initialize-lookup))
|
||||
((picklist (initialize-hashtable))
|
||||
(qifname (inputcat 'get 'name))
|
||||
(catlength (string-length (qifname)))
|
||||
(is-acct? (and
|
||||
@ -32,7 +32,7 @@
|
||||
inputcat))
|
||||
(add-to-picklist
|
||||
(lambda (string value)
|
||||
(set! picklist (lookup-set! picklist string value))))
|
||||
(hashv-set! picklist string value)))
|
||||
(match-against-list
|
||||
(lambda (itemstring)
|
||||
(if (string=? itemstring incat) ;;; Exact match
|
||||
|
||||
@ -5,34 +5,71 @@
|
||||
|
||||
(define favorite-currency "USD") ;;;; This may need to change...
|
||||
|
||||
(define (gnc:extensions-qif-import win)
|
||||
(define (gnc:extensions-test-add-accs win)
|
||||
(let ((account-group (gnc:get-current-group)))
|
||||
(if (not account-group)
|
||||
(gnc:error-dialog
|
||||
"No account group available for text export.")
|
||||
"No account group available for account import.")
|
||||
(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")
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(loadlist '("testbed.scm" "analytical-qifs.scm"
|
||||
"gc-import-qifs.scm"
|
||||
"qifutils.scm" "acc-create.scm")))
|
||||
(for-each loadfun loadlist))
|
||||
(begin
|
||||
(get-all-types)
|
||||
(display "Account type list:")
|
||||
(display gnc:account-types)
|
||||
(newline))
|
||||
(gnc:test-load-accs account-group)))))
|
||||
|
||||
(define (gnc:extensions-test-add-txns win)
|
||||
(let ((account-group (gnc:get-current-group)))
|
||||
(if (not account-group)
|
||||
(gnc:error-dialog
|
||||
"No account group available for transaction import.")
|
||||
(begin
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(loadlist '("testbed.scm" "analytical-qifs.scm"
|
||||
"gc-import-qifs.scm"
|
||||
"qifutils.scm" "txn-create.scm")))
|
||||
(for-each loadfun loadlist))
|
||||
(begin
|
||||
(get-all-types)
|
||||
(display "Account type list:")
|
||||
(display gnc:account-types)
|
||||
(newline))
|
||||
(gnc:test-load-txns account-group)))))
|
||||
|
||||
(define (gnc:extensions-qif-import win)
|
||||
(let ((account-group (gnc:get-current-group)))
|
||||
(if (not account-group)
|
||||
(gnc:error-dialog
|
||||
"No account group available for QIF import.")
|
||||
(begin
|
||||
(display "account-group:")
|
||||
(display account-group) (newline)
|
||||
(let ((loadfun (lambda (x) (gnc:load x)))
|
||||
(loadlist '("testbed.scm" "sstring-qif.scm"
|
||||
"acc-create.scm"
|
||||
"txn-create.scm"
|
||||
"qifutils.scm" "dates-qif.scm"
|
||||
"split-qif.scm" "qifcats.scm"
|
||||
"parseqif.scm" "qifstate.scm"
|
||||
"qifstat.scm" "qif2gc.scm"
|
||||
"guess-category-qif.scm"
|
||||
"analytical-qifs.scm"
|
||||
"gc-import-qifs.scm")))
|
||||
(for-each loadfun loadlist))
|
||||
(begin
|
||||
(get-all-types)
|
||||
(display "Account type list:")
|
||||
(display gnc:account-types)
|
||||
(newline))
|
||||
(gnc:test-load account-group) ; This tries to create some accounts
|
||||
(gnc:import-file-into-account-group account-group)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -3,16 +3,26 @@
|
||||
(define qif-txn-list '())
|
||||
|
||||
(define qif-txn-structure
|
||||
(define-mystruct '(memo date id payee addresslist amount status category splitlist)))
|
||||
(make-record-type
|
||||
"qif-txn"
|
||||
'(memo date id payee addresslist amount status category splitlist)))
|
||||
|
||||
(define thetxn
|
||||
(build-mystruct-instance qif-txn-structure))
|
||||
(define thetxn
|
||||
((record-constructor qif-txn-structure)
|
||||
#f #f #f #f #f #f #f #f #f))
|
||||
|
||||
(define (txnupdate txn field value)
|
||||
((record-modifier qif-txn-structure field) txn value))
|
||||
|
||||
(define (txnget txn field)
|
||||
((record-accessor qif-txn-structure field) txn))
|
||||
|
||||
(define addresslist '())
|
||||
|
||||
(define (read-qif-file file account-group)
|
||||
(set! qif-txn-list '()) ; Reset the transaction list...
|
||||
(set! thetxn (build-mystruct-instance qif-txn-structure))
|
||||
(set! thetxn ((record-constructor qif-txn-structure)
|
||||
#f #f #f #f #f #f #f #f #f))
|
||||
(resetdates) ; Reset the date checker
|
||||
(let*
|
||||
((infile (open-input-file file)))
|
||||
@ -38,11 +48,11 @@
|
||||
(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")))
|
||||
; (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)
|
||||
(write txn outfile)
|
||||
(newline outfile))))
|
||||
|
||||
(display (string-append ";;;; Data from " file) outfile)
|
||||
@ -69,27 +79,22 @@
|
||||
(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)
|
||||
(hash-for-each (lambda (x)
|
||||
(write x 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)
|
||||
(hash-for-each (lambda (x)
|
||||
(write x)
|
||||
(newline))
|
||||
category-analysis)
|
||||
(display ")")
|
||||
(newline outfile)
|
||||
(close-output-port outfile)))
|
||||
|
||||
(define (read-qiffile-line line)
|
||||
(display (string-append "Line:" line)) (newline)
|
||||
; (display (string-append "Line:" line)) (newline)
|
||||
(if
|
||||
(char=? (string-ref line 0) #\!) ;;; Starts with a !
|
||||
(newqifstate line)) ;;; Jump to a new state...
|
||||
@ -104,19 +109,16 @@
|
||||
#f) ; do nothing with line
|
||||
|
||||
(define (oops-new-command-type line)
|
||||
(write "Oops: New command type!")
|
||||
(write line))
|
||||
(display (string-append "Oops: New command type!" line))
|
||||
(newline))
|
||||
|
||||
(define (rewrite-txn-line line)
|
||||
(let*
|
||||
((fchar (substring line 0 1))
|
||||
(found (lookup fchar trans-jumptable)))
|
||||
(if
|
||||
found
|
||||
(let
|
||||
((tfunction (cdr found)))
|
||||
(tfunction line))
|
||||
(oops-new-command-type line))))
|
||||
((fchar (string-ref line 0))
|
||||
(found (hashv-ref trans-jumptable fchar)))
|
||||
(if found
|
||||
(found line)
|
||||
(oops-new-command-type line))))
|
||||
|
||||
;;;; At the end of a transaction,
|
||||
;;;; Insert queued material into "thetxn" (such as splits, address)
|
||||
@ -124,20 +126,21 @@
|
||||
;;;; And then clear stateful variables.
|
||||
(define (end-of-transaction line) ; End of transaction
|
||||
(if (not (null? addresslist))
|
||||
(thetxn 'put 'addresslist addresslist))
|
||||
(txnupdate thetxn 'addresslist addresslist))
|
||||
(if splits?
|
||||
(begin
|
||||
(thetxn 'put 'splitslist splitlist)
|
||||
(txnupdate thetxn 'splitlist splitlist)
|
||||
(ensure-split-adds-up)
|
||||
(resetsplits)))
|
||||
(set! qif-txn-list (cons thetxn qif-txn-list))
|
||||
(set! addresslist '())
|
||||
(set! thetxn (build-mystruct-instance qif-txn-structure)))
|
||||
(set! thetxn ((record-constructor qif-txn-structure)
|
||||
#f #f #f #f #f #f #f #f #f)))
|
||||
|
||||
;;;;;;;;;;; Various "trans" functions for different
|
||||
;;;;;;;;;;; sorts of QIF lines
|
||||
(define (transmemo line)
|
||||
(thetxn 'put 'memo (strip-qif-header line)))
|
||||
(txnupdate thetxn 'memo (strip-qif-header line)))
|
||||
|
||||
(define (transaddress line)
|
||||
(set! addresslist (cons (strip-qif-header line) addresslist)))
|
||||
@ -146,7 +149,7 @@
|
||||
(let*
|
||||
((date (replacespace0 (strip-qif-header line)))
|
||||
(dpieces (split-on-somechar date #\/)))
|
||||
(thetxn 'put 'date date)
|
||||
(txnupdate thetxn '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
|
||||
@ -162,45 +165,44 @@
|
||||
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))))
|
||||
(txnupdate thetxn 'amount (numerizeamount (strip-qif-header line))))
|
||||
|
||||
(define (transid line)
|
||||
(thetxn 'put 'id (strip-qif-header line)))
|
||||
(txnupdate thetxn 'id (strip-qif-header line)))
|
||||
|
||||
(define (transstatus line)
|
||||
(thetxn 'put 'status (strip-qif-header line)))
|
||||
(txnupdate thetxn 'status (strip-qif-header line)))
|
||||
|
||||
(define (transpayee line)
|
||||
(thetxn 'put 'payee (strip-qif-header line)))
|
||||
(txnupdate thetxn 'payee (strip-qif-header line)))
|
||||
|
||||
(define (transcategory line)
|
||||
(thetxn 'put 'category (strip-qif-header line)))
|
||||
(txnupdate thetxn 'category (strip-qif-header line)))
|
||||
|
||||
(define trans-jumptable (initialize-lookup))
|
||||
(define trans-jumptable (initialize-hashtable 37)) ;;; Need not be large
|
||||
|
||||
(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)))
|
||||
'((#\^ 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))))))
|
||||
(hashv-set! trans-jumptable command function)))))
|
||||
(for-each setter ltable))
|
||||
|
||||
(display "trans-jumptable")
|
||||
|
||||
@ -10,10 +10,10 @@
|
||||
(case item
|
||||
((default)
|
||||
(list
|
||||
(string-append (getenv "HOME") "/.gnucash/doc")
|
||||
(string-append gnc:_share-dir-default_ "/Docs/En")
|
||||
(string-append gnc:_share-dir-default_ "/Docs")
|
||||
(string-append gnc:_share-dir-default_ "/Reports")))
|
||||
(build-path (getenv "HOME") ".gnucash" "doc")
|
||||
(build-path gnc:_share-dir-default_ "Docs" "En")
|
||||
(build-path gnc:_share-dir-default_ "Docs")
|
||||
(build-path gnc:_share-dir-default_ "Reports")))
|
||||
((current)
|
||||
(gnc:config-var-value-get gnc:*doc-path*))
|
||||
(else
|
||||
@ -32,9 +32,9 @@
|
||||
(gnc:debug "loading user configuration")
|
||||
|
||||
(let ((user-file
|
||||
(string-append (getenv "HOME") "/.gnucash/config.user"))
|
||||
(build-path (getenv "HOME") ".gnucash" "config.user"))
|
||||
(auto-file
|
||||
(string-append (getenv "HOME") "/.gnucash/config.auto")))
|
||||
(build-path (getenv "HOME") ".gnucash" "config.auto")))
|
||||
|
||||
(if (access? user-file F_OK)
|
||||
(if (false-if-exception (primitive-load user-file))
|
||||
@ -60,9 +60,9 @@
|
||||
(begin
|
||||
(gnc:debug "loading system configuration")
|
||||
|
||||
(let ((system-config (string-append
|
||||
(let ((system-config (build-path
|
||||
(gnc:config-var-value-get gnc:*config-dir*)
|
||||
"/config")))
|
||||
"config")))
|
||||
|
||||
(if (false-if-exception (primitive-load system-config))
|
||||
(set! system-config-loaded? #t)
|
||||
|
||||
@ -6,71 +6,94 @@
|
||||
;;; 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)))
|
||||
(make-record-type "gnucash-account-structure"
|
||||
'(id name flags type code description
|
||||
notes currency security splitlist
|
||||
parentaccountgroup
|
||||
childrenaccountgroup)))
|
||||
|
||||
(define (gnc-account-update acc field value)
|
||||
((record-modifier gnc-account-structure field) acc value))
|
||||
|
||||
(define (gnc-account-get acc field)
|
||||
((record-accessor gnc-account-structure field) acc))
|
||||
|
||||
(define gnc-account-group-structure
|
||||
(define-mystruct '(parentaccount peercount
|
||||
peerlist)))
|
||||
(make-record-type "gnucash-account-group-structure"
|
||||
'(parentaccount peercount
|
||||
peerlist)))
|
||||
|
||||
(define gnc-txn-structure
|
||||
(define-mystruct '(num date-posted date-entered description
|
||||
docref splitlist)))
|
||||
(make-record-type "gnucash-txn-structure"
|
||||
'(num date-posted date-entered description
|
||||
docref splitlist)))
|
||||
|
||||
(define (gnc-txn-update txn field value)
|
||||
((record-modifier gnc-txn-structure field) txn value))
|
||||
|
||||
(define (gnc-txn-get txn field)
|
||||
((record-accessor gnc-txn-structure field) txn))
|
||||
|
||||
(define gnc-split-structure
|
||||
(define-mystruct '(memo action reconcile-state
|
||||
reconciled-date docref share-amount
|
||||
share-price account parenttransaction)))
|
||||
(make-record-type "gnucash-split-structure"
|
||||
'(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 (gnc-split-update split field value)
|
||||
((record-modifier gnc-split-structure field) split value))
|
||||
|
||||
(define (gnc-split-get split field)
|
||||
((record-accessor gnc-split-structure field) split))
|
||||
|
||||
(define gnc-txn-list (initialize-hashtable))
|
||||
(define gnc-acc-list (initialize-hashtable))
|
||||
(define gnc-split-list (initialize-hashtable))
|
||||
|
||||
(define (add-qif-transaction-to-gnc-lists txn curtxn cursplitlist accountname)
|
||||
(define txnref (gensym))
|
||||
(set! gnc-txn-list (lookup-set! gnc-txn-list txnref curtxn))
|
||||
(hashv-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))
|
||||
(gnc-txn-update curtxn 'num (txn 'get 'id))
|
||||
(gnc-txn-update curtxn 'date-posted (txn 'get 'date))
|
||||
(gnc-txn-update curtxn 'date-entered '(1999 0903)) ;;; Which should get replaced!
|
||||
(gnc-txn-update curtxn 'description (txn 'get 'memo))
|
||||
(gnc-txn-update curtxn '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 'reconciled-date
|
||||
(if (string=? (txn 'get 'date) "*")
|
||||
'(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)))
|
||||
|
||||
(mainsplit ((record-constructor gnc-split-structure)
|
||||
#f #f #f #f #f #f #f #f #f)))
|
||||
(gnc-split-update mainsplit 'memo (txnget txn 'memo))
|
||||
(gnc-split-update mainsplit 'share-amount (txnget txn 'amount))
|
||||
(gnc-split-update mainsplit 'reconcile-state (txnget txn 'status))
|
||||
(gnc-split-update mainsplit 'reconciled-date
|
||||
(if (string=? (txnget txn 'date) "*")
|
||||
'(1999 09 03) #f))
|
||||
(gnc-split-update mainsplit 'docref (txnget txn 'id))
|
||||
(gnc-split-update mainsplit 'parenttransaction txnref)
|
||||
(gnc-split-update mainsplit 'account accountname)
|
||||
(hashv-set! gnc-split-list mainref mainsplit))
|
||||
|
||||
;;;; Chunk of missing code:
|
||||
;;;; ---> Take a look at the split list in (txn 'get 'splitlist)
|
||||
;;;; ---> Take a look at the split list in (txnget txn 'splitlist)
|
||||
;;;; Add a split for each one of these
|
||||
;;;; Alternatively, add a split for (txn 'get 'category)
|
||||
;;;; Alternatively, add a split for (txnget txn 'category)
|
||||
;;;; ---> Attach all the accounts to the corresponding splits
|
||||
(curtxn 'put 'splitlist lookup-keys cursplitlist))
|
||||
(display "Now, update txn with set of split...")
|
||||
(gnc-txn-update curtxn 'splitlist lookup-keys cursplitlist)
|
||||
(display "done.") (newline)
|
||||
)
|
||||
|
||||
(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 accountname))))
|
||||
((curtxn ((record-constructor gnc-txn-structure) #f #f #f #f #f #f))
|
||||
(cursplitlist (initialize-hashtable 19)) ;;; Doesn't need to be large
|
||||
(process-txn (lambda (x)
|
||||
(add-qif-transaction-to-gnc-lists
|
||||
x curtxn cursplitlist accountname))))
|
||||
(for-each process-txn txnlist)))
|
||||
|
||||
; QIF essentially provides a structure that sort of looks like
|
||||
@ -132,9 +155,10 @@
|
||||
; - 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)
|
||||
(let ((ptr (gnc:split-create))
|
||||
(splitstruct ((record-constructor gnc-split-structure)
|
||||
#f #f #f #f #f #f #f #f #f)))
|
||||
(gnc-split-structure splitstruct 'gncpointer ptr)
|
||||
splitstruct))
|
||||
|
||||
(define (gnc:set-split-values q-txn q-split)
|
||||
@ -154,31 +178,32 @@
|
||||
|
||||
(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 ((record-constructor gnc-account-structure)
|
||||
#f #f #f #f #f #f #f #f #f #f #f #f)))
|
||||
(gnc-account-update accstruct '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 ((record-constructor gnc-transaction-structure)
|
||||
#f #f #f #f #f #f)))
|
||||
(gnc-account-update txnstruct 'gncpointer ptr)
|
||||
txnstruct))
|
||||
|
||||
(if testing?
|
||||
(begin
|
||||
(display "need test scripts in qif2gc.scm")))
|
||||
|
||||
(define best-guesses (initialize-lookup))
|
||||
(define best-guesses (initialize-hashtable 19)) ;; Need not be a big list
|
||||
|
||||
(define (add-best-guess qif gnc)
|
||||
(set! best-guesses (lookup-set! best-guesses qif gnc)))
|
||||
(hashv-set! best-guesses qif gnc))
|
||||
|
||||
(define (find-best-guess qif)
|
||||
(lookup qif best-guesses))
|
||||
(hashv-ref qif best-guesses))
|
||||
|
||||
(define qif-to-gnc-acct-xlation-table (initialize-lookup))
|
||||
(define qif-to-gnc-acct-xlation-table (initialize-hashtable))
|
||||
|
||||
(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)))
|
||||
(hashv-set! qif-to-gnc-acct-xlation-table
|
||||
qif gnc))
|
||||
|
||||
@ -1,23 +1,27 @@
|
||||
;;; $Id$
|
||||
;;;;; Category management
|
||||
|
||||
(define qif-cat-list (initialize-lookup))
|
||||
(define qif-cat-list (initialize-hashtable))
|
||||
|
||||
(define qif-category-structure
|
||||
(define-mystruct '(name count value)))
|
||||
(make-record-type "qif-category-structure" '(name count value)))
|
||||
|
||||
(define (qif-category-update cat field value)
|
||||
((record-modifier qif-category-structure field) cat value))
|
||||
|
||||
(define (analyze-qif-categories)
|
||||
(define (analyze-qif-category item)
|
||||
(let*
|
||||
((id (car item))
|
||||
(q (cdr item))
|
||||
(gc (build-mystruct-instance gnc-account-structure))
|
||||
(gc ((record-constructor gnc-account-structure)
|
||||
#f #f #f #f #f #f #f #f #f #f #f #f))
|
||||
(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
|
||||
(gnc-account-update gc 'type
|
||||
(if positive?
|
||||
(if balance-sheet?
|
||||
'BANK
|
||||
@ -25,19 +29,19 @@
|
||||
(if balance-sheet?
|
||||
'INCOME
|
||||
'EXPENSE)))
|
||||
(gc 'put 'description id)
|
||||
(gc 'put 'currency favorite-currency)))
|
||||
(set! qif-analysis (initialize-lookup))
|
||||
(gnc-account-update gc 'description id)
|
||||
(gnc-account-update gc 'currency favorite-currency)))
|
||||
(set! qif-analysis (initialize-hashtable))
|
||||
(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)))
|
||||
(collect-cat-stats (txnget txn 'category)
|
||||
(txnget txn 'amount))
|
||||
(let ((splits (txnget txn 'splitlist)))
|
||||
(if splits
|
||||
(for-each analyze-qif-split-category splits))))
|
||||
(set! qif-cat-list (initialize-lookup))
|
||||
(set! qif-cat-list (initialize-hashtable))
|
||||
(for-each analyze-qif-txn-category qif-txn-list)
|
||||
qif-cat-list)
|
||||
|
||||
@ -45,14 +49,16 @@
|
||||
(collect-cat-stats (split 'get 'category) (split 'get 'amount)))
|
||||
|
||||
(define (collect-cat-stats category amount)
|
||||
(let* ((s (lookup category qif-cat-list)))
|
||||
(let* ((s (hashv-ref qif-cat-list category)))
|
||||
(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))))
|
||||
(qif-category-update sc 'value (+ amount (sc 'get 'value)))
|
||||
(qif-category-update sc '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)))))))
|
||||
(let ((nc ((record-constructor qif-category-structure) #f #f #f)))
|
||||
(qif-category-update nc 'name category)
|
||||
(qif-category-update nc 'count 1)
|
||||
(qif-category-update nc 'value amount)
|
||||
(hashv-set! qif-cat-list category nc))))))
|
||||
|
||||
|
||||
|
||||
@ -1,4 +1,55 @@
|
||||
;;; $Id$
|
||||
;;;;; - 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 qif-txn-list)
|
||||
(define cleared? #f)
|
||||
(define (look-for-cleared txn)
|
||||
(if
|
||||
(string=? "X" (cdr (assoc 'status txn)))
|
||||
(set! cleared #t)))
|
||||
(for-each look-for-cleared qif-txn-list)
|
||||
(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...
|
||||
(let ((certain? (lambda () #f)))
|
||||
(set! cleared (certain?)))))
|
||||
(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
|
||||
|
||||
(if testing?
|
||||
(begin (display "Need tests for qifstat.scm") (newline)));;; $Id$
|
||||
(define qifstate #f)
|
||||
|
||||
(define (newqifstate line)
|
||||
@ -21,7 +72,8 @@
|
||||
(set! qifstate (cdr statepair))
|
||||
(cdr statepair))
|
||||
(begin
|
||||
(display "No new QIF state") (newline)))))
|
||||
(display "No new QIF state") (newline)
|
||||
#f))))
|
||||
|
||||
(testing "newqifstate"
|
||||
"!Account"
|
||||
|
||||
@ -192,70 +192,34 @@
|
||||
first)
|
||||
first))))
|
||||
|
||||
(define (shorten-to-best keep-top-n picklist)
|
||||
(define (shorten-to-best! keep-top-n picklist)
|
||||
(let ((shortened '()))
|
||||
(let loop ((count keep-top-n))
|
||||
(if (> count 0)
|
||||
(let
|
||||
((bestitem (find-min-cdr picklist)))
|
||||
(if (= count 0) ;;; No room left...
|
||||
shortened ;;; Return the present short list
|
||||
(let ((bestitem (find-min-cdr picklist)))
|
||||
(if bestitem
|
||||
(begin
|
||||
(if (> 99 (cdr bestitem))
|
||||
(begin
|
||||
(if (> 9999 (cdr bestitem))
|
||||
(set! shortened (cons (car bestitem) shortened)))
|
||||
(set-cdr! bestitem 999) ;;;; Force off list...
|
||||
(loop (- count 1)))))))
|
||||
shortened))
|
||||
(set-cdr! bestitem 999999)
|
||||
(loop (- count 1)))))))))
|
||||
|
||||
;;;; Test shorten-to-best:
|
||||
|
||||
(if testing?
|
||||
(let
|
||||
((alist '((a . 10) (b . 15) (c . 20) (d . 12) (e . 7))))
|
||||
(testing "shorten-to-best 3"
|
||||
(testing "shorten-to-best! 3"
|
||||
alist
|
||||
'(b c d)
|
||||
(shorten-to-best 3 alist))))
|
||||
'(d a e)
|
||||
(shorten-to-best! 3 alist))))
|
||||
|
||||
;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
|
||||
;;; Initialize lookup table
|
||||
(define (initialize-lookup)
|
||||
'())
|
||||
|
||||
(define (lookup key list) ;;; Returns (key . value)
|
||||
(assoc key list))
|
||||
|
||||
(define (lookup-set! lookuptable key value)
|
||||
(let
|
||||
((oldval (assoc key lookuptable)))
|
||||
(if oldval
|
||||
(set-cdr! oldval value)
|
||||
(set! lookuptable (cons (cons key value) lookuptable))))
|
||||
lookuptable)
|
||||
|
||||
(define (lookup-map lfunction ltable)
|
||||
(map lfunction ltable))
|
||||
|
||||
(define (lookup-keys ltable)
|
||||
(map car ltable))
|
||||
|
||||
(if testing?
|
||||
(begin
|
||||
(write "Testing lookup tables.") (newline)
|
||||
(let
|
||||
((ltbl (initialize-lookup))
|
||||
(sfun (lambda (x)
|
||||
(display "(car.cdr) = (")
|
||||
(display (car x)) (display ".")
|
||||
(display (cdr x)) (display ")") (newline))))
|
||||
(set! ltbl (lookup-set! ltbl "1" "one"))
|
||||
(set! ltbl (lookup-set! ltbl "2" "twoo"))
|
||||
(set! ltbl (lookup-set! ltbl "3" "three"))
|
||||
(set! ltbl (lookup-set! ltbl "2" "two"))
|
||||
(display "After 4 inserts, ltbl looks like:")
|
||||
(display ltbl) (newline)
|
||||
(display "Now, look up 1, 3, 2") (newline)
|
||||
(display (list (lookup "1" ltbl) (lookup "2" ltbl) (lookup "3" ltbl)))
|
||||
(newline)
|
||||
(display "Try mapping using lookup-map:")(newline)
|
||||
(lookup-map sfun ltbl)
|
||||
(newline))))
|
||||
(define (initialize-hashtable . size)
|
||||
(make-vector
|
||||
(if (null? size)
|
||||
313
|
||||
(car size))
|
||||
'()))
|
||||
42
src/scm/samp.scm
Normal file
42
src/scm/samp.scm
Normal file
@ -0,0 +1,42 @@
|
||||
(define (gnc:create-account AccPtr name description notes type)
|
||||
(display "start creation")(newline)
|
||||
(gnc:xaccAccountBeginEdit AccPtr 0)
|
||||
(display "edit")(newline)
|
||||
(display (string-append "Name:" name)) (newline)
|
||||
(gnc:xaccAccountSetName AccPtr name)
|
||||
(display (string-append "Descr:" description)) (newline)
|
||||
(gnc:xaccAccountSetDescription AccPtr description)
|
||||
(display (string-append "notes:" notes)) (newline)
|
||||
(gnc:xaccAccountSetNotes AccPtr notes)
|
||||
(display (string-append "Type:" (number->string type))) (newline)
|
||||
(gnc:xaccAccountSetType AccPtr type)
|
||||
(gnc:xaccAccountCommitEdit AccPtr)
|
||||
(display "committed")(newline)
|
||||
)
|
||||
|
||||
(display "Create some accounts:")(newline)
|
||||
(let ((cash
|
||||
(list (gnc:malloc-account)
|
||||
"Sample Cash"
|
||||
"Sample Cash Description"
|
||||
"No notes - this is just a sample"
|
||||
1))
|
||||
(inc1
|
||||
(list (gnc:malloc-account)
|
||||
"Misc Income"
|
||||
"Miscellaneous Income"
|
||||
"Just a dumb income account"
|
||||
8))
|
||||
(exp1
|
||||
(list (gnc:malloc-account)
|
||||
"Misc Exp"
|
||||
"Miscellaneous Expenses"
|
||||
"Just a dumb expense account"
|
||||
9)))
|
||||
(display "Samples: ") (newline)
|
||||
(display (list cash inc1 exp1)) (newline)
|
||||
(apply gnc:create-account cash)
|
||||
(apply gnc:create-account inc1)
|
||||
(apply gnc:create-account exp1))
|
||||
(display "Tried creation")(newline)
|
||||
|
||||
@ -6,9 +6,16 @@
|
||||
(define splits? #f)
|
||||
(define splitlist '())
|
||||
(define qif-split-structure
|
||||
(define-mystruct '(category memo amount percent)))
|
||||
(make-record-type "qif-split-structure"
|
||||
'(category memo amount percent)))
|
||||
|
||||
(define thesplit (build-mystruct-instance qif-split-structure))
|
||||
(define (qif-split-update split field value)
|
||||
((record-modifier qif-split-structure field) split value))
|
||||
|
||||
(define (create-qif-split-structure)
|
||||
((record-constructor qif-split-structure) #f #f #f #f))
|
||||
|
||||
(define thesplit (create-qif-split-structure))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; And functions to nuke out the splits ;;;;
|
||||
@ -17,15 +24,18 @@
|
||||
(define (resetsplits) ;;; Do this at end of whole txn
|
||||
(set! splits? #f)
|
||||
(set! splitlist '())
|
||||
(set! thesplit (build-mystruct-instance qif-split-structure)))
|
||||
(set! thesplit (create-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 (thetxn 'get 'amount))
|
||||
(find-amount (lambda (splitstructure) (splitstructure 'get 'amount)))
|
||||
((txnamount (txnget thetxn 'amount))
|
||||
(find-amount (lambda (splitstructure)
|
||||
((record-accessor qif-split-structure
|
||||
'amount) splitstructure)))
|
||||
(null (begin (display "splitlist") (display splitlist) (display (map find-amount splitlist))))
|
||||
(total-of-split
|
||||
(apply + (map find-amount splitlist))))
|
||||
(if
|
||||
@ -44,12 +54,12 @@
|
||||
|
||||
(define (transsplitamt line)
|
||||
(set! splits? #T)
|
||||
(thesplit 'put 'amount (numerizeamount (strip-qif-header line)))
|
||||
(qif-split-update thesplit 'amount (numerizeamount (strip-qif-header line)))
|
||||
;;; And now, add amount and memo to splitlist
|
||||
(display (thesplit 'what 'what)) (newline)
|
||||
; (display (thesplit 'what 'what)) (newline)
|
||||
(set! splitlist (cons thesplit splitlist))
|
||||
(set! thesplit (build-mystruct-instance qif-split-structure)))
|
||||
|
||||
(set! thesplit (create-qif-split-structure)))
|
||||
|
||||
;;;; percentages only occur as parts of memorized transactions
|
||||
(define (transsplitpercent line)
|
||||
(set! splits? #T)
|
||||
@ -57,8 +67,8 @@
|
||||
|
||||
(define (transsplitmemo line)
|
||||
(set! splits? #T)
|
||||
(thesplit 'put 'memo (strip-qif-header line)))
|
||||
(qif-split-update thesplit 'memo (strip-qif-header line)))
|
||||
|
||||
(define (transsplitcategory line)
|
||||
(set! splits? #T)
|
||||
(thesplit 'put 'category (strip-qif-header line)))
|
||||
(qif-split-update thesplit 'category (strip-qif-header line)))
|
||||
|
||||
65
src/scm/txn-create.scm
Normal file
65
src/scm/txn-create.scm
Normal file
@ -0,0 +1,65 @@
|
||||
(define (gnc:create-transaction Account txnlist)
|
||||
(define (associt type)
|
||||
(let
|
||||
((result (hashv-ref 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)))
|
||||
|
||||
(define (gnc:test-load-txns accg)
|
||||
#f)diff -u 'pristine/gnucash/src/scm/utilities.scm' 'working/gnucash/src/scm/utilities.scm'
|
||||
@ -18,7 +18,7 @@
|
||||
|
||||
(if (not (or (string=? item ".")
|
||||
(string=? item "..")))
|
||||
(let* ((full-path (string-append dir-name "/" item)))
|
||||
(let* ((full-path (build-path dir-name item)))
|
||||
;; ignore symlinks, etc.
|
||||
(if (access? full-path F_OK)
|
||||
(let* ((status (lstat full-path))
|
||||
@ -41,7 +41,7 @@ string and 'directories' must be a list of strings."
|
||||
(result #f))
|
||||
((or (null? rest) finished?) result)
|
||||
|
||||
(let ((file-name (string-append (car rest) "/" file)))
|
||||
(let ((file-name (build-path (car rest) file)))
|
||||
(gnc:debug " checking for " file-name)
|
||||
(if (access? file-name F_OK)
|
||||
(begin
|
||||
|
||||
Loading…
Reference in New Issue
Block a user