mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
More work on GUIDs. Removed src/scm cruft.
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2294 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
parent
96e312fd44
commit
e40f406d3a
@ -1,5 +1,10 @@
|
|||||||
2000-05-10 Dave Peticolas <peticola@cs.ucdavis.edu>
|
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
|
* src/register/splitreg.c (configLayout): swap mirrored xfer from
|
||||||
and xfer to field in the transaction line of the ledgers.
|
and xfer to field in the transaction line of the ledgers.
|
||||||
|
|
||||||
|
|||||||
@ -227,6 +227,19 @@ xaccAccountGetGUID (Account *account)
|
|||||||
return &account->guid;
|
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 *
|
Account *
|
||||||
|
|||||||
@ -160,7 +160,6 @@ struct _account {
|
|||||||
* it should be immediately destroyed, or it should be inserted into
|
* it should be immediately destroyed, or it should be inserted into
|
||||||
* an account.
|
* an account.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
void xaccAccountRemoveSplit (Account *, Split *);
|
void xaccAccountRemoveSplit (Account *, Split *);
|
||||||
|
|
||||||
/* the following recompute the partial balances (stored with the
|
/* the following recompute the partial balances (stored with the
|
||||||
@ -175,6 +174,12 @@ void xaccAccountRecomputeBalances (Account **);
|
|||||||
void xaccAccountRecomputeCostBasis (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 *********************************************************/
|
/** GLOBALS *********************************************************/
|
||||||
|
|
||||||
extern int next_free_unique_account_id;
|
extern int next_free_unique_account_id;
|
||||||
|
|||||||
@ -29,6 +29,10 @@
|
|||||||
#include "GNCIdP.h"
|
#include "GNCIdP.h"
|
||||||
|
|
||||||
|
|
||||||
|
/** #defines ********************************************************/
|
||||||
|
#define GNCID_DEBUG 0
|
||||||
|
|
||||||
|
|
||||||
/** Type definitions ************************************************/
|
/** Type definitions ************************************************/
|
||||||
typedef struct entity_node
|
typedef struct entity_node
|
||||||
{
|
{
|
||||||
@ -247,8 +251,9 @@ xaccStoreEntity(void * entity, const GUID * guid, GNCIdType entity_type)
|
|||||||
void
|
void
|
||||||
xaccRemoveEntity(const GUID * guid)
|
xaccRemoveEntity(const GUID * guid)
|
||||||
{
|
{
|
||||||
gpointer e_node;
|
EntityNode *e_node;
|
||||||
gpointer old_guid;
|
gpointer old_guid;
|
||||||
|
gpointer node;
|
||||||
|
|
||||||
if (guid == NULL)
|
if (guid == NULL)
|
||||||
return;
|
return;
|
||||||
@ -256,9 +261,13 @@ xaccRemoveEntity(const GUID * guid)
|
|||||||
if (entity_table == NULL)
|
if (entity_table == NULL)
|
||||||
entity_table_init();
|
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);
|
g_hash_table_remove(entity_table, old_guid);
|
||||||
entity_node_destroy(old_guid, e_node, NULL);
|
entity_node_destroy(old_guid, node, NULL);
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|||||||
@ -155,6 +155,19 @@ xaccGroupGetGUID (AccountGroup *group)
|
|||||||
return &group->guid;
|
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 *
|
AccountGroup *
|
||||||
|
|||||||
@ -58,4 +58,11 @@ struct _account_group {
|
|||||||
double balance;
|
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__ */
|
#endif /* __XACC_ACCOUNT_GROUP_P_H__ */
|
||||||
|
|||||||
@ -201,6 +201,19 @@ xaccSplitGetGUID (Split *split)
|
|||||||
return &split->guid;
|
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 *
|
Split *
|
||||||
@ -504,6 +517,20 @@ xaccTransGetGUID (Transaction *trans)
|
|||||||
return &trans->guid;
|
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 *
|
Transaction *
|
||||||
|
|||||||
@ -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
|
/* The xaccFreeTransaction() method simply frees all memory associated
|
||||||
* with the transaction. It does not perform any consistency checks
|
* with the transaction. It does not perform any consistency checks
|
||||||
* to verify that such freeing can be safely done. (e.g. id does
|
* to verify that such freeing can be safely done. (e.g. id does
|
||||||
|
|||||||
@ -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))
|
|
||||||
@ -63,7 +63,8 @@
|
|||||||
(record-accessor gnc:split-structure 'share-price))
|
(record-accessor gnc:split-structure 'share-price))
|
||||||
|
|
||||||
;; This function take a C split and returns a representation
|
;; 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)
|
(define (gnc:split->split-scm split)
|
||||||
(gnc:make-split-scm
|
(gnc:make-split-scm
|
||||||
(gnc:split-get-guid split)
|
(gnc:split-get-guid split)
|
||||||
@ -77,16 +78,6 @@
|
|||||||
(gnc:split-get-share-amount split)
|
(gnc:split-get-share-amount split)
|
||||||
(gnc:split-get-share-price 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.
|
;; Copy a scheme representation of a split onto a C split.
|
||||||
;; If possible, insert the C split into the account of the
|
;; If possible, insert the C split into the account of the
|
||||||
;; scheme split. Not all values are copied. The reconcile
|
;; scheme split. Not all values are copied. The reconcile
|
||||||
|
|||||||
@ -1,3 +0,0 @@
|
|||||||
|
|
||||||
;;; Macros to conditionally define various things.
|
|
||||||
|
|
||||||
@ -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))))
|
|
||||||
|
|
||||||
|
|
||||||
@ -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
|
|
||||||
|
|
||||||
|
|
||||||
@ -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)))
|
|
||||||
@ -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.
|
|
||||||
;;;;;
|
|
||||||
|
|
||||||
@ -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)
|
|
||||||
@ -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))
|
|
||||||
@ -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))))))
|
|
||||||
|
|
||||||
@ -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"))
|
|
||||||
@ -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))))
|
|
||||||
|
|
||||||
@ -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)))
|
|
||||||
@ -24,7 +24,6 @@
|
|||||||
(if gnc:*load-slib-backup*
|
(if gnc:*load-slib-backup*
|
||||||
(gnc:load "slib-backup.scm"))
|
(gnc:load "slib-backup.scm"))
|
||||||
|
|
||||||
(gnc:load "macros.scm")
|
|
||||||
(gnc:load "config-var.scm")
|
(gnc:load "config-var.scm")
|
||||||
(gnc:load "utilities.scm")
|
(gnc:load "utilities.scm")
|
||||||
(gnc:load "path.scm")
|
(gnc:load "path.scm")
|
||||||
@ -33,6 +32,5 @@
|
|||||||
(gnc:load "options.scm")
|
(gnc:load "options.scm")
|
||||||
(gnc:load "prefs.scm")
|
(gnc:load "prefs.scm")
|
||||||
(gnc:load "command-line.scm")
|
(gnc:load "command-line.scm")
|
||||||
(gnc:load "convenience-wrappers.scm")
|
|
||||||
(gnc:load "hooks.scm")
|
(gnc:load "hooks.scm")
|
||||||
(gnc:load "main.scm")
|
(gnc:load "main.scm")
|
||||||
|
|||||||
@ -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)
|
|
||||||
@ -109,12 +109,3 @@ string and 'directories' must be a list of strings."
|
|||||||
(car lst))
|
(car lst))
|
||||||
(else
|
(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))
|
|
||||||
'()))
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user