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

updates from cbbrowne

Browse Source 
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 1999-11-29 08:18:08 +00:00
parent 882eabf200
commit 49d51b4432
16 changed files with 638 additions and 425 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

130
src/scm/acc-create.scm Normal file
View 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))

31
src/scm/bootstrap.scm.in
View File

@ -7,6 +7,37 @@
;; (use-modules (gnc)) ;; (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 ;; In pre 1.3 guile's you have to do this manually, unless you call
;; scm_shell, which we can't. ;; scm_shell, which we can't.
(if (or (string=? (version) "1.2") (if (or (string=? (version) "1.2")

75
src/scm/extensions.scm
View File

@ -18,43 +18,52 @@
(gnc:error-dialog (gnc:error-dialog
"Some error didn't occur."))) "Some error didn't occur.")))
(gnc:extensions-menu-add-item "QIF Import" (gnc:extensions-menu-add-item "QIF File Import"
"Import QIF hint" "Import QIF File - Scripted in Guile"
(lambda () (lambda ()
(gnc:extensions-qif-import win))) (gnc:extensions-qif-import win)))
(gnc:extensions-menu-add-item (gnc:extensions-menu-add-item "Test Adding Transactions"
"Test choose item from list dialog" "Test Bed"
"Test choose item from list dialog" (lambda ()
(lambda () (gnc:extensions-test-add-txns win)))
(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 (gnc:extensions-menu-add-item "Test Adding Accounts"
((eq? result #f) "Test Bed"
(gnc:error-dialog (lambda ()
"Fatal error in choose item from list dialog.")) (gnc:extensions-test-add-accs win)))
((eq? result 'cancel)
(gnc:error-dialog "Choose item from list dialog canceled.")) (gnc:extensions-menu-add-item "Test choose item from list dialog"
(else "Test choose item from list dialog"
(gnc:error-dialog (lambda ()
(call-with-output-string (lambda (string-port) (let ((result (gnc:choose-item-from-list-dialog
(display "Choose item result: " "Choose item from list test dialog"
string-port) (list
(write result string-port))))))))) (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 (gnc:extensions-menu-add-item
"Test verify dialog" "Test verify dialog"

160
src/scm/gc-import-qifs.scm
View File

@ -13,82 +13,6 @@
(newline) (newline)
(filteroutnulls fullacclist)))) (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) (define (gnc:import-file-into-account-group account-group)
;(sample-dialog) ;(sample-dialog)
@ -105,88 +29,4 @@
;;; Set up QIF Category ;;; 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)))

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

@ -13,7 +13,7 @@
(define (guess-gnucash-category (define (guess-gnucash-category
inputcat gc-income-categories gc-account-categories) inputcat gc-income-categories gc-account-categories)
(let* (let*
((picklist (initialize-lookup)) ((picklist (initialize-hashtable))
(qifname (inputcat 'get 'name)) (qifname (inputcat 'get 'name))
(catlength (string-length (qifname))) (catlength (string-length (qifname)))
(is-acct? (and (is-acct? (and
@ -32,7 +32,7 @@
inputcat)) inputcat))
(add-to-picklist (add-to-picklist
(lambda (string value) (lambda (string value)
(set! picklist (lookup-set! picklist string value)))) (hashv-set! picklist string value)))
(match-against-list (match-against-list
(lambda (itemstring) (lambda (itemstring)
(if (string=? itemstring incat) ;;; Exact match (if (string=? itemstring incat) ;;; Exact match

75
src/scm/importqif.scm
View File

@ -5,34 +5,71 @@
(define favorite-currency "USD") ;;;; This may need to change... (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))) (let ((account-group (gnc:get-current-group)))
(if (not account-group) (if (not account-group)
(gnc:error-dialog (gnc:error-dialog
"No account group available for text export.") "No account group available for account import.")
(begin (begin
(display "account-group:") (display account-group) (newline) (display "account-group:")
(gnc:load "testbed.scm") (display account-group) (newline)
(gnc:load "sstring-qif.scm") (let ((loadfun (lambda (x) (gnc:load x)))
(gnc:load "qifutils.scm") (loadlist '("testbed.scm" "analytical-qifs.scm"
(gnc:load "structure.scm") "gc-import-qifs.scm"
(gnc:load "dates-qif.scm") "qifutils.scm" "acc-create.scm")))
(gnc:load "split-qif.scm") (for-each loadfun loadlist))
(gnc:load "qifcats.scm") (begin
(gnc:load "parseqif.scm") (get-all-types)
(gnc:load "qifstate.scm") (display "Account type list:")
(gnc:load "qifstat.scm") (display gnc:account-types)
(gnc:load "qif2gc.scm") (newline))
(gnc:load "guess-category-qif.scm") (gnc:test-load-accs account-group)))))
(gnc:load "analytical-qifs.scm")
(gnc:load "test.scm") (define (gnc:extensions-test-add-txns win)
(gnc:load "gc-import-qifs.scm") (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 (begin
(get-all-types) (get-all-types)
(display "Account type list:") (display "Account type list:")
(display gnc:account-types) (display gnc:account-types)
(newline)) (newline))
(gnc:test-load account-group) ; This tries to create some accounts
(gnc:import-file-into-account-group account-group))))) (gnc:import-file-into-account-group account-group)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

118
src/scm/parseqif.scm
View File

@ -3,16 +3,26 @@
(define qif-txn-list '()) (define qif-txn-list '())
(define qif-txn-structure (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 (define thetxn
(build-mystruct-instance qif-txn-structure)) ((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 addresslist '())
(define (read-qif-file file account-group) (define (read-qif-file file account-group)
(set! qif-txn-list '()) ; Reset the transaction list... (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 (resetdates) ; Reset the date checker
(let* (let*
((infile (open-input-file file))) ((infile (open-input-file file)))
@ -38,11 +48,11 @@
(let* (let*
((qif-txn-list (read-qif-file file account-group)) ((qif-txn-list (read-qif-file file account-group))
(category-analysis (analyze-qif-transaction-categories qif-txn-list)) (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") 'replace))
; (outfile (open-output-file (string-append file ".XAC"))) (outfile (open-output-file (string-append file ".XAC")))
(write-to-output-thunk (write-to-output-thunk
(lambda (txn) (lambda (txn)
(write (cdr (txn 'geteverything 'nil)) outfile) (write txn outfile)
(newline outfile)))) (newline outfile))))
(display (string-append ";;;; Data from " file) outfile) (display (string-append ";;;; Data from " file) outfile)
@ -69,27 +79,22 @@
(display ")") (display ")")
(newline) (newline)
(display "(define category-analysis '" outfile) (display "(define category-analysis '" outfile)
(for-each (lambda (x) (display "(" outfile) (hash-for-each (lambda (x)
(write (car x) outfile) (write x outfile)
(display " " outfile) (newline outfile))
(write ((cdr x) 'list 'all) outfile) category-analysis)
(display ")" outfile)
(newline outfile)) category-analysis)
(display ")" outfile) (display ")" outfile)
(display "(define category-analysis '") (display "(define category-analysis '")
(for-each (lambda (x) (hash-for-each (lambda (x)
(display "(") (write x)
(write (car x)) (newline))
(display " ") category-analysis)
(write ((cdr x) 'list 'all))
(display ")")
(newline)) category-analysis)
(display ")") (display ")")
(newline outfile) (newline outfile)
(close-output-port outfile))) (close-output-port outfile)))
(define (read-qiffile-line line) (define (read-qiffile-line line)
(display (string-append "Line:" line)) (newline) ; (display (string-append "Line:" line)) (newline)
(if (if
(char=? (string-ref line 0) #\!) ;;; Starts with a ! (char=? (string-ref line 0) #\!) ;;; Starts with a !
(newqifstate line)) ;;; Jump to a new state... (newqifstate line)) ;;; Jump to a new state...
@ -104,19 +109,16 @@
#f) ; do nothing with line #f) ; do nothing with line
(define (oops-new-command-type line) (define (oops-new-command-type line)
(write "Oops: New command type!") (display (string-append "Oops: New command type!" line))
(write line)) (newline))
(define (rewrite-txn-line line) (define (rewrite-txn-line line)
(let* (let*
((fchar (substring line 0 1)) ((fchar (string-ref line 0))
(found (lookup fchar trans-jumptable))) (found (hashv-ref trans-jumptable fchar)))
(if (if found
found (found line)
(let (oops-new-command-type line))))
((tfunction (cdr found)))
(tfunction line))
(oops-new-command-type line))))
;;;; At the end of a transaction, ;;;; At the end of a transaction,
;;;; Insert queued material into "thetxn" (such as splits, address) ;;;; Insert queued material into "thetxn" (such as splits, address)
@ -124,20 +126,21 @@
;;;; And then clear stateful variables. ;;;; And then clear stateful variables.
(define (end-of-transaction line) ; End of transaction (define (end-of-transaction line) ; End of transaction
(if (not (null? addresslist)) (if (not (null? addresslist))
(thetxn 'put 'addresslist addresslist)) (txnupdate thetxn 'addresslist addresslist))
(if splits? (if splits?
(begin (begin
(thetxn 'put 'splitslist splitlist) (txnupdate thetxn 'splitlist splitlist)
(ensure-split-adds-up) (ensure-split-adds-up)
(resetsplits))) (resetsplits)))
(set! qif-txn-list (cons thetxn qif-txn-list)) (set! qif-txn-list (cons thetxn qif-txn-list))
(set! addresslist '()) (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 ;;;;;;;;;;; Various "trans" functions for different
;;;;;;;;;;; sorts of QIF lines ;;;;;;;;;;; sorts of QIF lines
(define (transmemo line) (define (transmemo line)
(thetxn 'put 'memo (strip-qif-header line))) (txnupdate thetxn 'memo (strip-qif-header line)))
(define (transaddress line) (define (transaddress line)
(set! addresslist (cons (strip-qif-header line) addresslist))) (set! addresslist (cons (strip-qif-header line) addresslist)))
@ -146,7 +149,7 @@
(let* (let*
((date (replacespace0 (strip-qif-header line))) ((date (replacespace0 (strip-qif-header line)))
(dpieces (split-on-somechar date #\/))) (dpieces (split-on-somechar date #\/)))
(thetxn 'put 'date date) (txnupdate thetxn 'date date)
(newdatemaxes dpieces))) ; collect info on date field ordering (newdatemaxes dpieces))) ; collect info on date field ordering
; so we can guess the date format at ; so we can guess the date format at
; the end based on what the population ; the end based on what the population
@ -162,45 +165,44 @@
numeric ; did the conversion succeed? numeric ; did the conversion succeed?
numeric ; Yup. Return the value numeric ; Yup. Return the value
amount-as-string))) ; Nope. Return the original 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) (define (transid line)
(thetxn 'put 'id (strip-qif-header line))) (txnupdate thetxn 'id (strip-qif-header line)))
(define (transstatus line) (define (transstatus line)
(thetxn 'put 'status (strip-qif-header line))) (txnupdate thetxn 'status (strip-qif-header line)))
(define (transpayee line) (define (transpayee line)
(thetxn 'put 'payee (strip-qif-header line))) (txnupdate thetxn 'payee (strip-qif-header line)))
(define (transcategory 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* (let*
((ltable ((ltable
'(("^" end-of-transaction) '((#\^ end-of-transaction)
("D" transdate) (#\D transdate)
("T" transamt) (#\T transamt)
("N" transid) (#\N transid)
("C" transstatus) (#\C transstatus)
("P" transpayee) (#\P transpayee)
("L" transcategory) (#\L transcategory)
("M" transmemo) (#\M transmemo)
("!" transnull) (#\! transnull)
("U" transnull) (#\U transnull)
("S" transsplitcategory) (#\S transsplitcategory)
("A" transaddress) (#\A transaddress)
("$" transsplitamt) (#\$ transsplitamt)
("%" transsplitpercent) (#\% transsplitpercent)
("E" transsplitmemo))) (#\E transsplitmemo)))
(setter (setter
(lambda (lst) (lambda (lst)
(let ((command (car lst)) (let ((command (car lst))
(function (eval (cadr lst)))) (function (eval (cadr lst))))
(set! trans-jumptable (hashv-set! trans-jumptable command function)))))
(lookup-set! trans-jumptable command function))))))
(for-each setter ltable)) (for-each setter ltable))
(display "trans-jumptable") (display "trans-jumptable")

16
src/scm/path.scm
View File

@ -10,10 +10,10 @@
(case item (case item
((default) ((default)
(list (list
(string-append (getenv "HOME") "/.gnucash/doc") (build-path (getenv "HOME") ".gnucash" "doc")
(string-append gnc:_share-dir-default_ "/Docs/En") (build-path gnc:_share-dir-default_ "Docs" "En")
(string-append gnc:_share-dir-default_ "/Docs") (build-path gnc:_share-dir-default_ "Docs")
(string-append gnc:_share-dir-default_ "/Reports"))) (build-path gnc:_share-dir-default_ "Reports")))
((current) ((current)
(gnc:config-var-value-get gnc:*doc-path*)) (gnc:config-var-value-get gnc:*doc-path*))
(else (else
@ -32,9 +32,9 @@
(gnc:debug "loading user configuration") (gnc:debug "loading user configuration")
(let ((user-file (let ((user-file
(string-append (getenv "HOME") "/.gnucash/config.user")) (build-path (getenv "HOME") ".gnucash" "config.user"))
(auto-file (auto-file
(string-append (getenv "HOME") "/.gnucash/config.auto"))) (build-path (getenv "HOME") ".gnucash" "config.auto")))
(if (access? user-file F_OK) (if (access? user-file F_OK)
(if (false-if-exception (primitive-load user-file)) (if (false-if-exception (primitive-load user-file))
@ -60,9 +60,9 @@
(begin (begin
(gnc:debug "loading system configuration") (gnc:debug "loading system configuration")
(let ((system-config (string-append (let ((system-config (build-path
(gnc:config-var-value-get gnc:*config-dir*) (gnc:config-var-value-get gnc:*config-dir*)
"/config"))) "config")))
(if (false-if-exception (primitive-load system-config)) (if (false-if-exception (primitive-load system-config))
(set! system-config-loaded? #t) (set! system-config-loaded? #t)

137
src/scm/qif2gc.scm
View File

@ -6,71 +6,94 @@
;;; address of the object. This way the object can be maintained ;;; address of the object. This way the object can be maintained
;;; on both sides of the Lisp<==>C boundary ;;; on both sides of the Lisp<==>C boundary
;;; For instance: ;;; 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 gnc-account-structure
(define-mystruct '(id name flags type code description (make-record-type "gnucash-account-structure"
notes currency security splitlist '(id name flags type code description
parentaccountgroup notes currency security splitlist
childrenaccountgroup))) 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 gnc-account-group-structure
(define-mystruct '(parentaccount peercount (make-record-type "gnucash-account-group-structure"
peerlist))) '(parentaccount peercount
peerlist)))
(define gnc-txn-structure (define gnc-txn-structure
(define-mystruct '(num date-posted date-entered description (make-record-type "gnucash-txn-structure"
docref splitlist))) '(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 gnc-split-structure
(define-mystruct '(memo action reconcile-state (make-record-type "gnucash-split-structure"
reconciled-date docref share-amount '(memo action reconcile-state
share-price account parenttransaction))) reconciled-date docref share-amount
share-price account parenttransaction)))
(define gnc-txn-list (initialize-lookup)) (define (gnc-split-update split field value)
(define gnc-acc-list (initialize-lookup)) ((record-modifier gnc-split-structure field) split value))
(define gnc-split-list (initialize-lookup))
(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 (add-qif-transaction-to-gnc-lists txn curtxn cursplitlist accountname)
(define txnref (gensym)) (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 ;;; Fill in gnc-txn-list, gnc-acc-list, gnc-split-list
;;; First, let's fill in curtxn with some values from txn ;;; First, let's fill in curtxn with some values from txn
(curtxn 'put 'num (txn 'get 'id)) (gnc-txn-update curtxn 'num (txn 'get 'id))
(curtxn 'put 'date-posted (txn 'get 'date)) (gnc-txn-update curtxn 'date-posted (txn 'get 'date))
(curtxn 'put 'date-entered '(1999 0903)) ;;; Which should get replaced! (gnc-txn-update curtxn 'date-entered '(1999 0903)) ;;; Which should get replaced!
(curtxn 'put 'description (txn 'get 'memo)) (gnc-txn-update curtxn 'description (txn 'get 'memo))
(curtxn 'put 'docref (txn 'get 'id)) (gnc-txn-update curtxn 'docref (txn 'get 'id))
;;; Now, set up the list of splits... ;;; Now, set up the list of splits...
(let ((mainref (gensym)) (let ((mainref (gensym))
(mainsplit (build-mystruct-instance gnc-split-structure))) (mainsplit ((record-constructor gnc-split-structure)
(mainsplit 'put 'memo (txn 'get 'memo)) #f #f #f #f #f #f #f #f #f)))
(mainsplit 'put 'share-amount (txn 'get 'amount)) (gnc-split-update mainsplit 'memo (txnget txn 'memo))
(mainsplit 'put 'reconcile-state (txn 'get 'status)) (gnc-split-update mainsplit 'share-amount (txnget txn 'amount))
(mainsplit 'put 'reconciled-date (gnc-split-update mainsplit 'reconcile-state (txnget txn 'status))
(if (string=? (txn 'get 'date) "*") (gnc-split-update mainsplit 'reconciled-date
'(1999 09 03) #f)) (if (string=? (txnget txn 'date) "*")
(mainsplit 'put 'docref (txn 'get 'id)) '(1999 09 03) #f))
(mainsplit 'put 'parenttransaction txnref) (gnc-split-update mainsplit 'docref (txnget txn 'id))
(mainsplit 'put 'account accountname) (gnc-split-update mainsplit 'parenttransaction txnref)
(set! gnc-split-list (lookup-set! gnc-split-list mainref mainsplit))) (gnc-split-update mainsplit 'account accountname)
(hashv-set! gnc-split-list mainref mainsplit))
;;;; Chunk of missing code: ;;;; 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 ;;;; 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 ;;;; ---> 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) (define (qif-to-gnucash txnlist accountname)
(letrec (letrec
((curtxn (build-mystruct-instance gnc-txn-structure)) ((curtxn ((record-constructor gnc-txn-structure) #f #f #f #f #f #f))
(cursplitlist (initialize-lookup)) (cursplitlist (initialize-hashtable 19)) ;;; Doesn't need to be large
(process-txn (lambda (x) (add-qif-transaction-to-gnc-lists x curtxn cursplitlist accountname)))) (process-txn (lambda (x)
(add-qif-transaction-to-gnc-lists
x curtxn cursplitlist accountname))))
(for-each process-txn txnlist))) (for-each process-txn txnlist)))
; QIF essentially provides a structure that sort of looks like ; 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 ; - Add each split to the account-to-splits list for the account
(define (initialize-split) ;;; Returns a gnc-split-structure (define (initialize-split) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:split-create)) (let ((ptr (gnc:split-create))
(splitstruct (build-mystruct-instance gnc-split-structure))) (splitstruct ((record-constructor gnc-split-structure)
(splitstruct 'put 'gncpointer ptr) #f #f #f #f #f #f #f #f #f)))
(gnc-split-structure splitstruct 'gncpointer ptr)
splitstruct)) splitstruct))
(define (gnc:set-split-values q-txn q-split) (define (gnc:set-split-values q-txn q-split)
@ -154,31 +178,32 @@
(define (initialize-account) ;;; Returns a gnc-split-structure (define (initialize-account) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:malloc-account)) (let ((ptr (gnc:malloc-account))
(accstruct (build-mystruct-instance gnc-account-structure))) (accstruct ((record-constructor gnc-account-structure)
(accstruct 'put 'gncpointer ptr) #f #f #f #f #f #f #f #f #f #f #f #f)))
(gnc-account-update accstruct 'gncpointer ptr)
accstruct)) accstruct))
(define (initialize-txn) ;;; Returns a gnc-split-structure (define (initialize-txn) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:transaction-create)) (let ((ptr (gnc:transaction-create))
(txnstruct (build-mystruct-instance gnc-transaction-structure))) (txnstruct ((record-constructor gnc-transaction-structure)
(txnstruct 'put 'gncpointer ptr) #f #f #f #f #f #f)))
(gnc-account-update txnstruct 'gncpointer ptr)
txnstruct)) txnstruct))
(if testing? (if testing?
(begin (begin
(display "need test scripts in qif2gc.scm"))) (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) (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) (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) (define (improve-qif-to-gnc-translation qif gnc)
(set! qif-to-gnc-acct-xlation-table (hashv-set! qif-to-gnc-acct-xlation-table
(lookup-set! qif-to-gnc-acct-xlation-table qif gnc))
qif gnc)))

44
src/scm/qifcats.scm
View File

@ -1,23 +1,27 @@
;;; $Id$ ;;; $Id$
;;;;; Category management ;;;;; Category management
(define qif-cat-list (initialize-lookup)) (define qif-cat-list (initialize-hashtable))
(define qif-category-structure (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-categories)
(define (analyze-qif-category item) (define (analyze-qif-category item)
(let* (let*
((id (car item)) ((id (car item))
(q (cdr 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))) (positive? (<= 0 (q 'get 'amount)))
(balance-sheet? (char=? (string-ref id 0) #\[)) (balance-sheet? (char=? (string-ref id 0) #\[))
(propername (if balance-sheet? (propername (if balance-sheet?
(substring 1 (- (string-length id) 1)) (substring 1 (- (string-length id) 1))
id))) id)))
(gc 'put 'type (gnc-account-update gc 'type
(if positive? (if positive?
(if balance-sheet? (if balance-sheet?
'BANK 'BANK
@ -25,19 +29,19 @@
(if balance-sheet? (if balance-sheet?
'INCOME 'INCOME
'EXPENSE))) 'EXPENSE)))
(gc 'put 'description id) (gnc-account-update gc 'description id)
(gc 'put 'currency favorite-currency))) (gnc-account-update gc 'currency favorite-currency)))
(set! qif-analysis (initialize-lookup)) (set! qif-analysis (initialize-hashtable))
(for-each analyze-qif-category qif-category-list)) (for-each analyze-qif-category qif-category-list))
(define (analyze-qif-transaction-categories qif-txn-list) (define (analyze-qif-transaction-categories qif-txn-list)
(define (analyze-qif-txn-category txn) (define (analyze-qif-txn-category txn)
(collect-cat-stats (txn 'get 'category) (collect-cat-stats (txnget txn 'category)
(txn 'get 'amount)) (txnget txn 'amount))
(let ((splits (txn 'get 'splitlist))) (let ((splits (txnget txn 'splitlist)))
(if splits (if splits
(for-each analyze-qif-split-category 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) (for-each analyze-qif-txn-category qif-txn-list)
qif-cat-list) qif-cat-list)
@ -45,14 +49,16 @@
(collect-cat-stats (split 'get 'category) (split 'get 'amount))) (collect-cat-stats (split 'get 'category) (split 'get 'amount)))
(define (collect-cat-stats category 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? (if s ;;; Did we find it in qif-cat-list?
(let ((sc (cdr s))) (let ((sc (cdr s)))
(sc 'put 'value (+ amount (sc 'get 'value))) (qif-category-update sc 'value (+ amount (sc 'get 'value)))
(sc 'put 'count (+ 1 (sc 'get 'count)))) (qif-category-update sc 'count (+ 1 (sc 'get 'count))))
(begin ;;; Nope; need to add new entry to qif-cat-list (begin ;;; Nope; need to add new entry to qif-cat-list
(let ((nc (build-mystruct-instance qif-category-structure))) (let ((nc ((record-constructor qif-category-structure) #f #f #f)))
(nc 'put 'name category) (qif-category-update nc 'name category)
(nc 'put 'count 1) (qif-category-update nc 'count 1)
(nc 'put 'value amount) (qif-category-update nc 'value amount)
(set! qif-cat-list (lookup-set! qif-cat-list category nc))))))) (hashv-set! qif-cat-list category nc))))))

54
src/scm/qifstate.scm
View File

@ -1,4 +1,55 @@
;;; $Id$ ;;; $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 qifstate #f)
(define (newqifstate line) (define (newqifstate line)
@ -21,7 +72,8 @@
(set! qifstate (cdr statepair)) (set! qifstate (cdr statepair))
(cdr statepair)) (cdr statepair))
(begin (begin
(display "No new QIF state") (newline))))) (display "No new QIF state") (newline)
#f))))
(testing "newqifstate" (testing "newqifstate"
"!Account" "!Account"

68
src/scm/qifutils.scm
View File

@ -192,70 +192,34 @@
first) first)
first)))) first))))
(define (shorten-to-best keep-top-n picklist) (define (shorten-to-best! keep-top-n picklist)
(let ((shortened '())) (let ((shortened '()))
(let loop ((count keep-top-n)) (let loop ((count keep-top-n))
(if (> count 0) (if (= count 0) ;;; No room left...
(let shortened ;;; Return the present short list
((bestitem (find-min-cdr picklist))) (let ((bestitem (find-min-cdr picklist)))
(if bestitem (if bestitem
(begin (begin
(if (> 99 (cdr bestitem)) (if (> 9999 (cdr bestitem))
(set! shortened (cons (car bestitem) shortened))) (set! shortened (cons (car bestitem) shortened)))
(set-cdr! bestitem 999) ;;;; Force off list... (set-cdr! bestitem 999999)
(loop (- count 1))))))) (loop (- count 1)))))))))
shortened))
;;;; Test shorten-to-best: ;;;; Test shorten-to-best:
(if testing? (if testing?
(let (let
((alist '((a . 10) (b . 15) (c . 20) (d . 12) (e . 7)))) ((alist '((a . 10) (b . 15) (c . 20) (d . 12) (e . 7))))
(testing "shorten-to-best 3" (testing "shorten-to-best! 3"
alist alist
'(b c d) '(d a e)
(shorten-to-best 3 alist)))) (shorten-to-best! 3 alist))))
;;;; Simple lookup scheme; can be turned into a hash table If Need Be. ;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
;;; Initialize lookup table ;;; Initialize lookup table
(define (initialize-lookup) (define (initialize-hashtable . size)
'()) (make-vector
(if (null? size)
(define (lookup key list) ;;; Returns (key . value) 313
(assoc key list)) (car size))
'()))
(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))))

42
src/scm/samp.scm Normal file
View 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)

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

@ -6,9 +6,16 @@
(define splits? #f) (define splits? #f)
(define splitlist '()) (define splitlist '())
(define qif-split-structure (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 ;;;; ;;;; And functions to nuke out the splits ;;;;
@ -17,15 +24,18 @@
(define (resetsplits) ;;; Do this at end of whole txn (define (resetsplits) ;;; Do this at end of whole txn
(set! splits? #f) (set! splits? #f)
(set! splitlist '()) (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 ;;;; This function *should* validate that a split adds up to
;;;; the same value as the transaction, and gripe if it's not. ;;;; 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. ;;;; I'm not sure how to usefully gripe, so I leave this as a stub.
(define (ensure-split-adds-up) (define (ensure-split-adds-up)
(let* (let*
((txnamount (thetxn 'get 'amount)) ((txnamount (txnget thetxn 'amount))
(find-amount (lambda (splitstructure) (splitstructure 'get '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 (total-of-split
(apply + (map find-amount splitlist)))) (apply + (map find-amount splitlist))))
(if (if
@ -44,11 +54,11 @@
(define (transsplitamt line) (define (transsplitamt line)
(set! splits? #T) (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 ;;; And now, add amount and memo to splitlist
(display (thesplit 'what 'what)) (newline) ; (display (thesplit 'what 'what)) (newline)
(set! splitlist (cons thesplit splitlist)) (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 ;;;; percentages only occur as parts of memorized transactions
(define (transsplitpercent line) (define (transsplitpercent line)
@ -57,8 +67,8 @@
(define (transsplitmemo line) (define (transsplitmemo line)
(set! splits? #T) (set! splits? #T)
(thesplit 'put 'memo (strip-qif-header line))) (qif-split-update thesplit 'memo (strip-qif-header line)))
(define (transsplitcategory line) (define (transsplitcategory line)
(set! splits? #T) (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
View 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'

4
src/scm/utilities.scm
View File

@ -18,7 +18,7 @@
(if (not (or (string=? item ".") (if (not (or (string=? item ".")
(string=? item ".."))) (string=? item "..")))
(let* ((full-path (string-append dir-name "/" item))) (let* ((full-path (build-path dir-name item)))
;; ignore symlinks, etc. ;; ignore symlinks, etc.
(if (access? full-path F_OK) (if (access? full-path F_OK)
(let* ((status (lstat full-path)) (let* ((status (lstat full-path))
@ -41,7 +41,7 @@ string and 'directories' must be a list of strings."
(result #f)) (result #f))
((or (null? rest) finished?) result) ((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) (gnc:debug " checking for " file-name)
(if (access? file-name F_OK) (if (access? file-name F_OK)
(begin (begin