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

More work on GUIDs. Removed src/scm cruft.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2294 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2000-05-11 02:57:33 +00:00
parent 96e312fd44
commit e40f406d3a
25 changed files with 95 additions and 1593 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
ChangeLog
View File

@ -1,5 +1,10 @@
2000-05-10 Dave Peticolas <peticola@cs.ucdavis.edu>
* src/engine/GNCId.c (xaccRemoveEntity): don't allow the NULL id
to be removed.
* src/scm: remove some old, unused files.
* src/register/splitreg.c (configLayout): swap mirrored xfer from
and xfer to field in the transaction line of the ledgers.

13
src/engine/Account.c
View File

@ -227,6 +227,19 @@ xaccAccountGetGUID (Account *account)
return &account->guid;
}
/********************************************************************\
\********************************************************************/
void xaccAccountSetGUID (Account *account, GUID *guid)
{
if (!account || !guid) return;
xaccRemoveEntity(&account->guid);
account->guid = *guid;
xaccStoreEntity(account, &account->guid, GNC_ID_ACCOUNT);
}
/********************************************************************\
\********************************************************************/
Account *

7
src/engine/AccountP.h
View File

@ -160,7 +160,6 @@ struct _account {
* it should be immediately destroyed, or it should be inserted into
* an account.
*/
void xaccAccountRemoveSplit (Account *, Split *);
/* the following recompute the partial balances (stored with the
@ -175,6 +174,12 @@ void xaccAccountRecomputeBalances (Account **);
void xaccAccountRecomputeCostBasis (Account *);
/* Set the account's GUID. This should only be done when reading
* an account from a datafile, or some other external source. Never
* call this on an existing account! */
void xaccAccountSetGUID (Account *account, GUID *guid);
/** GLOBALS *********************************************************/
extern int next_free_unique_account_id;

15
src/engine/GNCId.c
View File

@ -29,6 +29,10 @@
#include "GNCIdP.h"
/** #defines ********************************************************/
#define GNCID_DEBUG 0
/** Type definitions ************************************************/
typedef struct entity_node
{
@ -247,8 +251,9 @@ xaccStoreEntity(void * entity, const GUID * guid, GNCIdType entity_type)
void
xaccRemoveEntity(const GUID * guid)
{
gpointer e_node;
EntityNode *e_node;
gpointer old_guid;
gpointer node;
if (guid == NULL)
return;
@ -256,9 +261,13 @@ xaccRemoveEntity(const GUID * guid)
if (entity_table == NULL)
entity_table_init();
if (g_hash_table_lookup_extended(entity_table, guid, &old_guid, &e_node))
if (g_hash_table_lookup_extended(entity_table, guid, &old_guid, &node))
{
e_node = node;
if (e_node->entity_type == GNC_ID_NULL)
return;
g_hash_table_remove(entity_table, old_guid);
entity_node_destroy(old_guid, e_node, NULL);
entity_node_destroy(old_guid, node, NULL);
}
}

13
src/engine/Group.c
View File

@ -155,6 +155,19 @@ xaccGroupGetGUID (AccountGroup *group)
return &group->guid;
}
/********************************************************************\
\********************************************************************/
void xaccGroupSetGUID (AccountGroup *group, GUID *guid)
{
if (!group || !guid) return;
xaccRemoveEntity(&group->guid);
group->guid = *guid;
xaccStoreEntity(group, &group->guid, GNC_ID_GROUP);
}
/********************************************************************\
\********************************************************************/
AccountGroup *

7
src/engine/GroupP.h
View File

@ -58,4 +58,11 @@ struct _account_group {
double balance;
};
/* Set the group's GUID. This should only be done when reading
* a group from a datafile, or some other external source. Never
* call this on an existing group! */
void xaccGroupSetGUID (AccountGroup *group, GUID *guid);
#endif /* __XACC_ACCOUNT_GROUP_P_H__ */

27
src/engine/Transaction.c
View File

@ -201,6 +201,19 @@ xaccSplitGetGUID (Split *split)
return &split->guid;
}
/********************************************************************\
\********************************************************************/
void xaccSplitSetGUID (Split *split, GUID *guid)
{
if (!split || !guid) return;
xaccRemoveEntity(&split->guid);
split->guid = *guid;
xaccStoreEntity(split, &split->guid, GNC_ID_SPLIT);
}
/********************************************************************\
\********************************************************************/
Split *
@ -504,6 +517,20 @@ xaccTransGetGUID (Transaction *trans)
return &trans->guid;
}
/********************************************************************\
\********************************************************************/
void xaccTransSetGUID (Transaction *trans, GUID *guid)
{
if (!trans || !guid) return;
xaccRemoveEntity(&trans->guid);
trans->guid = *guid;
xaccStoreEntity(trans, &trans->guid, GNC_ID_TRANS);
}
/********************************************************************\
\********************************************************************/
Transaction *

10
src/engine/TransactionP.h
View File

@ -180,6 +180,16 @@ struct _transaction
};
/* Set the transaction's GUID. This should only be done when reading
* a transaction from a datafile, or some other external source. Never
* call this on an existing transaction! */
void xaccTransSetGUID (Transaction *trans, GUID *guid);
/* Set the split's GUID. This should only be done when reading
* a split from a datafile, or some other external source. Never
* call this on an existing split! */
void xaccSplitSetGUID (Split *split, GUID *guid);
/* The xaccFreeTransaction() method simply frees all memory associated
* with the transaction. It does not perform any consistency checks
* to verify that such freeing can be safely done. (e.g. id does

154
src/scm/acc-create.scm
View File

@ -1,154 +0,0 @@
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;;; 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)))
(if (gnc:debugging?)
(begin
(display (account-type->number 'INCOME))
(newline)))
(define (gnc:get-incomes-list account-group)
(if (gnc:debugging?)
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 (gnc:debugging?)
(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 (gnc:debugging?)
(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 (gnc:debugging?)
(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!!! ;;;;;;;;;;;;
(if (gnc:debugging?)
(begin
(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))

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

13
src/scm/engine-interface.scm
View File

@ -63,7 +63,8 @@
(record-accessor gnc:split-structure 'share-price))
;; This function take a C split and returns a representation
;; of it as a split-structure.
;; of it as a split-structure. Assumes the transaction is open
;; for editing.
(define (gnc:split->split-scm split)
(gnc:make-split-scm
(gnc:split-get-guid split)
@ -77,16 +78,6 @@
(gnc:split-get-share-amount split)
(gnc:split-get-share-price split)))
;; gnc:split-copy is a form of gnc:split->split-scm used by C routines.
;; It stores the split in an internal variable so C can safely register
;; it before it gets garbage collected.
(define gnc:copy-split #f)
(let ((last-split #f))
(set! gnc:copy-split
(lambda (split)
(set! last-split (gnc:split->split-scm split))
last-split)))
;; Copy a scheme representation of a split onto a C split.
;; If possible, insert the C split into the account of the
;; scheme split. Not all values are copied. The reconcile

3
src/scm/macros.scm
View File

@ -1,3 +0,0 @@
;;; Macros to conditionally define various things.

286
src/scm/qifs/dates-qif.scm
View File

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

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

@ -1,35 +0,0 @@
;;; $Id$
(gnc:support "qifs/gc-import-qifs.scm")
(gnc:depend "qifs/qifcats.scm")
(gnc:depend "qifs/qif2gc.scm")
(display "Started gc-impor.scm")
(newline)
(define (gnc:get-account-list account-group)
(if testing?
gc-accts
(let ((fullacclist
(flatten
(gnc:group-map-accounts get-names-of-accounts
account-group))))
(display "acclist:")
(display fullacclist)
(newline)
(filteroutnulls fullacclist))))
(define (gnc:import-file-into-account-group account-group)
;(sample-dialog)
(let ((file-name
(gnc:file-selection-dialog "Select file for QIF import" "*.qif")))
(if file-name
(begin
(gnc:debug "Loading data from file " file-name)
(let* ((txn-list (read-qif-file file-name account-group))
(category-analysis (analyze-qif-transaction-categories txn-list)))
;;; Now, take steps:
(qif-to-gnucash txn-list file-name)
(list txn-list category-analysis))))))
;;; Set up QIF Category

106
src/scm/qifs/guess-category-qif.scm
View File

@ -1,106 +0,0 @@
;;; $Id$
(gnc:support "qifs/guess-category-qif.scm")
(gnc:depend "substring-search.scm")
;;; Need a bunch of metrics, and probably to vectorize this...
;;; 1. Braces --> pick gnucash entries from account list
;;; No braces --> pick gnucash entries from category list
;;; 2. Exact match of names -->
;;; 3. a contains b, b contains a --> end of list
;;; 4. First 2 letters match --> end of list
;;; 5. First letter matches --> end of list
;;; 6. I'd like a "similarity match" of some sort
;;; 7. Is it in old-matches? If so, toss that to front of list.
;;; Lastly, shorten the list to no more than 4 items.
(define (guess-gnucash-category
inputcat gc-income-categories gc-account-categories)
(let*
((picklist (initialize-hashtable))
(qifname (inputcat 'get 'name))
(catlength (string-length (qifname)))
(is-acct? (and
(>= catlength 2)
(string=? (substring inputcat 0 1) "[")
(string=? (substring inputcat
(- catlength 1) catlength) "]")))
(netdebit? (< (inputcat 'get 'value)))
(acctlist ; Pick either gc-income-categories/gc-account-categories
(if
is-acct?
gc-account-categories
gc-income-categories))
(incat (if is-acct?
(substring inputcat 1 (- catlength 1))
inputcat))
(add-to-picklist
(lambda (string value)
(hashv-set! picklist string value)))
(match-against-list
(lambda (itemstring)
(if (string=? itemstring incat) ;;; Exact match
(add-to-picklist itemstring 1))
(if (or ((substring-search-maker incat) itemstring) ;;; Inclusion
((substring-search-maker itemstring) incat))
(add-to-picklist itemstring 3))
(if (string=?
(substring incat 0
(min 2 (string-length incat))) ;; Match first 2 chars
(substring itemstring 0 (min 2 (string-length itemstring))) )
(add-to-picklist itemstring 5))
(if (string=?
(substring incat 0
(min 1 (string-length incat)));; Match first 1 char
(substring itemstring 0 (min 1 (string-length itemstring))))
(add-to-picklist itemstring 7)))))
;;;;;;;; Now, apply the matching...
(for-each match-against-list acctlist)
;;;;;;;; Shorten picklist, keeping top 4 items
(shorten-to-best 4 picklist)))
(define (guess-corresponding-categories
import-categories
gc-income-categories gc-account-categories)
(define apply-guess-category
(lambda (incat)
(list incat
(guess-gnucash-category (car incat)
gc-income-categories
gc-account-categories))))
(map apply-guess-category import-categories))
;;; Make use of "old-matches," which is an association list
;;; containing the correspondences that have been used previously.
;;; These are almost sure-fire "best matches"
;;;;; (define best-guesses
;;;;; (guess-corresponding-categories
;;;;; kept-categories categories-from-gnucash))
;;;;;
;;;;; The next step would be to ask the user to verify the category
;;;;; matching, thus establishing an association list to be used to
;;;;; translate from QIF to GnuCash. This alist should be merged with
;;;;; whatever is out on disk from "last time," and will become
;;;;; "old-matches" to provide a high quality set of "best guesses"
;;;;; for next time.
;;;;; (define (fix-category-translation best-guesses))
;;;;; which is used thus:
;;;;; (define category-translations (fix-category-translation
;;;;; best-guesses))
;;;;; category-translations is then an alist that is then used to pick
;;;;; off categories for use thus:
;;;;; (let ((use-category (assoc (assoc 'category transaction)
;;;;; category-translations))
;;;;; (date (assoc 'date transaction))
;;;;; (amount (assoc 'amount transaction)))
;;;;; (add-transaction use-category date amount)
;;;;;
(define (guess-results account-group kept-categories)
(guess-corresponding-categories
kept-categories
(gnc:get-incomes-list account-group)
(gnc:get-account-list account-group)))

91
src/scm/qifs/importqif.scm
View File

@ -1,91 +0,0 @@
;;; $Id$
;;; Import QIF File
(gnc:support "importqif.scm")
(gnc:depend "qifs/gc-import-qifs.scm")
(define testing? #f) ;;; Should we do testing?
(define favorite-currency "USD") ;;;; This may need to change...
(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 account import.")
(begin
(display "account-group:")
(display account-group) (newline)
(let ((loadfun (lambda (x) (gnc:load (string-append "qifs/" 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 (string-append "qifs/" x))))
(loadlist '("testbed.scm" "analytical-qifs.scm"
"gc-import-qifs.scm" "qifutils.scm"
"acc-create.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 (string-append "qifs/" x))))
(loadlist '("testbed.scm"
"qifutils.scm" "dates-qif.scm"
"acc-create.scm"
"txn-create.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:import-file-into-account-group account-group)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; Now, let's actually execute the code...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;(for-each process-possible-qif-file indir)
;;;;; Open Issues:
;;;;;
;;;;; - What account do we load into?
;;;;; 1. Hopefully this can be determined in an implicit manner...
;;;;; 2. The alternative is that something interactive must be done for
;;;;; a group of transactions, querying the user to select the appropriate
;;;;; account.
;;;;;

220
src/scm/qifs/parseqif.scm
View File

@ -1,220 +0,0 @@
;;; $Id$
(require 'hash-table)
(gnc:support "qifs/parseqif.scm")
(gnc:depend "qifs/qifcats.scm")
(gnc:depend "qifs/dates-qif.scm")
(gnc:depend "qifs/gc-import-qifs.scm")
(gnc:depend "qifs/qifstate.scm")
(gnc:depend "qifs/split-qif.scm")
(gnc:depend "qifs/guess-category-qif.scm")
(define qif-txn-list '())
(define qif-txn-structure
(make-record-type
"qif-txn"
'(memo date id payee addresslist amount status category splitlist)))
(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 ((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)))
(let loop
((line (read-line infile)))
(if
(eof-object? line) #f
(let
((newline (read-qiffile-line line)))
(loop (read-line infile)))))
(if
(checkdatemaxes)
#f ;;; Do nothing; all is ok
(begin
(display "Problem with dating - ambiguous data!")
(newline)))
;;; Now, return results:
qif-txn-list))
(define (process-qif-file file account-group)
; Opens file, rewrites all the lines, closes files
(display (string-append "rewriting file:" file)) (newline)
(let*
((qif-txn-list (read-qif-file file account-group))
(category-analysis (analyze-qif-transaction-categories qif-txn-list))
; (outfile (open-output-file (string-append file ".XAC") 'replace))
(outfile (open-output-file (string-append file ".XAC")))
(write-to-output-thunk
(lambda (txn)
(write txn outfile)
(newline outfile))))
(display (string-append ";;;; Data from " file) outfile)
(newline outfile)
(newline outfile)
(display ";;; Transactional data:" outfile)
(newline outfile)
(display "(define transactions '(" outfile)
(newline outfile)
(for-each write-to-output-thunk qif-txn-list)
(display (string-append
"Total transactions: "
(number->string (length qif-txn-list))))
(newline)
(display ")) ;;; End of transaction data" outfile)
(newline outfile)
(newline outfile)
(display "(define acclist")
(display (gnc:get-account-list account-group))
(display ")")
(newline)
(display "(define acclist")
(display (gnc:get-incomes-list account-group))
(display ")")
(newline)
(display "(define category-analysis '" outfile)
(hash-for-each (lambda (key value)
(write key outfile)
(write value outfile)
(newline outfile))
category-analysis)
(display ")" outfile)
(display "(define category-analysis '")
(hash-for-each (lambda (key value)
(write key)
(write value)
(newline))
category-analysis)
(display ")")
(newline outfile)
(close-output-port outfile)))
(define (read-qiffile-line line)
; (display (string-append "Line:" line)) (newline)
(if
(char=? (string-ref line 0) #\!) ;;; Starts with a !
(newqifstate line)) ;;; Jump to a new state...
(cond
((eq? qifstate 'txn) ;;; If it's a transaction
(rewrite-txn-line (striptrailingwhitespace line)))
(else
(display "Ignoring non-transaction:") (display qifstate)(newline))))
(define (transnull line)
#f) ; do nothing with line
(define (oops-new-command-type line)
(display (string-append "Oops: New command type!" line))
(newline))
(define (rewrite-txn-line line)
(let*
((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)
;;;; Add "thetxn" to the master list of transactions,
;;;; And then clear stateful variables.
(define (end-of-transaction line) ; End of transaction
(if (not (null? addresslist))
(txnupdate thetxn 'addresslist addresslist))
(if splits?
(begin
(txnupdate thetxn 'splitlist splitlist)
(ensure-split-adds-up)
(resetsplits)))
(set! qif-txn-list (cons thetxn qif-txn-list))
(set! addresslist '())
(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)
(txnupdate thetxn 'memo (strip-qif-header line)))
(define (transaddress line)
(set! addresslist (cons (strip-qif-header line) addresslist)))
(define (transdate line)
(let*
((date (replacespace0 (strip-qif-header line)))
(dpieces (split-on-somechar 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
; looks like
(define (transamt line)
(define (numerizeamount amount-as-string)
(let*
((commasplit (split-on-somechar amount-as-string #\,))
(decommaed (apply string-append commasplit))
(numeric (string->number decommaed)))
(if
numeric ; did the conversion succeed?
numeric ; Yup. Return the value
amount-as-string))) ; Nope. Return the original value.
(txnupdate thetxn 'amount (numerizeamount (strip-qif-header line))))
(define (transid line)
(txnupdate thetxn 'id (strip-qif-header line)))
(define (transstatus line)
(txnupdate thetxn 'status (strip-qif-header line)))
(define (transpayee line)
(txnupdate thetxn 'payee (strip-qif-header line)))
(define (transcategory line)
(txnupdate thetxn 'category (strip-qif-header line)))
(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)))
(setter
(lambda (lst)
(let ((command (car lst))
(function (eval (cadr lst))))
(hashv-set! trans-jumptable command function)))))
(for-each setter ltable))
(display "trans-jumptable")
(display trans-jumptable)
(newline)

211
src/scm/qifs/qif2gc.scm
View File

@ -1,211 +0,0 @@
;;; $Id$
(gnc:support "qifs/qif2gc.scm")
(gnc:depend "qifs/guess-category-qif.scm")
;;;; Take the set of stuff from a QIF file, and turn it into the
;;;; structures expected by GnuCash.
;;; In each of these, "gncpointer" should be populated with the
;;; address of the object. This way the object can be maintained
;;; on both sides of the Lisp<==>C boundary
;;; For instance:
(define gnc-account-structure
(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
(make-record-type "gnucash-account-group-structure"
'(parentaccount peercount
peerlist)))
(define gnc-txn-structure
(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
(make-record-type "gnucash-split-structure"
'(memo action reconcile-state
reconciled-date docref share-amount
share-price account parenttransaction)))
(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))
(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
(gnc-txn-update curtxn 'num (txnget txn 'id))
(gnc-txn-update curtxn 'date-posted (txnget txn 'date))
(gnc-txn-update curtxn 'date-entered '(1999 0903)) ;;; Which should get replaced!
(gnc-txn-update curtxn 'description (txnget txn 'memo))
(gnc-txn-update curtxn 'docref (txnget txn 'id))
;;; Now, set up the list of splits...
(let ((mainref (gensym))
(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 (txnget txn 'splitlist)
;;;; Add a split for each one of these
;;;; Alternatively, add a split for (txnget txn 'category)
;;;; ---> Attach all the accounts to the corresponding splits
(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 ((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
; (chequing
; (deposit 500 salary)
; (withdraw 300 rent)
; (transfer 200 mastercard))
; Asset account
; --> Bunch of transactions, implicitly associated with it
; --> That are also associated with income/expense accounts
; This must be transformed to something more like:
;;; Account points to vector of splits, each split points to a transaction
; Accounts look like:
; ('chequing
; (500 'chequing 'deposit)
; (-300 'chequing 'withdraw)
; (-200 'chequing 'transfer))
; ('mastercard
; (200 'mastercard 'transfer))
; ('salary
; (-500 'salary 'deposit))
; ('rent
; (-500 'rent 'withdraw))
; Transactions look like:
; ('deposit
; (500 'chequing 'deposit)
; (-500 'salary 'deposit))
; (withdraw
; (-300 'chequing 'withdraw)
; (-500 'rent 'withdraw))
; (transfer
; (200 'mastercard 'transfer)
; (-200 'chequing 'transfer))
; And the splits are the subordinates in both cases...
;;; Thus, the approach should be:
; -- For each QIF transaction QT
; -- Create transaction
; -- Construct the splits for the current transaction
; If there's no QIF split, then there's two:
; - One for the [current account]
; - Offset by the [category]
; Alternatively:
; - One for the [current account]
; - Offset by the set of QIF split items
; - Link splits to transaction
; - Link transaction to split list
; - Link each splits to appropriate account
; - Add each split to the account-to-splits list for the account
(define (initialize-split) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:split-create))
(splitstruct ((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)
(let ((g:split (initialize-split))
(g:memo (gnc-split-get q-split 'memo))
(g:amount (gnc-split-get q-split 'amount))
(g:docref (gnc-split-get q-split 'id))
(g:action (txnget q-txn 'status)))
(if g:amount (gnc:split-set-value g:split g:amount))
(if g:memo (gnc:split-set-memo g:split g:memo))
(if g:action (gnc:split-set-action g:split g:action))
(if g:docref (gnc:split-set-docref g:split g:docref))))
(define (gnc:link-split-to-parents g:split g:account g:transaction)
(gnc:transaction-append-split g:transaction g:split)
(gnc:account-insert-split g:account g:split))
(define (initialize-account) ;;; Returns a gnc-split-structure
(let ((ptr (gnc:malloc-account))
(accstruct ((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 ((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-hashtable 19)) ;; Need not be a big list
(define (add-best-guess qif gnc)
(hashv-set! best-guesses qif gnc))
(define (find-best-guess qif)
(hashv-ref qif best-guesses))
(define qif-to-gnc-acct-xlation-table (initialize-hashtable))
(define (improve-qif-to-gnc-translation qif gnc)
(hashv-set! qif-to-gnc-acct-xlation-table
qif gnc))

68
src/scm/qifs/qifcats.scm
View File

@ -1,68 +0,0 @@
;;; $Id$
;;;;; Category management
(gnc:support "qifs/qifcats.scm")
(define qif-cat-list (initialize-hashtable))
(define qif-category-structure
(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 (qif-category-get cat field)
((record-accessor qif-category-structure field) cat))
(define (analyze-qif-categories)
(define (analyze-qif-category item)
(let*
((id (car item))
(q (cdr item))
(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)))
(gnc-account-update gc 'type
(if positive?
(if balance-sheet?
'BANK
'CREDIT)
(if balance-sheet?
'INCOME
'EXPENSE)))
(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 (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-hashtable))
(for-each analyze-qif-txn-category qif-txn-list)
qif-cat-list)
(define (analyze-qif-split-category split)
(collect-cat-stats (qif-split-get split 'category)
(qif-split-get split 'amount)))
(define (collect-cat-stats category amount)
(let* ((s (hash-ref qif-cat-list category)))
(if s ;;; Did we find it in qif-cat-list?
(begin ;;; Yes; found an existing entry so update it's attributes
(qif-category-update s 'value (+ amount (qif-category-get s 'value)))
(qif-category-update s 'count (+ 1 (qif-category-get s 'count))))
(begin ;;; Nope; need to add new entry to qif-cat-list
(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)
(hash-set! qif-cat-list category nc))))))

93
src/scm/qifs/qifstate.scm
View File

@ -1,93 +0,0 @@
;;; $Id$
(gnc:support "qifs/qifstate.scm")
;;;;; - 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)
(let*
((QIFstates
'(("!Type:Cat" . category)
("!Type:Class" . class) ;;; Additional classification feature
("!Option:AutoSwitch" . accounts)
("!Clear:AutoSwitch" . accounts)
("!Account" . accounts)
("!Type:Memorized" . memorized)
("!Type:Bank" . txn)
("!Type:CCard" . txn)
("!Type:Oth A" . txn)))
(name (striptrailingwhitespace line))
(statepair (assoc name QIFstates)))
(if (pair? statepair)
(begin
(display "New qifstate:") (display (cdr statepair))
(newline)
(set! qifstate (cdr statepair))
(cdr statepair))
(begin
(display "No new QIF state") (newline)
#f))))
(testing "newqifstate"
"!Account"
'accounts
(newqifstate "!Account"))
(testing "newqifstate"
"!Type:Cat "
'category
(newqifstate "!Type:Cat"))
(testing "newqifstate"
"nothing"
#f
(newqifstate "nothing"))

138
src/scm/qifs/qifutils.scm
View File

@ -1,138 +0,0 @@
;;; $Id$
(gnc:support "qifs/qifutils.scm")
(gnc:depend "utilities.scm")
(define (strip-qif-header line)
(substring line 1 (string-length line)))
;;; Check amount to see if it's:
;;; a) "European" where one separates thousands using a period, and
;;; the decimal is represented via a comma, or if this be
;;; b) "American" where commas indicate groupings of digits, and
;;; decimal is a "."
(define (thousands-separator numstring)
(define findcomma (substring-search-maker ","))
(define findperiod (substring-search-maker "."))
(let
((firstcomma (findcomma numstring))
(firstperiod (findperiod numstring)))
(cond
((not firstcomma) ;; No commas found
#\,)
((not firstperiod) ;; No periods found
#\.)
((> firstperiod firstcomma) ;; First comma before first period
#\,)
((< firstperiod firstcomma) ;; First comma after first period
#\.)
(else #f))))
(if testing?
(begin
(let ((num "1,234,56.78"))
(testing "thousands-separator"
num
#\,
(thousands-separator num)))
(let ((num "1 234 56,78"))
(testing "thousands-separator"
num
#\.
(thousands-separator num)))
(let ((num "1 234 56.78"))
(testing "thousands-separator"
num
#\,
(thousands-separator num)))
(let ((num ".78"))
(testing "thousands-separator"
num
#\,
(thousands-separator num)))
(let ((num ""))
(testing "thousands-separator"
num
#\,
(thousands-separator num)))
(let ((num "1.234.56,78"))
(testing "thousands-separator"
num
#\.
(thousands-separator num)))))
(define (numerizeamount amount-as-string)
(let*
(
;;; First, chop out spaces
(spacesplit (split-on-somechar amount-as-string #\space))
(despaced (apply string-append spacesplit))
;;; Second, separate based on #\, or #\.
(curr-separator (thousands-separator despaced))
(decimal-separator (if (char=? curr-separator #\,)
#\.
#\,))
(trio-split (split-on-somechar despaced curr-separator))
;;; Reform into a string
(without-trios (apply string-append trio-split))
;;; Now, split on decimal separator...
(decimal-split (split-on-somechar without-trios
decimal-separator))
(rejoin-decimal (string-join decimal-split "."))
;;; Lastly, convert to a number
(numeric (string->number rejoin-decimal)))
(if
numeric ; did the conversion succeed?
numeric ; Yup. Return the value
amount-as-string))) ; Nope. Return the original value.
(if testing?
(begin
(let ((num " 1,234,56.78"))
(testing "numerizeamount"
num
123456.78
(numerizeamount num)))
(let ((num "1 .2 34.5 6,78"))
(testing "numerizeamount"
num
123456.78
(numerizeamount num)))))
(define (find-min-cdr mlist)
(if
(null? mlist)
#f
(let
((first (car mlist))
(rest (find-min-cdr (cdr mlist))))
(if
rest ;;; Found a value for rest
(if (> (cdr first) (cdr rest))
rest
first)
first))))
(define (shorten-to-best! keep-top-n picklist)
(let ((shortened '()))
(let loop ((count keep-top-n))
(if (= count 0) ;;; No room left...
shortened ;;; Return the present short list
(let ((bestitem (find-min-cdr picklist)))
(if bestitem
(begin
(if (> 9999 (cdr bestitem))
(set! shortened (cons (car bestitem) 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"
alist
'(d a e)
(shorten-to-best! 3 alist))))

80
src/scm/qifs/split-qif.scm
View File

@ -1,80 +0,0 @@
;;; $Id$
;;;;;;;;;;; QIF Split Management ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Variables used to handle splits ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(gnc:support "qifs/split-qif.scm")
(gnc:depend "structure.scm")
(define splits? #f)
(define splitlist '())
(define qif-split-structure
(make-record-type "qif-split-structure"
'(category memo amount percent)))
(define (qif-split-update split field value)
((record-modifier qif-split-structure field) split value))
(define (qif-split-get split field)
((record-accessor qif-split-structure field) split))
(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 ;;;;
;;;; at the start/end of each transaction ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (resetsplits) ;;; Do this at end of whole txn
(set! splits? #f)
(set! splitlist '())
(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 (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
(< (abs (- txnamount total-of-split)) 0.01) ; Difference tiny
#t ;;; OK - adds up to near enough zero.
(begin ;;; Problem: Doesn't add up
(display
(string-append "Error - Transaction amount, "
(number->string txnamount)
" not equal to sum of split amount, "
(number->string total-of-split)))
(newline)
(display splitlist)
(newline)
#f))))
(define (transsplitamt line)
(set! splits? #T)
(qif-split-update thesplit 'amount (numerizeamount (strip-qif-header line)))
;;; And now, add amount and memo to splitlist
; (display (thesplit 'what 'what)) (newline)
(set! splitlist (cons thesplit splitlist))
(set! thesplit (create-qif-split-structure)))
;;;; percentages only occur as parts of memorized transactions
(define (transsplitpercent line)
(set! splits? #T)
#f) ;;;; Do nothing; percentages only occur in memorized transactions
(define (transsplitmemo line)
(set! splits? #T)
(qif-split-update thesplit 'memo (strip-qif-header line)))
(define (transsplitcategory line)
(set! splits? #T)
(qif-split-update thesplit 'category (strip-qif-header line)))

2
src/scm/startup.scm
View File

@ -24,7 +24,6 @@
(if gnc:*load-slib-backup*
(gnc:load "slib-backup.scm"))
(gnc:load "macros.scm")
(gnc:load "config-var.scm")
(gnc:load "utilities.scm")
(gnc:load "path.scm")
@ -33,6 +32,5 @@
(gnc:load "options.scm")
(gnc:load "prefs.scm")
(gnc:load "command-line.scm")
(gnc:load "convenience-wrappers.scm")
(gnc:load "hooks.scm")
(gnc:load "main.scm")

82
src/scm/txn-create.scm
View File

@ -1,82 +0,0 @@
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
(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)

9
src/scm/utilities.scm
View File

@ -109,12 +109,3 @@ string and 'directories' must be a list of strings."
(car lst))
(else
""))))
;;;; Simple lookup scheme; can be turned into a hash table If Need Be.
;;; Initialize lookup table
(define (initialize-hashtable . size)
(make-vector
(if (null? size)
313
(car size))
'()))