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

Merge branch 'maint'

Browse Source
This commit is contained in:
Christopher Lam 2019-08-04 13:44:12 +08:00
commit 5bd854c550
38 changed files with 1516 additions and 1321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gnucash/gnome/gnc-plugin-page-account-tree.c
View File

@ -146,6 +146,7 @@ static void gnc_plugin_page_account_tree_cmd_delete_account (GtkAction *action,
static void gnc_plugin_page_account_tree_cmd_renumber_accounts (GtkAction *action, GncPluginPageAccountTree *page);
static void gnc_plugin_page_account_tree_cmd_view_filter_by (GtkAction *action, GncPluginPageAccountTree *plugin_page);
static void gnc_plugin_page_account_tree_cmd_reconcile (GtkAction *action, GncPluginPageAccountTree *page);
static void gnc_plugin_page_account_tree_cmd_refresh (GtkAction *action, GncPluginPageAccountTree *page);
static void gnc_plugin_page_account_tree_cmd_autoclear (GtkAction *action, GncPluginPageAccountTree *page);
static void gnc_plugin_page_account_tree_cmd_transfer (GtkAction *action, GncPluginPageAccountTree *page);
static void gnc_plugin_page_account_tree_cmd_stock_split (GtkAction *action, GncPluginPageAccountTree *page);
@ -253,6 +254,11 @@ static GtkActionEntry gnc_plugin_page_account_tree_actions [] =
"ViewFilterByAction", NULL, N_("_Filter By..."), NULL, NULL,
G_CALLBACK (gnc_plugin_page_account_tree_cmd_view_filter_by)
},
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"),
G_CALLBACK (gnc_plugin_page_account_tree_cmd_refresh)
},
/* Actions menu */
{
@ -1656,6 +1662,18 @@ gnc_plugin_page_account_tree_cmd_renumber_accounts (GtkAction *action,
gnc_account_renumber_create_dialog(window, account);
}
static void
gnc_plugin_page_account_tree_cmd_refresh (GtkAction *action,
GncPluginPageAccountTree *page)
{
GncPluginPageAccountTreePrivate *priv;
g_return_if_fail(GNC_IS_PLUGIN_PAGE_ACCOUNT_TREE(page));
priv = GNC_PLUGIN_PAGE_ACCOUNT_TREE_GET_PRIVATE(page);
gtk_widget_queue_draw (priv->widget);
}
/*********************/
static void

22
gnucash/gnome/gnc-plugin-page-budget.c
View File

@ -117,6 +117,8 @@ static void gnc_plugin_page_budget_cmd_estimate_budget(
GtkAction *action, GncPluginPageBudget *page);
static void gnc_plugin_page_budget_cmd_allperiods_budget(
GtkAction *action, GncPluginPageBudget *page);
static void gnc_plugin_page_budget_cmd_refresh (
GtkAction *action, GncPluginPageBudget *page);
static GtkActionEntry gnc_plugin_page_budget_actions [] =
{
@ -165,6 +167,11 @@ static GtkActionEntry gnc_plugin_page_budget_actions [] =
"ViewFilterByAction", NULL, N_("_Filter By..."), NULL, NULL,
G_CALLBACK (gnc_plugin_page_budget_cmd_view_filter_by)
},
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"),
G_CALLBACK (gnc_plugin_page_budget_cmd_refresh)
},
};
@ -1145,3 +1152,18 @@ gnc_plugin_page_budget_cmd_view_filter_by (GtkAction *action,
LEAVE(" ");
}
static void
gnc_plugin_page_budget_cmd_refresh (GtkAction *action,
GncPluginPageBudget *page)
{
GncPluginPageBudgetPrivate *priv;
g_return_if_fail (GNC_IS_PLUGIN_PAGE_BUDGET(page));
ENTER("(action %p, page %p)", action, page);
priv = GNC_PLUGIN_PAGE_BUDGET_GET_PRIVATE(page);
gnc_budget_view_refresh (priv->budget_view);
LEAVE(" ");
}

22
gnucash/gnome/gnc-plugin-page-invoice.c
View File

@ -69,6 +69,7 @@ static void gnc_plugin_page_invoice_cmd_edit (GtkAction *action, GncPluginPageIn
static void gnc_plugin_page_invoice_cmd_duplicateInvoice (GtkAction *action, GncPluginPageInvoice *plugin_page);
static void gnc_plugin_page_invoice_cmd_post (GtkAction *action, GncPluginPageInvoice *plugin_page);
static void gnc_plugin_page_invoice_cmd_unpost (GtkAction *action, GncPluginPageInvoice *plugin_page);
static void gnc_plugin_page_invoice_cmd_refresh (GtkAction *action, GncPluginPageInvoice *plugin_page);
static void gnc_plugin_page_invoice_cmd_sort_changed (GtkAction *action,
GtkRadioAction *current,
@ -147,6 +148,13 @@ static GtkActionEntry gnc_plugin_page_invoice_actions [] =
G_CALLBACK (gnc_plugin_page_invoice_cmd_unpost)
},
/* View menu */
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"),
G_CALLBACK (gnc_plugin_page_invoice_cmd_refresh)
},
/* Actions menu */
{
"RecordEntryAction", "list-add", N_("_Enter"), NULL,
@ -853,6 +861,20 @@ gnc_plugin_page_invoice_cmd_sort_changed (GtkAction *action,
LEAVE(" ");
}
static void
gnc_plugin_page_invoice_cmd_refresh (GtkAction *action,
GncPluginPageInvoice *plugin_page)
{
GncPluginPageInvoicePrivate *priv;
g_return_if_fail(GNC_IS_PLUGIN_PAGE_INVOICE(plugin_page));
ENTER("(action %p, plugin_page %p)", action, plugin_page);
priv = GNC_PLUGIN_PAGE_INVOICE_GET_PRIVATE(plugin_page);
gtk_widget_queue_draw (priv->widget);
LEAVE(" ");
}
static void
gnc_plugin_page_invoice_cmd_enter (GtkAction *action,

17
gnucash/gnome/gnc-plugin-page-owner-tree.c
View File

@ -123,6 +123,7 @@ static void gnc_plugin_page_owner_tree_cmd_edit_owner (GtkAction *action, GncPlu
static void gnc_plugin_page_owner_tree_cmd_delete_owner (GtkAction *action, GncPluginPageOwnerTree *page);
#endif
static void gnc_plugin_page_owner_tree_cmd_view_filter_by (GtkAction *action, GncPluginPageOwnerTree *page);
static void gnc_plugin_page_owner_tree_cmd_refresh (GtkAction *action, GncPluginPageOwnerTree *page);
static void gnc_plugin_page_owner_tree_cmd_new_invoice (GtkAction *action, GncPluginPageOwnerTree *page);
static void gnc_plugin_page_owner_tree_cmd_owners_report (GtkAction *action, GncPluginPageOwnerTree *plugin_page);
static void gnc_plugin_page_owner_tree_cmd_owner_report (GtkAction *action, GncPluginPageOwnerTree *plugin_page);
@ -181,6 +182,11 @@ static GtkActionEntry gnc_plugin_page_owner_tree_actions [] =
"ViewFilterByAction", NULL, N_("_Filter By..."), NULL, NULL,
G_CALLBACK (gnc_plugin_page_owner_tree_cmd_view_filter_by)
},
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"),
G_CALLBACK (gnc_plugin_page_owner_tree_cmd_refresh)
},
/* Business menu */
{
@ -1150,6 +1156,17 @@ gnc_plugin_page_owner_tree_cmd_view_filter_by (GtkAction *action,
LEAVE(" ");
}
static void
gnc_plugin_page_owner_tree_cmd_refresh (GtkAction *action,
GncPluginPageOwnerTree *page)
{
GncPluginPageOwnerTreePrivate *priv;
g_return_if_fail(GNC_IS_PLUGIN_PAGE_OWNER_TREE(page));
priv = GNC_PLUGIN_PAGE_OWNER_TREE_GET_PRIVATE(page);
gtk_widget_queue_draw (priv->widget);
}
static void
gnc_plugin_page_owner_tree_cmd_new_invoice (GtkAction *action,

29
gnucash/gnome/gnc-plugin-page-register.c
View File

@ -175,6 +175,7 @@ static void gnc_plugin_page_register_cmd_reinitialize_transaction (GtkAction *ac
static void gnc_plugin_page_register_cmd_expand_transaction (GtkToggleAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_exchange_rate (GtkAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_jump (GtkAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_reload (GtkAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_schedule (GtkAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_scrub_all (GtkAction *action, GncPluginPageRegister *plugin_page);
static void gnc_plugin_page_register_cmd_scrub_current (GtkAction *action, GncPluginPageRegister *plugin_page);
@ -349,6 +350,11 @@ static GtkActionEntry gnc_plugin_page_register_actions [] =
"ViewFilterByAction", NULL, N_("_Filter By..."), NULL, NULL,
G_CALLBACK (gnc_plugin_page_register_cmd_view_filter_by)
},
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"),
G_CALLBACK (gnc_plugin_page_register_cmd_reload)
},
/* Actions menu */
@ -4043,6 +4049,29 @@ gnc_plugin_page_register_cmd_view_filter_by (GtkAction *action,
LEAVE(" ");
}
static void
gnc_plugin_page_register_cmd_reload (GtkAction *action, GncPluginPageRegister *plugin_page)
{
GncPluginPageRegisterPrivate *priv;
SplitRegister *reg;
ENTER("(action %p, page %p)", action, plugin_page);
g_return_if_fail (GNC_IS_PLUGIN_PAGE_REGISTER (plugin_page));
priv = GNC_PLUGIN_PAGE_REGISTER_GET_PRIVATE (plugin_page);
reg = gnc_ledger_display_get_split_register (priv->ledger);
/* Check for trans being edited */
if (gnc_split_register_changed (reg))
{
LEAVE("register has pending edits");
return;
}
gnc_ledger_display_refresh (priv->ledger);
LEAVE(" ");
}
static void
gnc_plugin_page_register_cmd_style_changed (GtkAction *action,
GtkRadioAction *current,

19
gnucash/gnome/gnc-plugin-page-sx-list.c
View File

@ -127,6 +127,7 @@ static void gnc_plugin_page_sx_list_cmd_edit2(GtkAction *action, GncPluginPageSx
/*################## Added for Reg2 #################*/
#endif
static void gnc_plugin_page_sx_list_cmd_delete(GtkAction *action, GncPluginPageSxList *page);
static void gnc_plugin_page_sx_list_cmd_refresh (GtkAction *action, GncPluginPageSxList *page);
/* Command callbacks */
static GtkActionEntry gnc_plugin_page_sx_list_actions [] =
@ -160,6 +161,13 @@ static GtkActionEntry gnc_plugin_page_sx_list_actions [] =
"SxListDeleteAction", GNC_ICON_DELETE_ACCOUNT, N_("_Delete"), NULL,
N_("Delete the selected scheduled transaction"), G_CALLBACK(gnc_plugin_page_sx_list_cmd_delete)
},
/* View menu */
{
"ViewRefreshAction", "view-refresh", N_("_Refresh"), "<primary>r",
N_("Refresh this window"), G_CALLBACK (gnc_plugin_page_sx_list_cmd_refresh)
},
};
/** The number of actions provided by this plugin. */
static guint gnc_plugin_page_sx_list_n_actions = G_N_ELEMENTS (gnc_plugin_page_sx_list_actions);
@ -659,6 +667,17 @@ gnc_plugin_page_sx_list_cmd_new2 (GtkAction *action, GncPluginPageSxList *page)
/*################## Added for Reg2 #################*/
#endif
static void
gnc_plugin_page_sx_list_cmd_refresh (GtkAction *action, GncPluginPageSxList *page)
{
GncPluginPageSxListPrivate *priv;
g_return_if_fail (GNC_IS_PLUGIN_PAGE_SX_LIST(page));
priv = GNC_PLUGIN_PAGE_SX_LIST_GET_PRIVATE(page);
gtk_widget_queue_draw (priv->widget);
}
static void
_edit_sx(gpointer data, gpointer user_data)
{

14
gnucash/gnome/gnc-split-reg.c
View File

@ -2268,7 +2268,7 @@ gnc_split_reg_set_sort_reversed(GNCSplitReg *gsr, gboolean rev, gboolean refresh
gnc_ledger_display_refresh( gsr->ledger );
}
static void
static gboolean
gnc_split_reg_record (GNCSplitReg *gsr)
{
SplitRegister *reg;
@ -2282,7 +2282,7 @@ gnc_split_reg_record (GNCSplitReg *gsr)
if (!gnc_split_register_save (reg, TRUE))
{
LEAVE("no save");
return;
return FALSE;
}
gsr_emit_include_date_signal( gsr, xaccTransGetDate(trans) );
@ -2291,6 +2291,7 @@ gnc_split_reg_record (GNCSplitReg *gsr)
* since gui_refresh events should handle this. */
/* gnc_split_register_redraw (reg); */
LEAVE(" ");
return TRUE;
}
static gboolean
@ -2354,7 +2355,14 @@ gnc_split_reg_enter( GNCSplitReg *gsr, gboolean next_transaction )
}
/* First record the transaction. This will perform a refresh. */
gnc_split_reg_record( gsr );
if (!gnc_split_reg_record (gsr))
{
/* make sure the sheet has the focus if the record is FALSE
* which results in no cursor movement. */
gnc_split_reg_focus_on_sheet (gsr);
LEAVE(" ");
return;
}
if (!goto_blank && next_transaction)
gnc_split_register_expand_current_trans (sr, FALSE);

36
gnucash/gtkbuilder/dialog-import.glade
View File

@ -79,7 +79,7 @@
<property name="expand">False</property>
<property name="fill">False</property>
<property name="pack_type">end</property>
<property name="position">0</property>
<property name="position">4</property>
</packing>
</child>
<child>
@ -108,6 +108,20 @@
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkScrolledWindow" id="account_tree_sw">
<property name="visible">True</property>
<property name="can_focus">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkBox" id="placeholder_warning_hbox">
<property name="can_focus">False</property>
@ -143,22 +157,7 @@
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="pack_type">end</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkScrolledWindow" id="account_tree_sw">
<property name="visible">True</property>
<property name="can_focus">True</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">4</property>
<property name="position">3</property>
</packing>
</child>
</object>
@ -1283,9 +1282,6 @@
<property name="position">0</property>
</packing>
</child>
<child>
<placeholder/>
</child>
</object>
</child>
<action-widgets>

44
gnucash/import-export/bi-import/dialog-bi-import-gui.c
View File

@ -137,30 +137,30 @@ gnc_plugin_bi_import_showGUI (GtkWindow *parent)
column = gtk_tree_view_column_new_with_attributes (description, renderer, "text", column_id, NULL); \
gtk_tree_view_column_set_resizable (column, TRUE); \
gtk_tree_view_append_column (GTK_TREE_VIEW (gui->tree_view), column);
CREATE_COLUMN ("id", ID);
CREATE_COLUMN ("date__opened", DATE_OPENED);
CREATE_COLUMN ("owner__id", OWNER_ID);
CREATE_COLUMN ("billing__id", BILLING_ID);
CREATE_COLUMN ("notes", NOTES);
CREATE_COLUMN (_("id"), ID);
CREATE_COLUMN (_("date__opened"), DATE_OPENED);
CREATE_COLUMN (_("owner__id"), OWNER_ID);
CREATE_COLUMN (_("billing__id"), BILLING_ID);
CREATE_COLUMN (_("notes"), NOTES);
CREATE_COLUMN ("date", DATE);
CREATE_COLUMN ("desc", DESC);
CREATE_COLUMN ("action", ACTION);
CREATE_COLUMN ("account", ACCOUNT);
CREATE_COLUMN ("quantity", QUANTITY);
CREATE_COLUMN ("price", PRICE);
CREATE_COLUMN ("disc__type", DISC_TYPE);
CREATE_COLUMN ("disc__how", DISC_HOW);
CREATE_COLUMN ("discount", DISCOUNT);
CREATE_COLUMN ("taxable", TAXABLE);
CREATE_COLUMN ("taxincluded", TAXINCLUDED);
CREATE_COLUMN ("tax__table", TAX_TABLE);
CREATE_COLUMN (_("date"), DATE);
CREATE_COLUMN (_("desc"), DESC);
CREATE_COLUMN (_("action"), ACTION);
CREATE_COLUMN (_("account"), ACCOUNT);
CREATE_COLUMN (_("quantity"), QUANTITY);
CREATE_COLUMN (_("price"), PRICE);
CREATE_COLUMN (_("disc__type"), DISC_TYPE);
CREATE_COLUMN (_("disc__how"), DISC_HOW);
CREATE_COLUMN (_("discount"), DISCOUNT);
CREATE_COLUMN (_("taxable"), TAXABLE);
CREATE_COLUMN (_("taxincluded"), TAXINCLUDED);
CREATE_COLUMN (_("tax__table"), TAX_TABLE);
CREATE_COLUMN ("date__posted", DATE_POSTED);
CREATE_COLUMN ("due__date", DUE_DATE);
CREATE_COLUMN ("account__posted", ACCOUNT_POSTED);
CREATE_COLUMN ("memo__posted", MEMO_POSTED);
CREATE_COLUMN ("accu__splits", ACCU_SPLITS);
CREATE_COLUMN (_("date__posted"), DATE_POSTED);
CREATE_COLUMN (_("due__date"), DUE_DATE);
CREATE_COLUMN (_("account__posted"), ACCOUNT_POSTED);
CREATE_COLUMN (_("memo__posted"), MEMO_POSTED);
CREATE_COLUMN (_("accu__splits"), ACCU_SPLITS);
gui->component_id = gnc_register_gui_component ("dialog-bi-import-gui",
NULL,

3
gnucash/import-export/qif-imp/assistant-qif-import.c
View File

@ -1111,7 +1111,8 @@ gnc_ui_qif_import_convert_undo (QIFImportWindow * wind)
/* Undo the conversion. */
if (wind->imported_account_tree != SCM_BOOL_F)
gfec_apply (undo, wind->imported_account_tree, _gfec_error_handler);
gfec_apply (undo, scm_list_1 (wind->imported_account_tree),
_gfec_error_handler);
/* There's no imported account tree any more. */
scm_gc_unprotect_object (wind->imported_account_tree);

2
gnucash/import-export/qif-imp/qif-file.scm
View File

@ -569,7 +569,7 @@
(if (or (and (not acct-name)
(not security)
payee (string? payee)
(string=? (string-remove-trailing-space payee)
(string=? (string-trim-right payee)
"Opening Balance")
cat-is-acct?)
(and acct-name (string? acct-name)

12
gnucash/import-export/qif-imp/qif-guess-map.scm
View File

@ -39,6 +39,14 @@
(define GNC-RECEIVABLE-TYPE 11)
(define GNC-PAYABLE-TYPE 12)
(define (record-fields->list record)
(let ((type (record-type-descriptor record)))
(map
(lambda (field) ((record-accessor type field) record))
(record-type-fields type))))
(define (list->record-fields lst type)
(apply (record-constructor type) lst))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-import:load-map-prefs
@ -180,7 +188,7 @@
(let ((table '()))
(hash-fold
(lambda (key value p)
(set! table (cons (cons key (simple-obj-to-list value)) table))
(set! table (cons (cons key (record-fields->list value)) table))
#f) #f hashtab)
(write table)))
@ -192,7 +200,7 @@
(for-each
(lambda (entry)
(let ((key (car entry))
(value (simple-obj-from-list (cdr entry) <qif-map-entry>)))
(value (list->record-fields (cdr entry) <qif-map-entry>)))
;; If the account separator has changed, fix the account name.
(if changed-sep?

5
gnucash/import-export/qif-imp/qif-import.scm
View File

@ -30,9 +30,8 @@
;; We do this initialization here because src/gnome isn't a real module.
;; Note: Guile 2 needs to find the symbols from the extension at compile time already
(eval-when
(compile load eval expand)
(load-extension "libgnc-gnome" "scm_init_sw_gnome_module"))
(eval-when (compile load eval expand)
(load-extension "libgnc-gnome" "scm_init_sw_gnome_module"))
(use-modules (sw_gnome))

282
gnucash/import-export/qif-imp/qif-merge-groups.scm
View File

@ -32,24 +32,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-get-transactions root)
(let ((accounts (gnc-account-get-descendants-sorted root)))
(if (null? accounts)
'()
(let ((query (qof-query-create-for-splits))
(xtns #f))
(qof-query-set-book query (gnc-account-get-book root))
;; we want to find all transactions with every split inside the
;; account group.
(xaccQueryAddAccountMatch query accounts
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(set! xtns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ALL))
;; lose the query
(qof-query-destroy query)
xtns))))
(let ((q (qof-query-create-for-splits)))
(qof-query-set-book q (gnc-account-get-book root))
(xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(let ((xtns (xaccQueryGetTransactions q QUERY-TXN-MATCH-ALL)))
(qof-query-destroy q)
xtns))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:account-tree-find-duplicates
@ -70,174 +58,103 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:account-tree-find-duplicates old-root new-root progress-dialog)
(define old-accounts (gnc-account-get-descendants-sorted old-root))
(define (progress v)
(when progress-dialog (gnc-progress-dialog-set-value progress-dialog v)))
;; This procedure does all the work. We'll define it, then call it safely.
(define (private-find)
(cond
((any (compose pair? xaccAccountGetSplitList) old-accounts)
;; Get all the splits in the new tree, then iterate over them
;; trying to find matches in the old tree. If there are
;; matches, push the splits' parent onto a list.
(let ((WeekSecs (* 60 60 24 7)))
;; Given a list of accounts, this predicate returns true if any
;; of those accounts are involved in a transaction.
(define (has-any-xtns? acctlist)
(if (null? acctlist)
#f
(let ((splits (xaccAccountGetSplitList (car acctlist))))
(if (null? splits)
(has-any-xtns? (cdr acctlist))
#t))))
(define new-splits
(let ((q (qof-query-create-for-splits))
(accounts (gnc-account-get-descendants-sorted new-root)))
(qof-query-set-book q (gnc-account-get-book new-root))
(xaccQueryAddAccountMatch q accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(let ((new-splits (qof-query-run q)))
(qof-query-destroy q)
new-splits)))
(define old-splits
(let ((q (qof-query-create-for-splits))
(dates (map (compose xaccTransGetDate xaccSplitGetParent) new-splits)))
(qof-query-set-book q (gnc-account-get-book old-root))
(xaccQueryAddAccountMatch q old-accounts QOF-GUID-MATCH-ANY QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q
#t (decdate (apply min dates) WeekDelta)
#t (incdate (apply max dates) WeekDelta)
QOF-QUERY-AND)
(let ((splits (qof-query-run q)))
(qof-query-destroy q)
splits)))
(let ((old-accounts (gnc-account-get-descendants-sorted old-root)))
(if (has-any-xtns? old-accounts)
;; Get all the transactions in the new tree, then iterate over them
;; trying to find matches in the old tree. If there are matches,
;; push the matches onto a list.
(let* ((new-xtns (gnc:account-tree-get-transactions new-root))
(work-to-do (length new-xtns))
(work-done 0)
(matches '()))
(define work-to-do (length new-splits))
(define (update-progress work-done)
(when (and progress-dialog (zero? (modulo work-done 8)))
(progress (/ work-done work-to-do))
(qif-import:check-pause progress-dialog)
(if qif-import:canceled (throw 'cancel))))
;; This procedure handles progress reporting, pause, and cancel.
(define (update-progress)
(set! work-done (+ 1 work-done))
(if (and progress-dialog
(zero? (remainder work-done 8)))
(begin
(gnc-progress-dialog-set-value progress-dialog
(/ work-done work-to-do))
(qif-import:check-pause progress-dialog)
(if qif-import:canceled
(throw 'cancel)))))
(when progress-dialog
(gnc-progress-dialog-set-sub progress-dialog
(_ "Finding duplicate transactions")))
(if progress-dialog
(gnc-progress-dialog-set-sub progress-dialog
(_ "Finding duplicate transactions")))
;; For each transaction in the new account tree, build a query
;; that matches possibly duplicate transactions in the old tree.
(for-each
(lambda (xtn)
(let ((query (qof-query-create-for-splits))
(num-splits 0))
(qof-query-set-book query (gnc-account-get-book old-root))
;; First, we only want to find only transactions
;; from accounts in the old tree.
(xaccQueryAddAccountMatch query
old-accounts
QOF-GUID-MATCH-ANY QOF-QUERY-AND)
;; The date should be close to the same.. +/- a week.
(let ((date (xaccTransGetDate xtn)))
(xaccQueryAddDateMatchTT query
#t (decdate date WeekDelta)
#t (incdate date WeekDelta)
QOF-QUERY-AND))
;; For each split in the new transaction, add a
;; term that can match on its properties.
(let ((q-splits (qof-query-create-for-splits)))
(for-each
(lambda (split)
(set! num-splits (+ num-splits 1))
(let ((sq (qof-query-create-for-splits)))
(qof-query-set-book sq (gnc-account-get-book old-root))
;; Require a match on the account name. If the name
;; doesn't exist in the old tree (indicating a new
;; account), the match will be NULL and the query
;; won't find anything. Optimize this later.
(xaccQueryAddSingleAccountMatch
sq
(gnc-account-lookup-by-full-name old-root
(gnc-account-get-full-name
(xaccSplitGetAccount split)))
QOF-QUERY-AND)
;; Require the value of the split in the new tree
;; to match the the value of the split in the old
;; tree. We should really check for fuzziness.
(xaccQueryAddValueMatch sq
(xaccSplitGetValue split)
QOF-NUMERIC-MATCH-ANY
QOF-COMPARE-EQUAL
QOF-QUERY-AND)
;; Now merge into the split query. Reminder: q-splits
;; must be merged with an OR. Otherwise, nothing will
;; match. (For example, something can be equal to 4 or
;; to -4, but not both.)
(let ((q-new (qof-query-merge q-splits
sq
QOF-QUERY-OR)))
(qof-query-destroy q-splits)
(qof-query-destroy sq)
(set! q-splits q-new))))
(xaccTransGetSplitList xtn))
;; Now q-splits will find every split that is the same as
;; any one split of the new-root transaction. Merge it in.
(let ((q-new (qof-query-merge query
q-splits
QOF-QUERY-AND)))
(qof-query-destroy query)
(qof-query-destroy q-splits)
(set! query q-new)))
;; Now that we have built a query that finds matching splits
;; in the old tree, run it and build a list of transactions
;; from the results.
;;
;; If the transaction from the new tree has more than two
;; splits, then we'll assume that it fully reflects what
;; occurred, and only consider transactions in the old tree
;; that match with every single split.
;;
;; All other new transactions could be incomplete, so we'll
;; consider transactions from the old tree to be possible
;; duplicates even if only one split matches.
;;
;; For more information, see bug 481528.
(let ((old-xtns (xaccQueryGetTransactions
query
(if (> num-splits 2)
QUERY-TXN-MATCH-ALL
QUERY-TXN-MATCH-ANY))))
;; Turn the resulting list of possibly duplicated
;; transactions into an association list.
(set! old-xtns (map
(lambda (elt)
(cons elt #f)) old-xtns))
;; If anything matched the query, add it to our "matches"
;; association list, keyed by the new-root transaction.
(if (not (null? old-xtns))
(set! matches (cons (cons xtn old-xtns) matches))))
(qof-query-destroy query))
(update-progress))
new-xtns)
;; Finished.
(if progress-dialog
(gnc-progress-dialog-set-value progress-dialog 1))
;; Return the matches.
(let loop ((new-splits new-splits)
(work-done 0)
(matches '()))
(cond
((null? new-splits)
(progress 1)
matches)
;; Since there are either no accounts or no transactions in the old
;; tree, duplicate checking is unnecessary.
(begin
;; Finished.
(if progress-dialog
(gnc-progress-dialog-set-value progress-dialog 1))
((assoc (xaccSplitGetParent (car new-splits)) matches)
;; txn has already been matched, by another split within same txn
(loop (cdr new-splits)
(1+ work-done)
matches))
;; Return an empty list.
'()))))
(else
(let* ((new-split (car new-splits))
(candidate-old-splits
(filter
(lambda (old-split)
(and
;; split value matches
(= (xaccSplitGetValue old-split)
(xaccSplitGetValue new-split))
;; account name matches
(string=?
(gnc-account-get-full-name (xaccSplitGetAccount old-split))
(gnc-account-get-full-name (xaccSplitGetAccount new-split)))
;; maximum 1 week date difference
(<= (abs (- (xaccTransGetDate (xaccSplitGetParent old-split))
(xaccTransGetDate (xaccSplitGetParent new-split))))
WeekSecs)))
old-splits)))
(update-progress work-done)
(loop (cdr new-splits)
(1+ work-done)
(if (null? candidate-old-splits)
matches
(cons (cons (xaccSplitGetParent new-split)
(map (lambda (s) (cons (xaccSplitGetParent s) #f))
candidate-old-splits))
matches)))))))))
;; Since there are either no accounts or no transactions in the old
;; tree, duplicate checking is unnecessary.
(else
(progress 1)
'())))
;; Safely do the work and return the result.
(gnc:backtrace-if-exception
(lambda () (catch 'cancel private-find (lambda (key . args) #t)))))
(lambda () (catch 'cancel private-find (const #t)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -252,20 +169,13 @@
(define (gnc:prune-matching-transactions match-list)
(for-each
(lambda (match)
(let ((new-xtn (car match))
(matches (cdr match))
(do-delete #f))
(for-each
(lambda (old)
(if (cdr old)
(set! do-delete #t)))
matches)
(if do-delete
(begin
(xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn)))))
(lambda (txn-match)
(let ((new-xtn (car txn-match))
(matches (cdr txn-match)))
(when (any cdr matches)
(xaccTransBeginEdit new-xtn)
(xaccTransDestroy new-xtn)
(xaccTransCommitEdit new-xtn))))
match-list))

271
gnucash/import-export/qif-imp/qif-objects.scm
View File

@ -23,7 +23,10 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load-from-path "gnucash/qif-import/simple-obj")
(define (construct class)
(apply (record-constructor class)
(map (const #f) (record-type-fields class))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-file class
@ -34,7 +37,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-file>
(make-simple-class
(make-record-type
'qif-file
'(path ;; where file was loaded
y2k-threshold
@ -47,43 +50,43 @@
(record-predicate <qif-file>))
(define qif-file:path
(simple-obj-getter <qif-file> 'path))
(record-accessor <qif-file> 'path))
(define qif-file:set-path!
(simple-obj-setter <qif-file> 'path))
(record-modifier <qif-file> 'path))
(define qif-file:y2k-threshold
(simple-obj-getter <qif-file> 'y2k-threshold))
(record-accessor <qif-file> 'y2k-threshold))
(define qif-file:set-y2k-threshold!
(simple-obj-setter <qif-file> 'y2k-threshold))
(record-modifier <qif-file> 'y2k-threshold))
(define qif-file:cats
(simple-obj-getter <qif-file> 'cats))
(record-accessor <qif-file> 'cats))
(define qif-file:set-cats!
(simple-obj-setter <qif-file> 'cats))
(record-modifier <qif-file> 'cats))
(define qif-file:classes
(simple-obj-getter <qif-file> 'classes))
(record-accessor <qif-file> 'classes))
(define qif-file:set-classes!
(simple-obj-setter <qif-file> 'classes))
(record-modifier <qif-file> 'classes))
(define qif-file:xtns
(simple-obj-getter <qif-file> 'xtns))
(record-accessor <qif-file> 'xtns))
(define qif-file:set-xtns!
(simple-obj-setter <qif-file> 'xtns))
(record-modifier <qif-file> 'xtns))
(define qif-file:accounts
(simple-obj-getter <qif-file> 'accounts))
(record-accessor <qif-file> 'accounts))
(define qif-file:set-accounts!
(simple-obj-setter <qif-file> 'accounts))
(record-modifier <qif-file> 'accounts))
(define (make-qif-file)
(let ((self (make-simple-obj <qif-file>)))
(let ((self (construct <qif-file>)))
(qif-file:set-y2k-threshold! self 50)
(qif-file:set-xtns! self '())
(qif-file:set-accounts! self '())
@ -97,16 +100,16 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-split>
(make-simple-class
(make-record-type
'qif-split
'(category class memo amount category-is-account? matching-cleared mark
miscx-category miscx-is-account? miscx-class)))
(define qif-split:category
(simple-obj-getter <qif-split> 'category))
(record-accessor <qif-split> 'category))
(define qif-split:set-category-private!
(simple-obj-setter <qif-split> 'category))
(record-modifier <qif-split> 'category))
(define (qif-split:set-category! self value)
(let* ((cat-info
@ -125,61 +128,61 @@
(qif-split:set-miscx-class! self miscx-class)))
(define qif-split:class
(simple-obj-getter <qif-split> 'class))
(record-accessor <qif-split> 'class))
(define qif-split:set-class!
(simple-obj-setter <qif-split> 'class))
(record-modifier <qif-split> 'class))
(define qif-split:memo
(simple-obj-getter <qif-split> 'memo))
(record-accessor <qif-split> 'memo))
(define qif-split:set-memo!
(simple-obj-setter <qif-split> 'memo))
(record-modifier <qif-split> 'memo))
(define qif-split:amount
(simple-obj-getter <qif-split> 'amount))
(record-accessor <qif-split> 'amount))
(define qif-split:set-amount!
(simple-obj-setter <qif-split> 'amount))
(record-modifier <qif-split> 'amount))
(define qif-split:mark
(simple-obj-getter <qif-split> 'mark))
(record-accessor <qif-split> 'mark))
(define qif-split:set-mark!
(simple-obj-setter <qif-split> 'mark))
(record-modifier <qif-split> 'mark))
(define qif-split:matching-cleared
(simple-obj-getter <qif-split> 'matching-cleared))
(record-accessor <qif-split> 'matching-cleared))
(define qif-split:set-matching-cleared!
(simple-obj-setter <qif-split> 'matching-cleared))
(record-modifier <qif-split> 'matching-cleared))
(define qif-split:category-is-account?
(simple-obj-getter <qif-split> 'category-is-account?))
(record-accessor <qif-split> 'category-is-account?))
(define qif-split:set-category-is-account?!
(simple-obj-setter <qif-split> 'category-is-account?))
(record-modifier <qif-split> 'category-is-account?))
(define qif-split:miscx-is-account?
(simple-obj-getter <qif-split> 'miscx-is-account?))
(record-accessor <qif-split> 'miscx-is-account?))
(define qif-split:set-miscx-is-account?!
(simple-obj-setter <qif-split> 'miscx-is-account?))
(record-modifier <qif-split> 'miscx-is-account?))
(define qif-split:miscx-category
(simple-obj-getter <qif-split> 'miscx-category))
(record-accessor <qif-split> 'miscx-category))
(define qif-split:set-miscx-category!
(simple-obj-setter <qif-split> 'miscx-category))
(record-modifier <qif-split> 'miscx-category))
(define qif-split:miscx-class
(simple-obj-getter <qif-split> 'miscx-class))
(record-accessor <qif-split> 'miscx-class))
(define qif-split:set-miscx-class!
(simple-obj-setter <qif-split> 'miscx-class))
(record-modifier <qif-split> 'miscx-class))
(define (make-qif-split)
(let ((self (make-simple-obj <qif-split>)))
(let ((self (construct <qif-split>)))
(qif-split:set-category! self "")
self))
@ -200,7 +203,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-xtn>
(make-simple-class
(make-record-type
'qif-xtn
'(date payee address number action cleared
from-acct share-price num-shares security-name commission
@ -210,97 +213,97 @@
(record-predicate <qif-xtn>))
(define qif-xtn:date
(simple-obj-getter <qif-xtn> 'date))
(record-accessor <qif-xtn> 'date))
(define qif-xtn:set-date!
(simple-obj-setter <qif-xtn> 'date))
(record-modifier <qif-xtn> 'date))
(define qif-xtn:payee
(simple-obj-getter <qif-xtn> 'payee))
(record-accessor <qif-xtn> 'payee))
(define qif-xtn:set-payee!
(simple-obj-setter <qif-xtn> 'payee))
(record-modifier <qif-xtn> 'payee))
(define qif-xtn:address
(simple-obj-getter <qif-xtn> 'address))
(record-accessor <qif-xtn> 'address))
(define qif-xtn:set-address!
(simple-obj-setter <qif-xtn> 'address))
(record-modifier <qif-xtn> 'address))
(define qif-xtn:number
(simple-obj-getter <qif-xtn> 'number))
(record-accessor <qif-xtn> 'number))
(define qif-xtn:set-number!
(simple-obj-setter <qif-xtn> 'number))
(record-modifier <qif-xtn> 'number))
(define qif-xtn:action
(simple-obj-getter <qif-xtn> 'action))
(record-accessor <qif-xtn> 'action))
(define qif-xtn:set-action!
(simple-obj-setter <qif-xtn> 'action))
(record-modifier <qif-xtn> 'action))
(define qif-xtn:cleared
(simple-obj-getter <qif-xtn> 'cleared))
(record-accessor <qif-xtn> 'cleared))
(define qif-xtn:set-cleared!
(simple-obj-setter <qif-xtn> 'cleared))
(record-modifier <qif-xtn> 'cleared))
(define qif-xtn:from-acct
(simple-obj-getter <qif-xtn> 'from-acct))
(record-accessor <qif-xtn> 'from-acct))
(define qif-xtn:set-from-acct!
(simple-obj-setter <qif-xtn> 'from-acct))
(record-modifier <qif-xtn> 'from-acct))
(define qif-xtn:share-price
(simple-obj-getter <qif-xtn> 'share-price))
(record-accessor <qif-xtn> 'share-price))
(define qif-xtn:set-share-price!
(simple-obj-setter <qif-xtn> 'share-price))
(record-modifier <qif-xtn> 'share-price))
(define qif-xtn:num-shares
(simple-obj-getter <qif-xtn> 'num-shares))
(record-accessor <qif-xtn> 'num-shares))
(define qif-xtn:set-num-shares!
(simple-obj-setter <qif-xtn> 'num-shares))
(record-modifier <qif-xtn> 'num-shares))
(define qif-xtn:security-name
(simple-obj-getter <qif-xtn> 'security-name))
(record-accessor <qif-xtn> 'security-name))
(define qif-xtn:set-security-name!
(simple-obj-setter <qif-xtn> 'security-name))
(record-modifier <qif-xtn> 'security-name))
(define qif-xtn:commission
(simple-obj-getter <qif-xtn> 'commission))
(record-accessor <qif-xtn> 'commission))
(define qif-xtn:set-commission!
(simple-obj-setter <qif-xtn> 'commission))
(record-modifier <qif-xtn> 'commission))
(define qif-xtn:default-split
(simple-obj-getter <qif-xtn> 'default-split))
(record-accessor <qif-xtn> 'default-split))
(define qif-xtn:set-default-split!
(simple-obj-setter <qif-xtn> 'default-split))
(record-modifier <qif-xtn> 'default-split))
(define qif-xtn:splits
(simple-obj-getter <qif-xtn> 'splits))
(record-accessor <qif-xtn> 'splits))
(define qif-xtn:set-splits!
(simple-obj-setter <qif-xtn> 'splits))
(record-modifier <qif-xtn> 'splits))
(define qif-xtn:mark
(simple-obj-getter <qif-xtn> 'mark))
(record-accessor <qif-xtn> 'mark))
(define qif-xtn:set-mark!
(simple-obj-setter <qif-xtn> 'mark))
(record-modifier <qif-xtn> 'mark))
(define (make-qif-xtn)
(let ((self (make-simple-obj <qif-xtn>)))
(let ((self (construct <qif-xtn>)))
(qif-xtn:set-mark! self #f)
(qif-xtn:set-splits! self '())
self))
(define (qif-xtn:print self)
(simple-obj-print self))
(write self))
(define (qif-xtn:split-amounts self)
@ -340,42 +343,42 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-acct>
(make-simple-class
(make-record-type
'qif-acct
'(name type description limit budget)))
(define qif-acct:name
(simple-obj-getter <qif-acct> 'name))
(record-accessor <qif-acct> 'name))
(define qif-acct:set-name!
(simple-obj-setter <qif-acct> 'name))
(record-modifier <qif-acct> 'name))
(define qif-acct:type
(simple-obj-getter <qif-acct> 'type))
(record-accessor <qif-acct> 'type))
(define qif-acct:set-type!
(simple-obj-setter <qif-acct> 'type))
(record-modifier <qif-acct> 'type))
(define qif-acct:description
(simple-obj-getter <qif-acct> 'description))
(record-accessor <qif-acct> 'description))
(define qif-acct:set-description!
(simple-obj-setter <qif-acct> 'description))
(record-modifier <qif-acct> 'description))
(define qif-acct:limit
(simple-obj-getter <qif-acct> 'limit))
(record-accessor <qif-acct> 'limit))
(define qif-acct:set-limit!
(simple-obj-setter <qif-acct> 'limit))
(record-modifier <qif-acct> 'limit))
(define qif-acct:budget
(simple-obj-getter <qif-acct> 'budget))
(record-accessor <qif-acct> 'budget))
(define qif-acct:set-budget!
(simple-obj-setter <qif-acct> 'budget))
(record-modifier <qif-acct> 'budget))
(define (make-qif-acct)
(let ((retval (make-simple-obj <qif-acct>)))
(let ((retval (construct <qif-acct>)))
(qif-acct:set-type! retval "Bank")
(qif-acct:set-name! retval "Default Account")
retval))
@ -384,7 +387,7 @@
(record-predicate <qif-acct>))
(define (qif-acct:print self)
(simple-obj-print self))
(write self))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <qif-class>
@ -393,27 +396,27 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-class>
(make-simple-class
(make-record-type
'qif-class
'(name description)))
(define qif-class:name
(simple-obj-getter <qif-class> 'name))
(record-accessor <qif-class> 'name))
(define qif-class:set-name!
(simple-obj-setter <qif-class> 'name))
(record-modifier <qif-class> 'name))
(define qif-class:description
(simple-obj-getter <qif-class> 'description))
(record-accessor <qif-class> 'description))
(define qif-class:set-description!
(simple-obj-setter <qif-class> 'description))
(record-modifier <qif-class> 'description))
(define (qif-class:print self)
(simple-obj-print self))
(write self))
(define (make-qif-class)
(make-simple-obj <qif-class>))
(construct <qif-class>))
(define qif-class?
(record-predicate <qif-class>))
@ -431,60 +434,60 @@
(define <qif-cat>
(make-simple-class
(make-record-type
'qif-cat
'(name description taxable expense-cat income-cat tax-class budget-amt)))
(define qif-cat:name
(simple-obj-getter <qif-cat> 'name))
(record-accessor <qif-cat> 'name))
(define qif-cat:set-name!
(simple-obj-setter <qif-cat> 'name))
(record-modifier <qif-cat> 'name))
(define qif-cat:description
(simple-obj-getter <qif-cat> 'description))
(record-accessor <qif-cat> 'description))
(define qif-cat:set-description!
(simple-obj-setter <qif-cat> 'description))
(record-modifier <qif-cat> 'description))
(define qif-cat:taxable
(simple-obj-getter <qif-cat> 'taxable))
(record-accessor <qif-cat> 'taxable))
(define qif-cat:set-taxable!
(simple-obj-setter <qif-cat> 'taxable))
(record-modifier <qif-cat> 'taxable))
(define qif-cat:expense-cat
(simple-obj-getter <qif-cat> 'expense-cat))
(record-accessor <qif-cat> 'expense-cat))
(define qif-cat:set-expense-cat!
(simple-obj-setter <qif-cat> 'expense-cat))
(record-modifier <qif-cat> 'expense-cat))
(define qif-cat:income-cat
(simple-obj-getter <qif-cat> 'income-cat))
(record-accessor <qif-cat> 'income-cat))
(define qif-cat:set-income-cat!
(simple-obj-setter <qif-cat> 'income-cat))
(record-modifier <qif-cat> 'income-cat))
(define qif-cat:tax-class
(simple-obj-getter <qif-cat> 'tax-class))
(record-accessor <qif-cat> 'tax-class))
(define qif-cat:set-tax-class!
(simple-obj-setter <qif-cat> 'tax-class))
(record-modifier <qif-cat> 'tax-class))
(define qif-cat:budget-amt
(simple-obj-getter <qif-cat> 'budget-amt))
(record-accessor <qif-cat> 'budget-amt))
(define qif-cat:set-budget-amt!
(simple-obj-setter <qif-cat> 'budget-amt))
(record-modifier <qif-cat> 'budget-amt))
(define (make-qif-cat)
(make-simple-obj <qif-cat>))
(construct <qif-cat>))
(define qif-cat?
(record-predicate <qif-cat>))
(define (qif-cat:print self)
(simple-obj-print self))
(write self))
(define (qif-file:add-xtn! self xtn)
(qif-file:set-xtns! self
@ -522,8 +525,8 @@
(if last-dot
last-dot
(string-length namestring)))))
(set! namestring (string-replace-char! namestring #\- #\space))
(set! namestring (string-replace-char! namestring #\_ #\space))
(set! namestring (gnc:string-replace-char namestring #\- #\space))
(set! namestring (gnc:string-replace-char namestring #\_ #\space))
namestring)
"QIF Import")))
@ -535,7 +538,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-map-entry>
(make-simple-class
(make-record-type
'qif-map-entry
'(qif-name ;; set while parsing file
allowed-types ;; set while parsing file
@ -545,7 +548,7 @@
display?))) ;; set when non-zero transactions
(define (make-qif-map-entry)
(make-simple-obj <qif-map-entry>))
(construct <qif-map-entry>))
(define (qif-map-entry:clone orig)
(let ((me (make-qif-map-entry)))
@ -586,40 +589,40 @@
(define qif-map-entry:qif-name
(simple-obj-getter <qif-map-entry> 'qif-name))
(record-accessor <qif-map-entry> 'qif-name))
(define qif-map-entry:set-qif-name!
(simple-obj-setter <qif-map-entry> 'qif-name))
(record-modifier <qif-map-entry> 'qif-name))
(define qif-map-entry:allowed-types
(simple-obj-getter <qif-map-entry> 'allowed-types))
(record-accessor <qif-map-entry> 'allowed-types))
(define qif-map-entry:set-allowed-types!
(simple-obj-setter <qif-map-entry> 'allowed-types))
(record-modifier <qif-map-entry> 'allowed-types))
(define qif-map-entry:description
(simple-obj-getter <qif-map-entry> 'description))
(record-accessor <qif-map-entry> 'description))
(define qif-map-entry:set-description!
(simple-obj-setter <qif-map-entry> 'description))
(record-modifier <qif-map-entry> 'description))
(define qif-map-entry:gnc-name
(simple-obj-getter <qif-map-entry> 'gnc-name))
(record-accessor <qif-map-entry> 'gnc-name))
(define qif-map-entry:set-gnc-name!
(simple-obj-setter <qif-map-entry> 'gnc-name))
(record-modifier <qif-map-entry> 'gnc-name))
(define qif-map-entry:new-acct?
(simple-obj-getter <qif-map-entry> 'new-acct?))
(record-accessor <qif-map-entry> 'new-acct?))
(define qif-map-entry:set-new-acct?!
(simple-obj-setter <qif-map-entry> 'new-acct?))
(record-modifier <qif-map-entry> 'new-acct?))
(define qif-map-entry:display?
(simple-obj-getter <qif-map-entry> 'display?))
(record-accessor <qif-map-entry> 'display?))
(define qif-map-entry:set-display?!
(simple-obj-setter <qif-map-entry> 'display?))
(record-modifier <qif-map-entry> 'display?))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -630,51 +633,51 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define <qif-stock-symbol>
(make-simple-class
(make-record-type
'qif-stock-symbol
'(name symbol type)))
(define qif-stock-symbol:name
(simple-obj-getter <qif-stock-symbol> 'name))
(record-accessor <qif-stock-symbol> 'name))
(define qif-stock-symbol:set-name!
(simple-obj-setter <qif-stock-symbol> 'name))
(record-modifier <qif-stock-symbol> 'name))
(define qif-stock-symbol:symbol
(simple-obj-getter <qif-stock-symbol> 'symbol))
(record-accessor <qif-stock-symbol> 'symbol))
(define qif-stock-symbol:set-symbol!
(simple-obj-setter <qif-stock-symbol> 'symbol))
(record-modifier <qif-stock-symbol> 'symbol))
(define qif-stock-symbol:type
(simple-obj-getter <qif-stock-symbol> 'type))
(record-accessor <qif-stock-symbol> 'type))
(define qif-stock-symbol:set-type!
(simple-obj-setter <qif-stock-symbol> 'type))
(record-modifier <qif-stock-symbol> 'type))
(define (qif-stock-symbol:print self)
(simple-obj-print self))
(write self))
(define (make-qif-stock-symbol)
(let ((retval (make-simple-obj <qif-stock-symbol>)))
(let ((retval (construct <qif-stock-symbol>)))
(qif-stock-symbol:set-name! retval "")
(qif-stock-symbol:set-symbol! retval "")
(qif-stock-symbol:set-type! retval "")
retval))
(define <qif-ticker-map>
(make-simple-class
(make-record-type
'qif-ticker-map
'(stocks)))
(define qif-ticker-map:ticker-map
(simple-obj-getter <qif-ticker-map> 'stocks))
(record-accessor <qif-ticker-map> 'stocks))
(define qif-ticker-map:set-ticker-map!
(simple-obj-setter <qif-ticker-map> 'stocks))
(record-modifier <qif-ticker-map> 'stocks))
(define (make-ticker-map)
(let ((self (make-simple-obj <qif-ticker-map>)))
(let ((self (construct <qif-ticker-map>)))
(qif-ticker-map:set-ticker-map! self '())
self))

759
gnucash/import-export/qif-imp/qif-parse.scm
View File

@ -24,28 +24,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (gnucash string))
(define qif-category-compiled-rexp
(make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$"))
(define qif-date-compiled-rexp
(make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]).*$"))
(define qif-date-mdy-compiled-rexp
(make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])"))
(define qif-date-ymd-compiled-rexp
(make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])"))
(define decimal-radix-regexp
(make-regexp
"^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *$"))
(define comma-radix-regexp
(make-regexp
"^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$"))
(define integer-regexp (make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$"))
(use-modules (srfi srfi-13))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-split:parse-category
@ -60,37 +39,42 @@
;; gosh, I love regular expressions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define qif-category-compiled-rexp
(make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$"))
(define (qif-split:parse-category self value)
(let ((match (regexp-exec qif-category-compiled-rexp value)))
(if match
(let ((rv
(list (match:substring match 2)
(if (and (match:substring match 1)
(match:substring match 3))
#t #f)
(if (match:substring match 4)
(match:substring match 5)
#f)
;; miscx category name
(if (match:substring match 6)
(match:substring match 8)
#f)
;; is it an account?
(if (and (match:substring match 7)
(match:substring match 9))
#t #f)
(if (match:substring match 10)
(match:substring match 11)
#f))))
rv)
(begin
;; Parsing failed. Bug detected!
(gnc:warn "qif-split:parse-category: can't parse [" value "].")
(throw 'bug
"qif-split:parse-category"
"Can't parse account or category ~A."
(list value)
#f)))))
;; example category regex matches (excluding initial 'L'):
;; field1
;; field1/field2
;; field1/|field3
;; field1/|field3/field4
;; where field1 is a category or [account]
;; and field2 is a class
;; and field3 is a miscx-category or [miscx-account]
;; and field4 is a miscx-class
(cond
((regexp-exec qif-category-compiled-rexp value) =>
(lambda (rmatch)
(list (match:substring rmatch 2)
(and (match:substring rmatch 1)
(match:substring rmatch 3)
#t)
(and (match:substring rmatch 4)
(match:substring rmatch 5))
;; miscx category name
(and (match:substring rmatch 6)
(match:substring rmatch 8))
;; is it an account?
(and (match:substring rmatch 7)
(match:substring rmatch 9)
#t)
(and (match:substring rmatch 10)
(match:substring rmatch 11)))))
(else
;; Parsing failed. Bug detected!
(gnc:warn "qif-split:parse-category: can't parse [" value "].")
(throw 'bug "qif-split:parse-category""Can't parse account or category ~A."
(list value) #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -101,59 +85,40 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:fix-year year-string y2k-threshold)
(let ((fixed-string #f)
(post-read-value #f)
(y2k-fixed-value #f))
;; quicken prints 2000 as "' 0" for at least some versions.
;; thanks dave p for reporting this.
(if (eq? (string-ref year-string 0) #\')
(begin
(gnc:warn "qif-file:fix-year: found weird QIF Y2K year ["
year-string "].")
(set! fixed-string
(substring year-string 2 (string-length year-string))))
(set! fixed-string year-string))
;; now the string should just have a number in it plus some
;; optional trailing space.
(set! post-read-value
(with-input-from-string fixed-string
(lambda () (read))))
(let* ((fixed-string
(cond
((char=? (string-ref year-string 0) #\')
(gnc:warn "qif-file:fix-year: weird QIF year [" year-string "].")
(substring year-string 2 (string-length year-string)))
(else year-string)))
(post-read-value (with-input-from-string fixed-string read)))
(cond
;; 2-digit numbers less than the window size are interpreted to
;; be post-2000.
((and (integer? post-read-value)
(< post-read-value y2k-threshold))
(set! y2k-fixed-value (+ 2000 post-read-value)))
((and (integer? post-read-value) (< post-read-value y2k-threshold))
(+ 2000 post-read-value))
;; there's a common bug in printing post-2000 dates that
;; prints 2000 as 19100 etc.
((and (integer? post-read-value)
(> post-read-value 19000))
(set! y2k-fixed-value (+ 1900 (- post-read-value 19000))))
;; there's a common bug in printing post-2000 dates that prints
;; 2000 as 19100 etc.
((and (integer? post-read-value) (> post-read-value 19000))
(+ 1900 (- post-read-value 19000)))
;; normal dates represented in unix years (i.e. year-1900, so
;; 2000 => 100.) We also want to allow full year specifications,
;; (i.e. 1999, 2001, etc) and there's a point at which you can't
;; determine which is which. this should eventually be another
;; field in the qif-file struct but not yet.
((and (integer? post-read-value)
(< post-read-value 1902))
(set! y2k-fixed-value (+ 1900 post-read-value)))
((and (integer? post-read-value) (< post-read-value 1902))
(+ 1900 post-read-value))
;; this is a normal, 4-digit year spec (1999, 2000, etc).
((integer? post-read-value)
(set! y2k-fixed-value post-read-value))
((integer? post-read-value) post-read-value)
;; No idea what the string represents. Maybe a new bug in Quicken!
(#t
(gnc:warn "qif-file:fix-year: ay caramba! What is this? ["
year-string "].")))
y2k-fixed-value))
(else
(gnc:warn "qif-file:fix-year: ay! What is this? [" year-string "].")
#f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-acct-type : set the type of the account, using gnucash
@ -161,35 +126,22 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-acct-type read-value errorproc errortype)
(let ((mangled-string
(string-downcase! (string-remove-trailing-space
(string-remove-leading-space read-value)))))
(cond
((string=? mangled-string "bank")
(list GNC-BANK-TYPE))
((string=? mangled-string "port")
(list GNC-BANK-TYPE))
((string=? mangled-string "cash")
(list GNC-CASH-TYPE))
((string=? mangled-string "ccard")
(list GNC-CCARD-TYPE))
((string=? mangled-string "invst") ;; these are brokerage accounts.
(list GNC-BANK-TYPE))
((string=? mangled-string "401(k)/403(b)")
(list GNC-BANK-TYPE))
((string=? mangled-string "oth a")
(list GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE))
((string=? mangled-string "oth l")
(list GNC-LIABILITY-TYPE GNC-CCARD-TYPE))
((string=? mangled-string "oth s") ;; German asset account
(list GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE))
((string=? mangled-string "mutual")
(list GNC-BANK-TYPE))
(#t
(errorproc errortype
(format #f (_ "Unrecognized account type '~s'. Defaulting to Bank.")
read-value))
(list GNC-BANK-TYPE)))))
(define string-map-alist
(list (list "bank" GNC-BANK-TYPE)
(list "port" GNC-BANK-TYPE)
(list "cash" GNC-CASH-TYPE)
(list "ccard" GNC-CCARD-TYPE)
(list "invst" GNC-BANK-TYPE)
(list "401(k)/403(b)" GNC-BANK-TYPE)
(list "oth a" GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE)
(list "oth l" GNC-LIABILITY-TYPE GNC-CCARD-TYPE)
(list "oth s" GNC-ASSET-TYPE GNC-BANK-TYPE GNC-CASH-TYPE)
(list "mutual" GNC-BANK-TYPE)))
(or (assoc-ref string-map-alist (string-downcase! (string-trim-both read-value)))
(let ((msg (format #f (_ "Unrecognized account type '~s'. Defaulting to Bank.")
read-value)))
(errorproc errortype msg)
(list GNC-BANK-TYPE))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-bang-field : the bang fields switch the parse context
@ -197,106 +149,60 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-bang-field read-value)
(let ((bang-field (string-downcase!
(string-remove-trailing-space read-value))))
;; The QIF files output by the WWW site of Credit Lyonnais
;; begin by: !type bank
;; instead of: !Type:bank
(let ((bang-field (string-downcase! (string-trim read-value))))
;; The QIF files output by the WWW site of Credit Lyonnais
;; begin by: !type bank
;; instead of: !Type:bank
(if (>= (string-length bang-field) 5)
(if (string=? (substring bang-field 0 5) "type ")
(string-set! bang-field 4 #\:)))
(string->symbol bang-field)))
(define (qif-parse:parse-action-field read-value errorproc errortype)
(if read-value
(let ((action-symbol (string-to-canonical-symbol read-value)))
(case action-symbol
;; buy
((buy cvrshrt kauf)
'buy)
((buyx cvrshrtx kaufx)
'buyx)
((cglong kapgew) ;; Kapitalgewinnsteuer
'cglong)
((cglongx kapgewx)
'cglongx)
((cgmid) ;; Kapitalgewinnsteuer
'cgmid)
((cgmidx)
'cgmidx)
((cgshort k.gewsp)
'cgshort)
((cgshortx k.gewspx)
'cgshortx)
((div) ;; dividende
'div)
((divx)
'divx)
; ((exercise)
; 'exercise)
; ((exercisx)
; 'exercisx)
; ((expire)
; 'expire)
; ((grant)
; 'grant)
((int intinc) ;; zinsen
'intinc)
((intx intincx)
'intincx)
((margint)
'margint)
((margintx)
'margintx)
((miscexp)
'miscexp)
((miscexpx)
'miscexpx)
((miscinc cash)
'miscinc)
((miscincx)
'miscincx)
((reinvdiv)
'reinvdiv)
((reinvint reinvzin)
'reinvint)
((reinvlg reinvkur)
'reinvlg)
((reinvmd)
'reinvmd)
((reinvsg reinvksp)
'reinvsg)
((reinvsh)
'reinvsh)
((reminder erinnerg)
'reminder)
((rtrncap)
'rtrncap)
((rtrncapx)
'rtrncapx)
((sell shtsell verkauf) ;; verkaufen
'sell)
((sellx shtsellx verkaufx)
'sellx)
((shrsin aktzu)
'shrsin)
((shrsout aktab)
'shrsout)
((stksplit aktsplit)
'stksplit)
((xin contribx)
'xin)
((xout withdrwx)
'xout)
; ((vest)
; 'vest)
(else
(errorproc errortype
(format #f (_ "Unrecognized action '~a'.") read-value))
#f)))
#f))
(define action-map
'((buy cvrshrt kauf)
(buyx cvrshrtx kaufx)
(cglong cglong kapgew)
(cglongx cglongx kapgewx)
(cgmid cgmid)
(cgmidx cgmidx)
(cgshort cgshort k.gewsp)
(cgshortx cgshortx k.gewspx)
(div div)
(divx divx)
;; (exercise exercise)
;; (exercisx exercisx)
;; (expire expire)
;; (grant grant)
(intinc int intinc)
(intincx intx intincx)
(margint margint)
(margintx margintx)
(miscexp miscexp)
(miscexpx miscexpx)
(miscinc miscinc cash)
(miscincx miscincx)
(reinvdiv reinvdiv)
(reinvint reinvint reinvzin)
(reinvlg reinvlg reinvkur)
(reinvmd reinvmd)
(reinvsg reinvsg reinvksp)
(reinvsh reinvsh)
(reminder reminder erinnerg)
(rtrncap rtrncap)
(rtrncapx rtrncapx)
(sell sell shtsell verkauf)
(sellx sellx shtsellx verkaufx)
(shrsin shrsin aktzu)
(shrsout shrsout aktab)
(stksplit stksplit aktsplit)
(xin xin contribx)
(xout xout withdrwx)))
(and read-value
(let ((sym (string->symbol (string-downcase (string-trim-both read-value)))))
(or (any (lambda (lst) (and (memq sym lst) (car lst))) action-map)
(let ((msg (format #f (_ "Unrecognized action '~a'.") read-value)))
(errorproc errortype msg))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; parse-cleared-field : In a "C" (cleared status) QIF line,
@ -305,24 +211,18 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-cleared-field read-value errorproc errortype)
(if (and (string? read-value)
(not (string-null? read-value)))
(let ((secondchar (string-ref read-value 0)))
(case secondchar
;; Reconciled is the most likely, especially for large imports,
;; so check that first. Also allow for lowercase.
((#\X #\x #\R #\r)
'reconciled)
((#\* #\C #\c)
'cleared)
((#\? #\!)
'budgeted)
(else
(errorproc errortype
(format #f (_ "Unrecognized status '~a'. Defaulting to uncleared.")
read-value))
#f)))
#f))
(define maplist
'((reconciled #\X #\x #\R #\r)
(cleared #\* #\C #\c)
(budgeted #\? #\!)))
(and
(string? read-value)
(not (string-null? read-value))
(let* ((secondchar (string-ref read-value 0)))
(or (any (lambda (m) (and (memq secondchar (cdr m)) (car m))) maplist)
(let ((msg (format #f (_ "Unrecognized status '~a'. Defaulting to uncleared.")
read-value)))
(errorproc errortype msg))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -332,115 +232,69 @@
;; that this date string could actually be.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse-check-date-format match possible-formats)
(let ((date-parts (list (match:substring match 1)
(match:substring match 2)
(match:substring match 3)))
(numeric-date-parts '())
(retval '()))
(define (date? d m y ys)
(and (number? d) (<= 1 d 31)
(number? m) (<= 1 m 12)
(= 4 (string-length ys))
(number? y) (> y 1930)))
(let* ((date-parts (list (match:substring match 1)
(match:substring match 2)
(match:substring match 3)))
(numeric-date-parts (map (lambda (elt) (with-input-from-string elt read))
date-parts))
(n1 (car numeric-date-parts))
(n2 (cadr numeric-date-parts))
(n3 (caddr numeric-date-parts))
(s1 (car date-parts))
(s3 (caddr date-parts))
(format-alist (list (list 'd-m-y n1 n2 n3 s3)
(list 'm-d-y n2 n1 n3 s3)
(list 'y-m-d n3 n2 n1 s1)
(list 'y-d-m n2 n3 n1 s1))))
;;(define (print-list l)
;; (for-each (lambda (x) (display x) (display " ")) l))
;;(for-each (lambda (x) (if (list? x) (print-list x) (display x)))
;; (list "parsing: " date-parts " in " possible-formats "\n"))
;; get the strings into numbers (but keep the strings around)
(set! numeric-date-parts
(map (lambda (elt)
(with-input-from-string elt
(lambda () (read))))
date-parts))
(let ((possibilities possible-formats)
(n1 (car numeric-date-parts))
(n2 (cadr numeric-date-parts))
(n3 (caddr numeric-date-parts))
(s1 (car date-parts))
(s3 (caddr date-parts)))
;; filter the possibilities to eliminate (hopefully)
;; all but one
(if (or (not (number? n1)) (> n1 12))
(set! possibilities (delq 'm-d-y possibilities)))
(if (or (not (number? n1)) (> n1 31))
(set! possibilities (delq 'd-m-y possibilities)))
(if (or (not (number? n1)) (< n1 1))
(set! possibilities (delq 'd-m-y possibilities)))
(if (or (not (number? n1)) (< n1 1))
(set! possibilities (delq 'm-d-y possibilities)))
(if (or (not (number? n2)) (> n2 12))
(begin
(set! possibilities (delq 'd-m-y possibilities))
(set! possibilities (delq 'y-m-d possibilities))))
(if (or (not (number? n2)) (> n2 31))
(begin
(set! possibilities (delq 'm-d-y possibilities))
(set! possibilities (delq 'y-d-m possibilities))))
(if (or (not (number? n3)) (> n3 12))
(set! possibilities (delq 'y-d-m possibilities)))
(if (or (not (number? n3)) (> n3 31))
(set! possibilities (delq 'y-m-d possibilities)))
(if (or (not (number? n3)) (< n3 1))
(set! possibilities (delq 'y-m-d possibilities)))
(if (or (not (number? n3)) (< n3 1))
(set! possibilities (delq 'y-d-m possibilities)))
;; If we've got a 4-character year, make sure the date
;; is after 1930. Don't check the high value (perhaps
;; we should?).
(if (= (string-length s1) 4)
(if (or (not (number? n1)) (< n1 1930))
(begin
(set! possibilities (delq 'y-m-d possibilities))
(set! possibilities (delq 'y-d-m possibilities)))))
(if (= (string-length s3) 4)
(if (or (not (number? n3)) (< n3 1930))
(begin
(set! possibilities (delq 'm-d-y possibilities))
(set! possibilities (delq 'd-m-y possibilities)))))
(set! retval possibilities))
retval))
(let lp ((possible-formats possible-formats)
(res '()))
(cond
((null? possible-formats) (reverse res))
(else
(lp (cdr possible-formats)
(let ((args (assq (car possible-formats) format-alist)))
(if (apply date? (cdr args)) (cons (car args) res) res))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:check-date-format
;; given a list of possible date formats, return a pruned list
;; of possibilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define qif-date-compiled-rexp
(make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]).*$"))
(define qif-date-mdy-compiled-rexp
(make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])"))
(define qif-date-ymd-compiled-rexp
(make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])"))
(define (qif-parse:check-date-format date-string possible-formats)
(let ((retval '()))
(if (or (not (string? date-string))
(not (> (string-length date-string) 0)))
(set! retval #f)
(let ((match (regexp-exec qif-date-compiled-rexp date-string)))
(if match
(if (match:substring match 1)
(set! retval (parse-check-date-format match possible-formats))
;; Uh oh -- this is a string XXXXXXXX; we don't know which
;; way to test.. So test both YYYYxxxx and xxxxYYYY,
;; and let the parser verify the year is valid.
(let* ((new-date-string (match:substring match 4))
(date-ymd (regexp-exec qif-date-ymd-compiled-rexp
new-date-string))
(date-mdy (regexp-exec qif-date-mdy-compiled-rexp
new-date-string))
(res1 '())
(res2 '()))
(if (or (memq 'y-d-m possible-formats)
(memq 'y-m-d possible-formats))
(set! res1 (parse-check-date-format date-ymd possible-formats)))
(if (or (memq 'd-m-y possible-formats)
(memq 'm-d-y possible-formats))
(set! res2 (parse-check-date-format date-mdy possible-formats)))
(set! retval (append res1 res2)))))))
retval))
(and (string? date-string)
(not (string-null? date-string))
(let ((rmatch (regexp-exec qif-date-compiled-rexp date-string)))
(if rmatch
(if (match:substring rmatch 1)
(parse-check-date-format rmatch possible-formats)
;; Uh oh -- this is a string XXXXXXXX; we don't know which
;; way to test.. So test both YYYYxxxx and xxxxYYYY,
;; and let the parser verify the year is valid.
(let* ((newstr (match:substring rmatch 4))
(date-ymd (regexp-exec qif-date-ymd-compiled-rexp newstr))
(date-mdy (regexp-exec qif-date-mdy-compiled-rexp newstr)))
(append
(if (or (memq 'y-d-m possible-formats)
(memq 'y-m-d possible-formats))
(parse-check-date-format date-ymd possible-formats))
(if (or (memq 'd-m-y possible-formats)
(memq 'm-d-y possible-formats))
(parse-check-date-format date-mdy possible-formats)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:parse-date/format
@ -448,107 +302,71 @@
;; date and return a list of day, month, year
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:parse-date/format date-string format)
(let ((date-parts '())
(numeric-date-parts '())
(retval #f)
(define (qif-parse:parse-date/format date-string dateformat)
(define (date? d m y)
(and (number? d) (<= 1 d 31)
(number? m) (<= 1 m 12)))
(let* ((rmatch (regexp-exec qif-date-compiled-rexp date-string))
(date-parts
(if rmatch
(if (match:substring rmatch 1)
(list (match:substring rmatch 1)
(match:substring rmatch 2)
(match:substring rmatch 3))
;; This is of the form XXXXXXXX; split the string based on
;; whether the format is YYYYxxxx or xxxxYYYY
(let ((date-str (match:substring rmatch 4)))
(case dateformat
((d-m-y m-d-y)
(let ((m (regexp-exec qif-date-mdy-compiled-rexp date-str)))
(list (match:substring m 1)
(match:substring m 2)
(match:substring m 3))))
((y-m-d y-d-m)
(let ((m (regexp-exec qif-date-ymd-compiled-rexp date-str)))
(list (match:substring m 1)
(match:substring m 2)
(match:substring m 3)))))))
'()))
;; get the strings into numbers (but keep the strings around)
(numeric-date-parts (map (lambda (elt) (with-input-from-string elt read))
date-parts)))
(match (regexp-exec qif-date-compiled-rexp date-string)))
(if match
(if (match:substring match 1)
(set! date-parts (list (match:substring match 1)
(match:substring match 2)
(match:substring match 3)))
;; This is of the form XXXXXXXX; split the string based on
;; whether the format is YYYYxxxx or xxxxYYYY
(let ((date-str (match:substring match 4)))
(case format
((d-m-y m-d-y)
(let ((m (regexp-exec qif-date-mdy-compiled-rexp date-str)))
(set! date-parts (list (match:substring m 1)
(match:substring m 2)
(match:substring m 3)))))
((y-m-d y-d-m)
(let ((m (regexp-exec qif-date-ymd-compiled-rexp date-str)))
(set! date-parts (list (match:substring m 1)
(match:substring m 2)
(match:substring m 3)))))
))))
;; get the strings into numbers (but keep the strings around)
(set! numeric-date-parts
(map (lambda (elt)
(with-input-from-string elt
(lambda () (read))))
date-parts))
(define (refs->list dd mm yy)
(let ((d (list-ref numeric-date-parts dd))
(m (list-ref numeric-date-parts mm))
(y (qif-parse:fix-year (list-ref date-parts yy) 50)))
(cond
((date? d m y) (list d m y))
(else (gnc:warn "qif-parse:parse-date/format: format is " dateformat
" but date is [" date-string "].") #f))))
;; if the date parts list doesn't have 3 parts, we're in trouble
(if (not (eq? 3 (length date-parts)))
(gnc:warn "qif-parse:parse-date/format: can't interpret date ["
date-string "]\nDate parts: " date-parts)
(case format
((d-m-y)
(let ((d (car numeric-date-parts))
(m (cadr numeric-date-parts))
(y (qif-parse:fix-year (caddr date-parts) 50)))
(if (and (integer? d) (integer? m) (integer? y)
(<= m 12) (<= d 31))
(set! retval (list d m y))
(gnc:warn "qif-parse:parse-date/format: "
"format is d/m/y, but date is ["
date-string "]."))))
((m-d-y)
(let ((m (car numeric-date-parts))
(d (cadr numeric-date-parts))
(y (qif-parse:fix-year (caddr date-parts) 50)))
(if (and (integer? d) (integer? m) (integer? y)
(<= m 12) (<= d 31))
(set! retval (list d m y))
(gnc:warn "qif-parse:parse-date/format: "
"format is m/d/y, but date is ["
date-string "]."))))
((y-m-d)
(let ((y (qif-parse:fix-year (car date-parts) 50))
(m (cadr numeric-date-parts))
(d (caddr numeric-date-parts)))
(if (and (integer? d) (integer? m) (integer? y)
(<= m 12) (<= d 31))
(set! retval (list d m y))
(gnc:warn "qif-parse:parse-date/format: "
"format is y/m/d, but date is ["
date-string "]."))))
((y-d-m)
(let ((y (qif-parse:fix-year (car date-parts) 50))
(d (cadr numeric-date-parts))
(m (caddr numeric-date-parts)))
(if (and (integer? d) (integer? m) (integer? y)
(<= m 12) (<= d 31))
(set! retval (list d m y))
(gnc:warn "qif-parse:parse-date/format: "
"format is y/d/m, but date is ["
date-string "]."))))))
retval))
(cond
((not (= 3 (length date-parts)))
(gnc:warn "qif-parse:parse-date/format: can't interpret date ["
date-string "]\nDate parts: " date-parts) #f)
((eq? dateformat 'd-m-y) (refs->list 0 1 2))
((eq? dateformat 'm-d-y) (refs->list 1 0 2))
((eq? dateformat 'y-m-d) (refs->list 2 1 0))
((eq? dateformat 'y-d-m) (refs->list 2 0 1)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; number format predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (value-is-decimal-radix? value)
(if (regexp-exec decimal-radix-regexp value)
#t #f))
(define (value-is-comma-radix? value)
(if (regexp-exec comma-radix-regexp value)
#t #f))
;; eg 1000.00 or 1,500.00 or 2'000.00
(define decimal-radix-regexp
(make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *$"))
(define (value-is-integer? value)
(if (regexp-exec integer-regexp value)
#t #f))
;; eg 5.000,00 or 4'500,00
(define comma-radix-regexp
(make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$"))
;; eg 456 or 123
(define integer-regexp
(make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:check-number-format
@ -557,15 +375,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (qif-parse:check-number-format value-string possible-formats)
(let ((retval possible-formats))
(if (not (value-is-decimal-radix? value-string))
(set! retval (delq 'decimal retval)))
(if (not (value-is-comma-radix? value-string))
(set! retval (delq 'comma retval)))
(if (not (value-is-integer? value-string))
(set! retval (delq 'integer retval)))
retval))
(define numtypes-alist
(list (cons 'decimal decimal-radix-regexp)
(cons 'comma comma-radix-regexp)
(cons 'integer integer-regexp)))
(filter (lambda (fmt) (regexp-exec (assq-ref numtypes-alist fmt) value-string))
possible-formats))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:parse-number/format
@ -574,69 +389,35 @@
;; represent the number
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following is a working refactored function
(define (qif-parse:parse-number/format value-string format)
(let ((minus-index (string-index value-string #\-))
(filtered-string (gnc:string-delete-chars value-string "$'+-")))
(case format
((decimal)
(let* ((read-string (string-remove-char filtered-string #\,))
(read-val (with-input-from-string read-string
(lambda () (read)))))
(if (number? read-val)
(double-to-gnc-numeric
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
GNC-DENOM-AUTO
(logior (GNC-DENOM-SIGFIGS
(string-length (string-remove-char read-string #\.)))
GNC-RND-ROUND))
(gnc-numeric-zero))))
((comma)
(let* ((read-string (gnc:string-replace-char
(string-remove-char filtered-string #\.)
#\, #\.))
(read-val (with-input-from-string read-string
(lambda () (read)))))
(if (number? read-val)
(double-to-gnc-numeric
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
GNC-DENOM-AUTO
(logior (GNC-DENOM-SIGFIGS
(string-length (string-remove-char read-string #\.)))
GNC-RND-ROUND))
(gnc-numeric-zero))))
((integer)
(let ((read-val (with-input-from-string filtered-string
(lambda () (read)))))
(if (number? read-val)
(double-to-gnc-numeric
(if minus-index (- 0.0 read-val) (+ 0.0 read-val))
1 GNC-RND-ROUND)
(gnc-numeric-zero)))))))
(let* ((filtered-string (gnc:string-delete-chars value-string "$'+"))
(read-string (case format
((decimal) (gnc:string-delete-chars filtered-string ","))
((comma) (gnc:string-replace-char
(gnc:string-delete-chars filtered-string ".")
#\, #\.))
((integer) filtered-string))))
(or (string->number (string-append "#e" read-string)) 0)))
;; input: list of numstrings eg "10.50" "20.54"
;; input: formats to test '(decimal comma integer)
;; output: list of formats applicable eg '(decimal)
(define (qif-parse:check-number-formats amt-strings formats)
(let ((retval formats))
(for-each
(lambda (amt)
(if amt
(set! retval (qif-parse:check-number-format amt retval))))
amt-strings)
retval))
(let lp ((amt-strings amt-strings)
(formats formats))
(if (null? amt-strings)
formats
(lp (cdr amt-strings)
(qif-parse:check-number-format (car amt-strings) formats)))))
;; list of number-strings and format -> list of numbers eg '("1,00"
;; "2,50" "3,99") 'comma --> '(1 5/2 399/100) this function would
;; formerly attempt to return #f if a list element couldn't be parsed;
;; but in practice always returns a list, with unparsed numbers as 0.
(define (qif-parse:parse-numbers/format amt-strings format)
(let* ((all-ok #t)
(tmp #f)
(parsed
(map
(lambda (amt)
(if amt
(begin
(set! tmp (qif-parse:parse-number/format amt format))
(if (not tmp)
(set! all-ok #f))
tmp)
(gnc-numeric-zero)))
amt-strings)))
(if all-ok parsed #f)))
(map (lambda (amt) (if amt (qif-parse:parse-number/format amt format) 0))
amt-strings))
(define (qif-parse:print-date date-list)
(let ((tm (gnc-localtime (current-time))))

74
gnucash/import-export/qif-imp/qif-utils.scm
View File

@ -24,72 +24,34 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use-modules (ice-9 regex))
(use-modules (srfi srfi-13))
(define qif-import:paused #f)
(define qif-import:canceled #f)
(define (simple-filter pred list)
(let ((retval '()))
(map (lambda (elt)
(if (pred elt)
(set! retval (cons elt retval))))
list)
(reverse retval)))
(define remove-trailing-space-rexp
(make-regexp "^(.*[^ ]+) *$"))
(define remove-leading-space-rexp
(make-regexp "^ *([^ ].*)$"))
(define (string-remove-trailing-space str)
(let ((match (regexp-exec remove-trailing-space-rexp str)))
(if match
(string-copy (match:substring match 1))
"")))
(issue-deprecation-warning "string-remove-trailing-space - use string-trim-right")
(string-trim-right str))
(define (string-remove-leading-space str)
(let ((match (regexp-exec remove-leading-space-rexp str)))
(if match
(string-copy (match:substring match 1))
"")))
(issue-deprecation-warning "string-remove-leading-space - use string-trim")
(string-trim str))
(define (string-remove-char str char)
(let ((rexpstr
(case char
((#\.) "\\.")
((#\^) "\\^")
((#\$) "\\$")
((#\*) "\\*")
((#\+) "\\+")
((#\\) "\\\\")
((#\?) "\\?")
(else
(make-string 1 char)))))
(regexp-substitute/global #f rexpstr str 'pre 'post)))
(define (string-char-count str char)
(length (simple-filter (lambda (elt) (eq? elt char))
(string->list str))))
(issue-deprecation-warning "string-remove-char - use gnc:string-delete-chars")
(gnc:string-delete-chars s (list char)))
(define (string-replace-char! str old new)
(let ((rexpstr
(if (not (eq? old #\.))
(make-string 1 old)
"\\."))
(newstr (make-string 1 new)))
(regexp-substitute/global #f rexpstr str 'pre newstr 'post)))
(issue-deprecation-warning "string-replace-char! - use gnc:string-replace-char")
(gnc:string-replace-char str old new))
(define (string-to-canonical-symbol str)
(issue-deprecation-warning "string-to-canonical-symbol - inline instead")
(string->symbol
(string-downcase
(string-remove-leading-space
(string-remove-trailing-space str)))))
(define (qif-import:log progress-dialog proc str)
(if progress-dialog
(gnc-progress-dialog-append-log progress-dialog (string-append str "\n"))
@ -103,15 +65,13 @@
(set! qif-import:canceled #t))
(define (qif-import:toggle-pause progress-dialog)
(if qif-import:paused
(begin
(set! qif-import:paused #f)
(if progress-dialog
(gnc-progress-dialog-resume progress-dialog)))
(begin
(set! qif-import:paused #t)
(if progress-dialog
(gnc-progress-dialog-pause progress-dialog)))))
(cond
(qif-import:paused
(set! qif-import:paused #f)
(when progress-dialog (gnc-progress-dialog-resume progress-dialog)))
(else
(set! qif-import:paused #t)
(when progress-dialog (gnc-progress-dialog-pause progress-dialog)))))
(define (qif-import:check-pause progress-dialog)
(while (and qif-import:paused (not qif-import:canceled))

8
gnucash/import-export/qif-imp/simple-obj.scm
View File

@ -23,7 +23,6 @@
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; this is an extremely rudimentary object system. Each object is a
;; cons cell, where the car is a symbol with the class name and the
;; cdr is a vector of the slots.
@ -41,18 +40,23 @@
;; the 'simple-class' class.
(define (make-simple-class class-symbol slot-names)
(issue-deprecation-warning "make-simple-class is deprecated. use make-record-type.")
(make-record-type (symbol->string class-symbol) slot-names))
(define (simple-obj-getter class slot)
(issue-deprecation-warning "simple-obj-getter is deprecated. use record-accessor.")
(record-accessor class slot))
(define (simple-obj-setter class slot)
(issue-deprecation-warning "simple-obj-setter is deprecated. use record-modifier.")
(record-modifier class slot))
(define (simple-obj-print obj)
(issue-deprecation-warning "simple-obj-print is deprecated. use write.")
(write obj))
(define (simple-obj-to-list obj)
(issue-deprecation-warning "simple-obj-to-list is deprecated. use record-type->list in qif-guess-map.scm")
(let ((retval '()))
(for-each
(lambda (slot)
@ -62,6 +66,7 @@
(reverse retval)))
(define (simple-obj-from-list list type)
(issue-deprecation-warning "simple-obj-from-list-obj is deprecated. use list->record-type in qif-guess-map.scm")
(let ((retval (make-simple-obj type)))
(for-each
(lambda (slot)
@ -73,6 +78,7 @@
(define (make-simple-obj class)
(issue-deprecation-warning "make-simple-obj is deprecated. use construct in qif-objects.scm")
(let ((ctor (record-constructor class))
(field-defaults
(map (lambda (v) #f) (record-type-fields class))))

4
gnucash/import-export/qif-imp/string.scm
View File

@ -98,7 +98,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (gnc:string-delete-chars s chars)
(string-delete s (lambda (c) (string-index chars c))))
(string-delete (lambda (c) (string-index chars c)) s))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -108,7 +108,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (gnc:list-display lst)
(for-each (lambda (elt) (display elt)) lst))
(for-each display lst))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:list-display-to-string

14
gnucash/import-export/qif-imp/test/CMakeLists.txt
View File

@ -3,6 +3,18 @@
set(QIF_IMP_TEST_INCLUDE_DIRS)
set(QIF_IMP_TEST_LIBS)
set(scm_qifimp_test_with_srfi64_SOURCES
test-qif-imp.scm
test-qif-parse.scm
test-qif-merge-groups.scm
)
gnc_add_test(test-link-qif-imp test-link.c QIF_IMP_TEST_INCLUDE_DIRS QIF_IMP_TEST_LIBS)
set_dist_list(test_qif_import_DIST CMakeLists.txt test-link.c)
if (HAVE_SRFI64)
gnc_add_scheme_tests("${scm_qifimp_test_with_srfi64_SOURCES}")
endif (HAVE_SRFI64)
set_dist_list(test_qif_import_DIST CMakeLists.txt test-link.c
${scm_qifimp_test_with_srfi64_SOURCES})

60
gnucash/import-export/qif-imp/test/test-qif-imp.scm Normal file
View File

@ -0,0 +1,60 @@
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash import-export qif-import))
(use-modules (gnucash import-export string))
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-qif-imp")
(test-string)
(test-qif-objects)
(test-end "test-qif-imp"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-string)
(test-equal "string-rcontains"
9
(gnc:string-rcontains "foobarfoobarf" "bar"))
(test-equal "string-rcontains"
2
(gnc:substring-count "foobarfoobarfoo" "bar"))
(test-equal "substring-split"
'("foo" "foo" "f")
(gnc:substring-split "foobarfoobarf" "bar"))
(test-equal "string-replace-char"
"fcc"
(gnc:string-replace-char "foo" #\o #\c))
(test-equal "string-delete"
"ad"
(gnc:string-delete-chars "abcd" "cb"))
(test-equal "list-display"
"abc"
(with-output-to-string
(lambda ()
(gnc:list-display '("a" "b" "c")))))
(test-equal "list-display-to-string"
"abc"
(gnc:list-display-to-string '("a" "b" "c"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-objects.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (test-qif-objects)
(test-assert "make-qif-file is called from C"
(make-qif-file))
(test-assert "make-ticker-map is called from C"
(make-ticker-map)))

113
gnucash/import-export/qif-imp/test/test-qif-merge-groups.scm Normal file
View File

@ -0,0 +1,113 @@
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash import-export qif-import))
(use-modules (gnucash import-export string))
(use-modules (gnucash engine test test-extras))
(use-modules (gnucash report report-system))
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-qif-merge-groups")
(test-gnc:account-tree-get-transactions)
(test-gnc:account-tree-find-duplicates)
(test-end "test-qif-merge-groups"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-merge-groups.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (teardown)
(gnc-clear-current-session))
(define (test-gnc:account-tree-get-transactions)
(define gnc:account-tree-get-transactions
(@@ (gnucash import-export qif-import) gnc:account-tree-get-transactions))
(test-group-with-cleanup "test-gnc:account-tree-get-transactions"
(create-test-data)
(test-equal "gnc:account-tree-get-transactions"
59
(length
(gnc:account-tree-get-transactions (gnc-get-current-root-account))))
(teardown)))
(define (test-gnc:account-tree-find-duplicates)
(define gnc:account-tree-find-duplicates
(@@ (gnucash import-export qif-import) gnc:account-tree-find-duplicates))
(define new-structure
(list "Root" (list (cons 'type ACCT-TYPE-ASSET))
(list "Asset"
(list "Bank")
(list "Wallet")
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE))))))
(test-group-with-cleanup "test-gnc:account-tree-find-duplicates"
(let* ((env (create-test-env))
(old-alist (create-test-data))
(old-root (assoc-ref old-alist "Root"))
(old-bank (assoc-ref old-alist "Bank"))
(old-expenses (assoc-ref old-alist "Expenses"))
(old-wallet (assoc-ref old-alist "Wallet"))
(new-alist (env-create-account-structure-alist env new-structure))
(new-root (assoc-ref new-alist "Root"))
(new-bank (assoc-ref new-alist "Bank"))
(new-expenses (assoc-ref new-alist "Expenses"))
(new-wallet (assoc-ref new-alist "Wallet")))
;; the following are the qif-transactions:
(define new-txn1 (env-transfer env 01 01 1970 new-bank new-expenses 5))
;; note the old-book txn is dated 14.02.1971; the new-book dated
;; 20.02.1971 will match because it's less than 1wk away. note
;; the old-book txn is a multisplit, but it will still match
;; because the bank value is -100.
(define new-txn2 (env-transfer env 20 02 1971 new-bank new-expenses 100))
;; old-book txn dated 13.02.1971 will also match above txn
(define old-txn2 (env-transfer env 13 02 1971 old-bank old-expenses 100))
;; the following imported txn will not match an existing
;; txn because the date difference from 14.02.1971 is > 1 week
(define new-txn3 (env-transfer env 22 02 1971 new-bank new-expenses 100))
(let ((matches (gnc:account-tree-find-duplicates old-root new-root #f)))
(test-equal "test-gnc:account-tree-find-duplicates - 2 txns matched"
2
(length matches))
(display "before pruning\n")
(test-equal "test-gnc:account-tree-find-duplicates - 1st txn matches 1"
1
(length (assoc-ref matches new-txn1)))
(test-equal "test-gnc:account-tree-find-duplicates - 2nd txn matches 2"
2
(length (assoc-ref matches new-txn2)))
(test-equal "test-gnc:account-tree-find-duplicates - 3nd txn matches none"
#f
(assoc-ref matches new-txn3))
(test-assert "mark the new-txn2, 1st match as duplicate"
(set-cdr! (car (assoc-ref matches new-txn2)) #t))
(test-assert "gnc:prune-matching-transactions completed"
(gnc:prune-matching-transactions matches)))
(let ((matches (gnc:account-tree-find-duplicates old-root new-root #f)))
(display "after pruning:\n")
(test-equal "test-gnc:account-tree-find-duplicates - 1st txn matches 1"
1
(length (assoc-ref matches new-txn1)))
(test-equal "test-gnc:account-tree-find-duplicates - 2nd txn destroyed"
#f
(assoc-ref matches new-txn2))))
(teardown)))

308
gnucash/import-export/qif-imp/test/test-qif-parse.scm Normal file
View File

@ -0,0 +1,308 @@
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(use-modules (gnucash import-export qif-import))
(use-modules (gnucash import-export string))
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-qif-imp")
(test-qif-parse:fix-year)
(test-qif-parse:parse-acct-type)
(test-qif-parse:parse-cleared-field)
(test-qif-parse:parse-action-field)
(test-qif-parse:check-date-format)
(test-qif-parse:parse-date/format)
(test-qif-parse:check-number-format)
(test-qif-parse:parse-number/format)
(test-qif-parse:check-number-formats)
(test-qif-parse:parse-numbers/format)
(test-qif-split:parse-category)
(test-end "test-qif-imp"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following isn't exported but can be tested anyway!
(define qif-parse:fix-year
(@@ (gnucash import-export qif-import) qif-parse:fix-year))
(define qif-parse:parse-acct-type
(@@ (gnucash import-export qif-import) qif-parse:parse-acct-type))
(define qif-parse:parse-cleared-field
(@@ (gnucash import-export qif-import) qif-parse:parse-cleared-field))
(define qif-split:parse-category
(@@ (gnucash import-export qif-import) qif-split:parse-category))
(define qif-parse:parse-action-field
(@@ (gnucash import-export qif-import) qif-parse:parse-action-field))
(define qif-parse:check-date-format
(@@ (gnucash import-export qif-import) qif-parse:check-date-format))
(define qif-parse:parse-date/format
(@@ (gnucash import-export qif-import) qif-parse:parse-date/format))
(define qif-parse:check-number-format
(@@ (gnucash import-export qif-import) qif-parse:check-number-format))
(define qif-parse:parse-number/format
(@@ (gnucash import-export qif-import) qif-parse:parse-number/format))
(define qif-parse:check-number-formats
(@@ (gnucash import-export qif-import) qif-parse:check-number-formats))
(define qif-parse:parse-numbers/format
(@@ (gnucash import-export qif-import) qif-parse:parse-numbers/format))
(define (test-qif-parse:fix-year)
(test-equal "qif-parse:fix-year 1998"
1998
(qif-parse:fix-year "1998" 50))
(test-equal "qif-parse:fix-year ' 0 = 2000"
2000
(qif-parse:fix-year "' 0" 50))
(test-equal "qif-parse:fix-year 98>50 = 1998"
1998
(qif-parse:fix-year "98" 50))
(test-equal "qif-parse:fix-year 48<50 = 2048"
2048
(qif-parse:fix-year "48" 50))
(test-equal "qif-parse:fix-year 19134 = 2034"
2034
(qif-parse:fix-year "19134" 50))
(test-equal "qif-parse:fix-year 102 = 2002"
2002
(qif-parse:fix-year "102" 50)))
(define (test-qif-parse:parse-acct-type)
(test-equal "qif-parse:parse-acct-type ccard"
(list 3)
(qif-parse:parse-acct-type "ccard" #f #f))
(test-equal "qif-parse:parse-acct-type oth s"
(list 2 0 1)
(qif-parse:parse-acct-type "oth s" #f #f))
(test-equal "qif-parse:parse-acct-type zzz"
(list 0)
(qif-parse:parse-acct-type "zzz" (const #f) #f)))
(define (test-qif-parse:parse-cleared-field)
(test-equal "qif-parse:parse-cleared-field xx = reconciled"
'reconciled
(qif-parse:parse-cleared-field "xx" (const #f) #f))
(test-equal "qif-parse:parse-cleared-field cc = cleared"
'cleared
(qif-parse:parse-cleared-field "cc" (const #f) #f))
(test-equal "qif-parse:parse-cleared-field !! = budgeted"
'budgeted
(qif-parse:parse-cleared-field "!!" (const #f) #f))
(test-equal "qif-parse:parse-cleared-field qq = #f"
#f
(qif-parse:parse-cleared-field "qq" (const #f) #f)))
(define (test-qif-parse:parse-action-field)
(test-equal "qif-parse:parse-action-field BuY"
'buy
(qif-parse:parse-action-field "BuY" (const #f) #f))
(test-equal "qif-parse:parse-action-field WithDrwX"
'xout
(qif-parse:parse-action-field "WithDrwX" (const #f) #f))
(test-equal "qif-parse:parse-action-field k.gewspx"
'cgshortx
(qif-parse:parse-action-field "k.gewspx" (const #f) #f)))
(define (test-qif-parse:check-date-format)
(test-equal "qif-parse:check-date-format 20/02/1981"
'(d-m-y)
(qif-parse:check-date-format
"20/02/1981"
'(d-m-y y-m-d y-d-m m-d-y)))
(test-equal "qif-parse:check-date-format 12/02/1981"
'(d-m-y m-d-y)
(qif-parse:check-date-format
"12/02/1981"
'(d-m-y y-m-d y-d-m m-d-y)))
(test-equal "qif-parse:check-date-format 1979/03/03"
'(y-m-d y-d-m)
(qif-parse:check-date-format
"1979/03/03"
'(d-m-y y-m-d m-d-y y-d-m)))
(test-equal "qif-parse:check-date-format 19790303"
'(y-m-d y-d-m)
(qif-parse:check-date-format
"19790303"
'(d-m-y y-m-d m-d-y y-d-m))))
(define (test-qif-parse:parse-date/format)
(test-equal "qif-parse:parse-date/format ok"
(list 31 01 1981)
(qif-parse:parse-date/format "31/01/81" 'd-m-y))
(test-equal "qif-parse:parse-date/format error"
#f
(qif-parse:parse-date/format "31/01/81" 'm-d-y)))
(define (test-qif-parse:check-number-format)
(test-equal "test-qif-parse:check-number-format 1,00"
'(comma)
(qif-parse:check-number-format "1,00" '(comma integer decimal)))
(test-equal "test-qif-parse:check-number-format 999"
'(comma integer decimal)
(qif-parse:check-number-format "999" '(comma integer decimal)))
(test-equal "test-qif-parse:check-number-format 999.20"
'(decimal)
(qif-parse:check-number-format "999.20" '(comma integer decimal)))
(test-equal "test-qif-parse:check-number-format 9.200,99"
'(comma)
(qif-parse:check-number-format "9.200,99" '(comma integer decimal)))
(test-equal "test-qif-parse:check-number-format $1000"
'(comma integer decimal)
(qif-parse:check-number-format "$1000" '(comma integer decimal))))
(define (test-qif-parse:parse-number/format)
(test-equal "qif-parse:parse-number/format 1,23"
123/100
(qif-parse:parse-number/format "1,23" 'comma))
(test-equal "qif-parse:parse-number/format 1,234.00"
1234
(qif-parse:parse-number/format "1,234.00" 'decimal))
(test-equal "qif-parse:parse-number/format -1234"
-1234
(qif-parse:parse-number/format "-1234" 'integer))
(test-equal "qif-parse:parse-number/format 1234"
1234
(qif-parse:parse-number/format "1234" 'integer))
)
(define (test-qif-parse:check-number-formats)
(test-equal "qif-parse:check-number-formats 1,000 2,000 300"
'(comma)
(qif-parse:check-number-formats '("1,00" "2,00" "300,00")
'(decimal comma integer)))
(test-equal "qif-parse:check-number-formats 10.50 20.54"
'(decimal)
(qif-parse:check-number-formats '("10.50" "20.54")
'(decimal comma integer)))
(test-equal "qif-parse:check-number-formats 1234 4567"
'(decimal comma integer)
(qif-parse:check-number-formats '("1234" "4567")
'(decimal comma integer))))
(define (test-qif-parse:parse-numbers/format)
(test-equal "qif-parse:parse-numbers/format 1,00 2,00 300,00"
'(1 2 300)
(qif-parse:parse-numbers/format '("1,00" "2,00" "300,00")
'comma))
(test-equal "qif-parse:parse-numbers/format 1,00 2,50 3,99"
'(1 5/2 399/100)
(qif-parse:parse-numbers/format '("1,00" "2,50" "3,99")
'comma))
(test-equal "qif-parse:parse-numbers/format 1.00 2.00 300.00"
'(1 2 300)
(qif-parse:parse-numbers/format '("1.00" "2.00" "300.00")
'decimal))
(test-equal "qif-parse:parse-numbers/format 1 2 300"
'(1 2 300)
(qif-parse:parse-numbers/format '("1" "2" "300")
'integer))
(test-equal "qif-parse:parse-numbers/format 1 * 300"
'(1 0 300)
(qif-parse:parse-numbers/format '("1" "*" "300")
'integer))
(test-equal "qif-parse:parse-numbers/format 1 #f 300"
'(1 0 300)
(qif-parse:parse-numbers/format '("1" #f "300")
'integer)))
;; unfinished
(define (test-qif-split:parse-category)
(test-equal "qif-split:parse-category [Transfer]/Class"
'("Transfer" #t "Class" #f #f #f)
(qif-split:parse-category #f "[Transfer]/Class"))
(test-equal "qif-split:parse-category Category/Class"
'("Category" #f "Class" #f #f #f)
(qif-split:parse-category #f "Category/Class"))
(test-equal "qif-split:parse-category Category"
'("Category" #f "" #f #f #f)
(qif-split:parse-category #f "Category"))
(test-equal "qif-split:parse-category [Transfer]"
'("Transfer" #t "" #f #f #f)
(qif-split:parse-category #f "[Transfer]"))
(test-equal "qif-split:parse-category Category/|miscx-category"
'("Category" #f "" "miscx-category" #f "")
(qif-split:parse-category #f "Category/|miscx-category"))
(test-equal "qif-split:parse-category Category/|[miscx-account]"
'("Category" #f "" "miscx-account" #t "")
(qif-split:parse-category #f "Category/|[miscx-account]"))
(test-equal "qif-split:parse-category Category/|miscx-category/miscx-class"
'("Category" #f "" "miscx-category" #f "miscx-class")
(qif-split:parse-category #f "Category/|miscx-category/miscx-class"))
(test-equal "qif-split:parse-category Category/|[miscx-account]/miscx-class"
'("Category" #f "" "miscx-account" #t "miscx-class")
(qif-split:parse-category #f "Category/|[miscx-account]/miscx-class")))

31
gnucash/register/ledger-core/gnc-ledger-display.c
View File

@ -70,6 +70,8 @@ struct gnc_ledger_display
GNCLedgerDisplayGetParent get_parent;
gpointer user_data;
gint number_of_subaccounts;
gint component_id;
};
@ -87,9 +89,13 @@ gnc_ledger_display_internal (Account *lead_account, Query *q,
SplitRegisterStyle style,
gboolean use_double_line,
gboolean is_template);
static void gnc_ledger_display_refresh_internal (GNCLedgerDisplay *ld,
GList *splits);
static void gnc_ledger_display_refresh_internal (GNCLedgerDisplay *ld,
GList *splits);
static void gnc_ledger_display_make_query (GNCLedgerDisplay *ld,
gint limit,
SplitRegisterType type);
/** Implementations *************************************************/
@ -572,6 +578,21 @@ refresh_handler (GHashTable *changes, gpointer user_data)
}
}
/* if subaccount ledger, check to see if still the same number
* of subaccounts, if not recreate the query. */
if (ld->ld_type == LD_SUBACCOUNT)
{
Account *leader = gnc_ledger_display_leader (ld);
GList *accounts = gnc_account_get_descendants (leader);
if (g_list_length (accounts) != ld->number_of_subaccounts)
gnc_ledger_display_make_query (ld,
gnc_prefs_get_float(GNC_PREFS_GROUP_GENERAL_REGISTER, GNC_PREF_MAX_TRANS),
gnc_get_reg_type (leader, ld->ld_type));
g_list_free (accounts);
}
/* Its not clear if we should re-run the query, or if we should
* just use qof_query_last_run(). Its possible that the dates
* changed, requiring a full new query. Similar considerations
@ -647,8 +668,14 @@ gnc_ledger_display_make_query (GNCLedgerDisplay *ld,
leader = gnc_ledger_display_leader (ld);
/* if this is a subaccount ledger, record the number of
* subaccounts so we can determine if the query needs
* recreating on a refresh. */
if (ld->ld_type == LD_SUBACCOUNT)
{
accounts = gnc_account_get_descendants (leader);
ld->number_of_subaccounts = g_list_length (accounts);
}
else
accounts = NULL;

44
gnucash/register/ledger-core/split-register.c
View File

@ -1735,8 +1735,12 @@ gnc_split_register_save (SplitRegister *reg, gboolean do_commit)
blank_split, blank_trans, pending_trans, trans);
/* Act on any changes to the current cell before the save. */
(void) gnc_split_register_check_cell (reg,
gnc_table_get_current_cell_name (reg->table));
if (!gnc_split_register_check_cell (reg,
gnc_table_get_current_cell_name (reg->table)))
{
LEAVE("need another go at changing cell");
return FALSE;
}
if (!gnc_split_register_auto_calc (reg, split))
{
@ -1945,6 +1949,10 @@ gnc_split_register_get_account_by_name (SplitRegister *reg, BasicCell * bcell,
if (!account)
account = gnc_account_lookup_by_code(gnc_get_current_root_account(), name);
/* if gnc_ui_new_accounts_from_name_window is used, there is a call to
* refresh which subsequently calls this function again, thats the
* reason for static creating_account. */
if (!account && !creating_account)
{
/* Ask if they want to create a new one. */
@ -1958,21 +1966,27 @@ gnc_split_register_get_account_by_name (SplitRegister *reg, BasicCell * bcell,
return NULL;
}
/* Now have the account. */
account_name = gnc_get_account_name_for_split_register (account, reg->show_leaf_accounts);
if (g_strcmp0(account_name, gnc_basic_cell_get_value(bcell)))
if (!creating_account)
{
/* The name has changed. Update the cell. */
gnc_combo_cell_set_value (cell, account_name);
gnc_basic_cell_set_changed (&cell->cell, TRUE);
}
g_free (account_name);
/* Now have the account. */
account_name = gnc_get_account_name_for_split_register (account, reg->show_leaf_accounts);
if (g_strcmp0(account_name, gnc_basic_cell_get_value(bcell)))
{
/* The name has changed. Update the cell. */
gnc_combo_cell_set_value (cell, account_name);
gnc_basic_cell_set_changed (&cell->cell, TRUE);
}
g_free (account_name);
/* See if the account (either old or new) is a placeholder. */
if (xaccAccountGetPlaceholder (account))
{
gnc_error_dialog (GTK_WINDOW (gnc_split_register_get_parent (reg)),
placeholder, name);
/* See if the account (either old or new) is a placeholder. */
if (account && xaccAccountGetPlaceholder (account))
{
gchar *fullname = gnc_account_get_full_name (account);
gnc_error_dialog (GTK_WINDOW (gnc_split_register_get_parent (reg)),
placeholder, fullname);
g_free (fullname);
return NULL;
}
}
/* Be seeing you. */

8
gnucash/register/register-gnome/gnucash-sheet.c
View File

@ -1855,7 +1855,12 @@ gnucash_sheet_key_press_event_internal (GtkWidget *widget, GdkEventKey *event)
/* If that would leave the register, abort */
if (abort_move)
{
// Make sure the sheet is the focus
if (!gtk_widget_has_focus(GTK_WIDGET (sheet)))
gtk_widget_grab_focus (GTK_WIDGET (sheet));
return TRUE;
}
/* Clear the saved selection for the new cell. */
sheet->end_sel = sheet->start_sel;
@ -2671,7 +2676,6 @@ gnucash_sheet_tooltip (GtkWidget *widget, gint x, gint y,
gpointer user_data)
{
GnucashSheet *sheet = GNUCASH_SHEET (widget);
GnucashCursor *cursor = sheet->cursor;
Table *table = sheet->table;
VirtualLocation virt_loc;
gchar *tooltip_text;
@ -2711,7 +2715,7 @@ gnucash_sheet_tooltip (GtkWidget *widget, gint x, gint y,
by = block->origin_y;
// get the cell location and dimensions
gnucash_sheet_style_get_cell_pixel_rel_coords (cursor->style,
gnucash_sheet_style_get_cell_pixel_rel_coords (block->style,
virt_loc.phys_row_offset, virt_loc.phys_col_offset,
&cx, &cy, &cw, &ch);

77
gnucash/report/eguile-html-utilities.scm
View File

@ -30,29 +30,24 @@
(gnc:module-load "gnucash/report" 0)
(gnc:module-load "gnucash/app-utils" 0)
(use-modules (gnucash report eguile-gnc))
(use-modules (ice-9 regex)) ; for regular expressions
(use-modules (srfi srfi-13)) ; for extra string functions
(define-public (escape-html s1)
;; Convert string s1 to escape HTML special characters < > and &
;; i.e. convert them to &lt; &gt; and &amp; respectively.
;; Maybe there's a way to do this in one go... (but order is important)
(set! s1 (regexp-substitute/global #f "&" s1 'pre "&amp;" 'post))
(set! s1 (regexp-substitute/global #f "<" s1 'pre "&lt;" 'post))
(regexp-substitute/global #f ">" s1 'pre "&gt;" 'post))
(define (string-repeat s n)
;; return a string made of n copies of string s
(string-join (make-list n s) ""))
(define-public (nl->br str)
;; Replace newlines with <br>
(regexp-substitute/global #f "\n" str 'pre "<br>" 'post))
(string-substitute-alist str '((#\newline . "<br/>"))))
(define-public (nbsp str)
;; Replace spaces with &nbsp; (non-breaking spaces)
;; (yes, I know <nobr> is non-standard, but webkit splits e.g. "-£40.00" between
;; the '-' and the '£' without it.)
(string-append
"<nobr>"
(regexp-substitute/global #f " " str 'pre "&nbsp;" 'post)
"</nobr>"))
(string-append
"<span style=\"white-space:nowrap;\">"
(string-substitute-alist str '((#\space . "&nbsp;")))
"</span>"))
(define-public (empty-cells n)
;; Display n empty table cells
@ -61,7 +56,8 @@
(define-public (indent-cells n)
;; Display n empty table cells with width attribute for indenting
;; (the &nbsp;s are just there in case CSS isn't working)
(display (string-repeat "<td min-width=\"32\" class=\"indent\">&nbsp;&nbsp;</td>" n)))
(display
(string-repeat "<td min-width=\"32\" class=\"indent\">&nbsp;&nbsp;</td>" n)))
(define-public (negstyle item)
;; apply styling for negative amounts
@ -84,9 +80,13 @@
(define-public (display-comm-coll-total comm-coll negative?)
;; Display the total(s) of a commodity collector as HTML
(for-each
(lambda (pair)
(display (nbsp (gnc:monetary->string pair))))
(comm-coll 'format gnc:make-gnc-monetary negative?)))
(lambda (pair)
(display (nbsp (gnc:monetary->string pair))))
(comm-coll 'format gnc:make-gnc-monetary negative?)))
;; (thanks to Peter Brett for this regexp and the use of match:prefix)
(define fontre
(make-regexp "([[:space:]]+(bold|semi-bold|book|regular|medium|light))?([[:space:]]+(normal|roman|italic|oblique))?([[:space:]]+(condensed))?[[:space:]]+([[:digit:]]+)" regexp/icase))
(define-public (font-name-to-style-info font-name)
;;; Convert a font name as return by a font option to CSS format.
@ -96,31 +96,28 @@
(font-weight "normal")
(font-style "normal")
(font-size "medium")
(match "")
; (thanks to Peter Brett for this regexp and the use of match:prefix)
(fontre (make-regexp "([[:space:]]+(bold|semi-bold|book|regular|medium|light))?([[:space:]]+(normal|roman|italic|oblique))?([[:space:]]+(condensed))?[[:space:]]+([[:digit:]]+)" regexp/icase))
(match (regexp-exec fontre font-name)))
(if match
(begin
; font name parsed OK -- assemble the bits for CSS
(set! font-family (match:prefix match))
(if (match:substring match 2)
; weight given -- some need translating
(when match
;; font name parsed OK -- assemble the bits for CSS
(set! font-family (match:prefix match))
(if (match:substring match 2)
;; weight given -- some need translating
(let ((weight (match:substring match 2)))
(cond
((string-ci=? weight "bold") (set! font-weight "bold"))
((string-ci=? weight "semi-bold") (set! font-weight "600"))
((string-ci=? weight "light") (set! font-weight "200")))))
(if (match:substring match 4)
; style
((string-ci=? weight "bold") (set! font-weight "bold"))
((string-ci=? weight "semi-bold") (set! font-weight "600"))
((string-ci=? weight "light") (set! font-weight "200")))))
(if (match:substring match 4)
;; style
(let ((style (match:substring match 4)))
(cond
((string-ci=? style "italic") (set! font-style "italic"))
((string-ci=? style "oblique") (set! font-style "oblique")))))
; ('condensed' is ignored)
(if (match:substring match 7)
; size is in points
(set! font-size (string-append (match:substring match 7) "pt")))))
; construct the result (the order of these is important)
(string-append "font: " font-weight " " font-style " " font-size " \"" font-family "\";")))
((string-ci=? style "italic") (set! font-style "italic"))
((string-ci=? style "oblique") (set! font-style "oblique")))))
;; ('condensed' is ignored)
(if (match:substring match 7)
;; size is in points
(set! font-size (string-append (match:substring match 7) "pt"))))
;; construct the result (the order of these is important)
(string-append "font: " font-weight " " font-style
" " font-size " \"" font-family "\";")))

72
gnucash/report/eguile-utilities.scm
View File

@ -31,7 +31,6 @@
(gnc:module-load "gnucash/report" 0)
(gnc:module-load "gnucash/app-utils" 0)
(define-public (fmtnumber n)
;; Format a number (integer or real) into something printable
(number->string (if (integer? n)
@ -44,28 +43,18 @@
(define-public (gnc-monetary-neg? monetary)
; return true if the monetary value is negative
(gnc-numeric-negative-p (gnc:gnc-monetary-amount monetary)))
(define-public (string-repeat s n)
;; return a string made of n copies of string s
;; (there's probably a better way)
(let ((s2 ""))
(do ((i 1 (1+ i))) ((> i n))
(set! s2 (string-append s2 s)))
s2))
(negative? (gnc:gnc-monetary-amount monetary)))
;; 'Safe' versions of cdr and cadr that don't crash
;; if the list is empty (is there a better way?)
(define-public (safe-cdr l)
(if (null? l)
'()
(cdr l)))
(if (null? l) '()
(cdr l)))
(define-public (safe-cadr l)
(if (null? l)
'()
(if (null? (cdr l))
'()
(cadr l))))
(cond
((null? l) '())
((null? (cdr l)) '())
(else (cadr l))))
; deprecated - use find-stylesheet or find-template instead
(define-public (find-file fname)
@ -77,11 +66,10 @@
(templatepath (find-template fname)))
; make sure there's a trailing delimiter
(issue-deprecation-warning "find-file is deprecated. Please use find-stylesheet or find-template instead.")
(if (access? stylesheetpath R_OK)
stylesheetpath
(if (access? templatepath R_OK)
templatepath
fname))))
(cond
((access? stylesheetpath R_OK) stylesheetpath)
((access? templatepath R_OK) templatepath)
(else fname))))
(define (find-internal ftype fname)
;; Find the file fname', and return its full path.
@ -113,29 +101,17 @@
; Define syntax for more readable for loops (the built-in for-each requires an
; explicit lambda and has the list expression all the way at the end).
(define-syntax for
(syntax-rules (for in => do hash)
; Multiple variables and equal number of lists (in
; parenthesis). e.g.:
;
; (for (a b) in (lsta lstb) do (display (+ a b)))
;
; Note that this template must be defined before the
; next one, since the template are evaluated in-order.
((for (<var> ...) in (<list> ...) do <expr> ...)
(for-each (lambda (<var> ...) <expr> ...) <list> ...))
; Single variable and list. e.g.:
;
; (for a in lst do (display a))
((for <var> in <list> do <expr> ...)
(for-each (lambda (<var>) <expr> ...) <list>))
; Iterate over key & values in a hash. e.g.:
;
; (for key => value in hash do (display (* key value)))
((for <key> => <value> in <hash> do <expr> ...)
; We use fold to iterate over the hash (instead of
; hash-for-each, since that is not present in guile
; 1.6).
(hash-fold (lambda (<key> <value> accum) (begin <expr> ... accum)) *unspecified* <hash>))
))
(export for)
(define-syntax for
(syntax-rules (for in do)
;; Multiple variables and equal number of lists (in
;; parenthesis). e.g.:
;; (for (a b) in (lsta lstb) do (display (+ a b)))
;; Note that this template must be defined before the
;; next one, since the template are evaluated in-order.
((for (<var> ...) in (<list> ...) do <expr> ...)
(for-each (lambda (<var> ...) <expr> ...) <list> ...))
;; Single variable and list. e.g.: (for a in lst do (display a))
((for <var> in <list> do <expr> ...)
(for-each (lambda (<var>) <expr> ...) <list>))))

101
gnucash/report/eguile.scm
View File

@ -88,17 +88,24 @@
(use-modules (ice-9 local-eval)) ; for the-environment
(use-modules (gnucash app-utils)) ; for _
(define-public (string-substitute-alist str sub-alist)
(with-output-to-string
(lambda ()
(string-for-each
(lambda (c)
(display
(or (assv-ref sub-alist c)
c)))
str))))
;; This is needed for displaying error messages -- note that it assumes that
;; the output is HTML, which is a pity, because otherwise this module is
;; non-specific -- it is designed to output a mixture of Guile and any other
;; sort of text. Oh well.
(define (escape-html s1)
;; convert string s1 to escape HTML special characters < > and &
;; i.e. convert them to &lt; &gt; and &amp; respectively.
;; Maybe there's a way to do this in one go... (but order is important)
(set! s1 (regexp-substitute/global #f "&" s1 'pre "&amp;" 'post))
(set! s1 (regexp-substitute/global #f "<" s1 'pre "&lt;" 'post))
(regexp-substitute/global #f ">" s1 'pre "&gt;" 'post))
(define-public (escape-html s1)
(string-substitute-alist s1 '((#\< . "&lt;")
(#\> . "&gt;")
(#\& . "&amp;"))))
;; regexps used to find start and end of code segments
(define startre (make-regexp "<\\?scm(:d)?[[:space:]]"))
@ -127,44 +134,40 @@
;; display either code or text
(define (display-it t code?)
(if code?
(display t)
(display-text t)))
(display t)
(display-text t)))
(define stop textstop) ; text to output at end of current section
;; switch between code and text modes
(define (switch-mode code? dmodifier?)
(display stop)
(if code?
(begin ; code mode to text mode
(display textstart)
(set! stop textstop))
(begin ; text mode to code mode
(if dmodifier?
(begin
(display dcodestart)
(set! stop dcodestop))
(begin
(display codestart)
(set! stop codestop))))))
(cond
(code? (display textstart)
(set! stop textstop))
(dmodifier? (display dcodestart)
(set! stop dcodestop))
(else (display codestart)
(set! stop codestop))))
;; recursively process input stream
(define (loop inp needle other code? line)
(if (equal? line "")
(when (string-null? line)
(set! line (read-line inp 'concat)))
(if (not (eof-object? line))
(let ((match (regexp-exec needle line)))
(if match
(let ((dmodifier? #f))
(display-it (match:prefix match) code?)
(if (not code?)
; switching from text to code -- check for modifier
(set! dmodifier? (match:substring match 1)))
(switch-mode code? dmodifier?)
(loop inp other needle (not code?) (match:suffix match)))
(begin ; no match - output whole line and continue
(display-it line code?)
(loop inp needle other code? ""))))))
(unless (eof-object? line)
(cond
((regexp-exec needle line)
=> (lambda (rmatch)
(let ((dmodifier? #f))
(display-it (match:prefix rmatch) code?)
(unless code?
;; switching from text to code -- check for modifier
(set! dmodifier? (match:substring rmatch 1)))
(switch-mode code? dmodifier?)
(loop inp other needle (not code?) (match:suffix rmatch)))))
(else ; no match - output whole line and continue
(display-it line code?)
(loop inp needle other code? "")))))
(display textstart)
(loop (current-input-port) startre endre #f "")
@ -175,7 +178,7 @@
;; Evaluate input containing Scheme code, trapping errors
;; e.g. (display "Text ")(display (+ x 2))(display ".") -> Text 42.
;; Parameters:
;; env - environment in which to do the evaluation;
;; env - environment in which to do the evaluation;
;; if #f, (the-environment) will be used
(define (script->output env)
; Placeholder for the normal stack and error stack in case of an error
@ -188,7 +191,7 @@
; Capture the current stack, so we can detect from where we
; need to display the stack trace
(set! good-stack (make-stack #t))
(local-eval s-expression (or env (the-environment)))
(local-eval s-expression (or env (the-environment)))
(set! s-expression (read)))))
; Error handler to display any errors while evaluating the template
@ -214,7 +217,10 @@
(error-length (stack-length error-stack)))
; Show the backtrace. Remove one extra from the "first"
; argument, since that is an index, not a count.
(display-backtrace error-stack (current-output-port) (- (- error-length remove-top) 1) (- (- error-length remove-top) remove-bottom)))
(display-backtrace error-stack
(current-output-port)
(- (- error-length remove-top) 1)
(- (- error-length remove-top) remove-bottom)))
(display "</pre><br>"))
; This handler will be called by catch before unwinding the
@ -242,15 +248,18 @@
;; Process a template file and return the result as a string
(define (eguile-file-to-string infile environment)
(if (not (access? infile R_OK))
(format #f (_ "Template file \"~a\" can not be read") infile)
(let ((script (with-input-from-file
infile
(lambda () (with-output-to-string template->script)))))
(cond
((not (access? infile R_OK))
(format #f (_ "Template file \"~a\" can not be read") infile))
(else
(let ((script (with-input-from-file infile
(lambda ()
(with-output-to-string template->script)))))
(with-output-to-string
(lambda () (with-input-from-string
script
(lambda () (script->output environment))))))))
(lambda ()
(with-input-from-string script
(lambda ()
(script->output environment)))))))))
(export eguile-file-to-string)

55
gnucash/report/reports/standard/balsheet-eg.scm
View File

@ -37,7 +37,6 @@
(use-modules (gnucash gettext))
(use-modules (gnucash eguile))
(use-modules (ice-9 regex)) ; for regular expressions
(use-modules (ice-9 local-eval)) ; for the-environment
(use-modules (srfi srfi-13)) ; for extra string functions
@ -46,38 +45,6 @@
(define debugging? #f)
;;; these could go into a separate module..........
;;;
;; Useful routines to use in the template
(define (escape-html s1)
;; convert string s1 to escape HTML special characters < > and &
;; i.e. convert them to &lt; &gt; and &amp; respectively.
;; Maybe there's a way to do this in one go... (but order is important)
(set! s1 (regexp-substitute/global #f "&" s1 'pre "&amp;" 'post))
(set! s1 (regexp-substitute/global #f "<" s1 'pre "&lt;" 'post))
(regexp-substitute/global #f ">" s1 'pre "&gt;" 'post))
(define (nl->br str)
;; replace newlines with <br>
(regexp-substitute/global #f "\n" str 'pre "<br />" 'post))
(define (nbsp str)
;; replace spaces with &nbsp; (non-breaking spaces)
;; (yes, I know <nobr> is non-standard, but webkit splits e.g. "-£40.00" between
;; the '-' and the '£' without it.)
(string-append "<nobr>" (regexp-substitute/global #f " " str 'pre "&nbsp;" 'post) "</nobr>"))
(define (dump x) (escape-html (object->string x)))
(define (ddump x) (display (dump x)))
(define (string-repeat s n)
;; return a string made of n copies of string s
;; (there's probably a better way)
(let ((s2 ""))
(do ((i 1 (1+ i))) ((> i n))
(set! s2 (string-append s2 s)))
s2))
(define (debug . args)
(if debugging?
(for arg in args do
@ -91,28 +58,6 @@
(display cols)
(display "\">&nbsp;</td></tr>\n"))
(define (empty-cells n)
;; Display n empty table cells
(display (string-repeat "<td class=\"empty\"></td>" n)))
(define (indent-cells n)
;; Display n empty table cells with width attribute for indenting
;; (the &nbsp;s are just there in case CSS isn't working)
(display (string-repeat "<td min-width=\"32\" class=\"indent\">&nbsp;&nbsp;</td>" n)))
;; 'Safe' versions of cdr and cadr that don't crash
;; if the list is empty (is there a better way?)
(define (safe-cdr l)
(if (null? l)
'()
(cdr l)))
(define (safe-cadr l)
(if (null? l)
'()
(if (null? (cdr l))
'()
(cadr l))))
(define (add-to-cc cc com num neg?)
; add a numeric and commodity to a commodity-collector,
; changing sign if required

2
gnucash/report/reports/support/taxinvoice.eguile.scm
View File

@ -341,7 +341,7 @@
?>
<tr valign="top">
<?scm (if opt-col-date (begin ?>
<td align="center" ><nobr><?scm:d (nbsp (qof-print-date (gncEntryGetDate entry))) ?></nobr></td>
<td align="center" ><?scm:d (nbsp (qof-print-date (gncEntryGetDate entry))) ?></td>
<?scm )) ?>
<td align="left"><?scm:d (gncEntryGetDescription entry) ?></td>
<!-- td align="left">< ?scm:d (gncEntryGetNotes entry) ?></td -->

67
libgnucash/app-utils/c-interface.scm
View File

@ -20,30 +20,25 @@
(captured-error #f)
(result #f))
(catch #t
(lambda ()
;; Execute the code in which
;; you want to catch errors here.
(if (procedure? cmd)
(set! result (apply cmd args)))
(if (string? cmd)
(set! result (eval-string cmd)))
)
(lambda (key . parameters)
;; Put the code which you want
;; to handle an error after the
;; stack has been unwound here.
(let* ((str-port (open-output-string)))
(display-backtrace captured-stack str-port)
(display "\n" str-port)
(print-exception str-port #f key parameters)
(set! captured-error (get-output-string str-port))))
(lambda (key . parameters)
;; Capture the stack here, cut the last 3 frames which are
;; make-stack, this one, and the throw handler.
(set! captured-stack (make-stack #t 3))))
(list result captured-error)
))
(lambda ()
;; Execute the code in which you want to catch errors here.
(cond
((procedure? cmd) (set! result (apply cmd args)))
((string? cmd) (set! result (eval-string cmd)))))
(lambda (key . parameters)
;; Put the code which you want to handle an error after the
;; stack has been unwound here.
(set! captured-error
(call-with-output-string
(lambda (port)
(display-backtrace captured-stack port)
(newline port)
(print-exception port #f key parameters)))))
(lambda (key . parameters)
;; Capture the stack here, cut the last 3 frames which are
;; make-stack, this one, and the throw handler.
(set! captured-stack (make-stack #t 3))))
(list result captured-error)))
;; gnc:eval-string-with-error-handling will evaluate the input string (cmd)
;; an captures any exception that would be generated. It returns
@ -53,7 +48,7 @@
;; We'll use this to wrap guile calls in C(++), allowing
;; the C(++) code to decide how to handle the errors.
(define (gnc:eval-string-with-error-handling cmd)
(gnc:call-with-error-handling cmd '()))
(gnc:call-with-error-handling cmd '()))
;; gnc:apply-with-error-handling will call guile's apply to run func with args
;; an captures any exception that would be generated. It returns
@ -63,33 +58,28 @@
;; We'll use this to wrap guile calls in C(++), allowing
;; the C(++) code to decide how to handle the errors.
(define (gnc:apply-with-error-handling func args)
(gnc:call-with-error-handling func args))
(gnc:call-with-error-handling func args))
(define (gnc:backtrace-if-exception proc . args)
(let* ((apply-result (gnc:apply-with-error-handling proc args))
(result (car apply-result))
(error (cadr apply-result)))
(if error
(begin
(display error (current-error-port))
(if (defined? 'gnc:warn)
(gnc:warn error)))
result)))
(cond
(error
(display error (current-error-port))
(when (defined? 'gnc:warn)
(gnc:warn error)))
(else result))))
;; This database can be used to store and retrieve translatable
;; strings. Strings that are returned by the lookup function are
;; translated with gettext.
(define (gnc:make-string-database)
(define string-hash (make-hash-table 23))
(define string-hash (make-hash-table))
(define (lookup key)
(_ (hash-ref string-hash key)))
(define (store key string)
(hash-set! string-hash key string))
(define (dispatch message . args)
(let ((func (case message
((lookup) lookup)
@ -98,5 +88,4 @@
(if func
(apply func args)
(gnc:warn "string-database: bad message" message "\n"))))
dispatch)

120
libgnucash/app-utils/options.scm
View File

@ -1653,70 +1653,68 @@ the option '~a'."))
(define callback-hash (make-hash-table 23))
(define last-callback-id 0)
(define new-names-alist
'(("Accounts to include" #f "Accounts")
("Exclude transactions between selected accounts?" #f
"Exclude transactions between selected accounts")
("Filter Accounts" #f "Filter By...")
("Flatten list to depth limit?" #f "Flatten list to depth limit")
("From" #f "Start Date")
("Report Accounts" #f "Accounts")
("Report Currency" #f "Report's currency")
("Show Account Code?" #f "Show Account Code")
("Show Full Account Name?" #f "Show Full Account Name")
("Show Multi-currency Totals?" #f "Show Multi-currency Totals")
("Show zero balance items?" #f "Show zero balance items")
("Sign Reverses?" #f "Sign Reverses")
("To" #f "End Date")
("Charge Type" #f "Action") ;easy-invoice.scm, renamed June 2018
;; the following 4 options in income-gst-statement.scm renamed Dec 2018
("Individual income columns" #f "Individual sales columns")
("Individual expense columns" #f "Individual purchases columns")
("Remittance amount" #f "Gross Balance")
("Net Income" #f "Net Balance")
;; transaction.scm:
("Use Full Account Name?" #f "Use Full Account Name")
("Use Full Other Account Name?" #f "Use Full Other Account Name")
("Void Transactions?" "Filter" "Void Transactions")
("Void Transactions" "Filter" "Void Transactions")
("Account Substring" "Filter" "Account Name Filter")
;; invoice.scm, renamed November 2018
("Individual Taxes" #f "Use Detailed Tax Summary")
))
(define (lookup-option section name)
(let ((section-hash (hash-ref option-hash section)))
(if section-hash
(let ((option-hash (hash-ref section-hash name)))
(if option-hash
option-hash
;; Option name was not found. Perhaps it was renamed ?
;; Let's try to map it to a known new name.
;; This list will try match names - if one is found
;; the next item will describe a pair.
;; (cons newsection newname)
;; If newsection is #f then reuse previous section name.
;;
;; Please note the rename list currently supports renaming
;; individual option names, or individual option names moved
;; to another section. It does not currently support renaming
;; whole sections.
(let* ((new-names-list (list
"Accounts to include" (cons #f "Accounts")
"Exclude transactions between selected accounts?" (cons #f "Exclude transactions between selected accounts")
"Filter Accounts" (cons #f "Filter By...")
"Flatten list to depth limit?" (cons #f "Flatten list to depth limit")
"From" (cons #f "Start Date")
"Report Accounts" (cons #f "Accounts")
"Report Currency" (cons #f "Report's currency")
"Show Account Code?" (cons #f "Show Account Code")
"Show Full Account Name?" (cons #f "Show Full Account Name")
"Show Multi-currency Totals?" (cons #f "Show Multi-currency Totals")
"Show zero balance items?" (cons #f "Show zero balance items")
"Sign Reverses?" (cons #f "Sign Reverses")
"To" (cons #f "End Date")
"Charge Type" (cons #f "Action") ;easy-invoice.scm, renamed June 2018
;; the following 4 options in income-gst-statement.scm renamed Dec 2018
"Individual income columns" (cons #f "Individual sales columns")
"Individual expense columns" (cons #f "Individual purchases columns")
"Remittance amount" (cons #f "Gross Balance")
"Net Income" (cons #f "Net Balance")
;; transaction.scm:
"Use Full Account Name?" (cons #f "Use Full Account Name")
"Use Full Other Account Name?" (cons #f "Use Full Other Account Name")
"Void Transactions?" (cons "Filter" "Void Transactions")
"Void Transactions" (cons "Filter" "Void Transactions")
"Account Substring" (cons "Filter" "Account Name Filter")
;; invoice.scm, renamed November 2018
"Individual Taxes" (cons "#f" "Use Detailed Tax Summary")
))
(name-match (member name new-names-list)))
(and name-match
(let ((new-section (car (cadr name-match)))
(new-name (cdr (cadr name-match))))
(gnc:debug
(format #f "option ~s/~s has been renamed to ~s/~s\n"
section name new-section new-name))
;; compare if new-section name exists.
(if new-section
;; if so, if it's different to current section name
;; then try new section name
(and (not (string=? new-section section))
(lookup-option new-section new-name))
;; else reuse section-name with new-name
(lookup-option section new-name)))))))
#f)))
(and section-hash
(or (hash-ref section-hash name)
;; Option name was not found. Perhaps it was renamed?
;; Let's try to map to a known new name. The alist
;; new-names-alist will try match names - car is the old
;; name, cdr is the 2-element list describing
;; newsection newname. If newsection is #f then reuse
;; previous section name. Please note the rename list
;; currently supports renaming individual option names,
;; or individual option names moved to another
;; section. It does not currently support renaming
;; whole sections.
(let ((name-match (assoc-ref new-names-alist name)))
(and name-match
(let ((new-section (car name-match))
(new-name (cadr name-match)))
(gnc:debug
(format #f "option ~a/~a has been renamed to ~a/~a\n"
section name new-section new-name))
(cond
;; new-name only
((not new-section)
(lookup-option section new-name))
;; new-section different to current section
;; name, and possibly new-name
((not (string=? new-section section))
(lookup-option new-section new-name))
;; no match, return #f
(else #f)))))))))
(define (option-changed section name)
(set! options-changed #t)

1
libgnucash/app-utils/test/CMakeLists.txt
View File

@ -47,6 +47,7 @@ set(test_app_utils_scheme_SOURCES
set (test_app_utils_scheme_SRFI64_SOURCES
test-date-utilities.scm
test-options.scm
)
gnc_add_scheme_test_targets(scm-test-load-app-utils-module

28
libgnucash/app-utils/test/test-options.scm Normal file
View File

@ -0,0 +1,28 @@
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (srfi srfi-64))
(use-modules (gnucash engine test srfi64-extras))
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-options")
(test-lookup-option)
(test-end "test-options"))
(define (test-lookup-option)
(let ((options (gnc:new-options)))
(gnc:register-option
options
(gnc:make-simple-boolean-option
"Section" "Start Date" "sort-tag" "docstring" 'default-val))
(gnc:register-option
options
(gnc:make-simple-boolean-option
"Filter" "Void Transactions" "sort-tag" "docstring" 'default-val))
(test-assert "lookup-option changed name"
(gnc:lookup-option options "Section" "From"))
(test-assert "lookup-option changed section and name"
(gnc:lookup-option options "Section" "Void Transactions?"))))

65
libgnucash/backend/xml/gnc-book-xml-v2.cpp
View File

@ -60,45 +60,6 @@ static QofLogModule log_module = GNC_MOD_IO;
/* ================================================================ */
#ifdef IMPLEMENT_BOOK_DOM_TREES_LATER
static void
append_account_tree (xmlNodePtr parent,
Account* account,
gboolean allow_incompat)
{
GList* children, *node;
children = gnc_account_get_children (account);
children = g_list_sort (children, qof_instance_guid_compare);
for (node = children; node; node = node->next)
{
xmlNodePtr accnode;
Account* account;
account = node->data;
accnode = gnc_account_dom_tree_create (account, FALSE, allow_incompat);
xmlAddChild (parent, accnode);
append_account_tree (accnode, account);
}
g_list_free (children);
}
static int
traverse_txns (Transaction* txn, gpointer data)
{
xmlNodePtr node;
xmlNodePtr parent = data;
node = gnc_transaction_dom_tree_create (txn);
xmlAddChild (parent, node);
return 0;
}
#endif
/* ================================================================ */
xmlNodePtr
gnc_book_dom_tree_create (QofBook* book)
{
@ -115,32 +76,6 @@ gnc_book_dom_tree_create (QofBook* book)
xmlAddChild (ret, qof_instance_slots_to_dom_tree (book_slots_string,
QOF_INSTANCE (book)));
#ifdef IMPLEMENT_BOOK_DOM_TREES_LATER
/* theoretically, we should be adding all the below to the book
* but in fact, there's enough brain damage in the code already
* that we are only going to hand-edit the file at a higher layer.
* And that's OK, since its probably a performance boost anyway.
*/
xmlAddChild (ret, gnc_commodity_dom_tree_create (
gnc_commodity_table_get_table (book)));
xmlAddChild (ret, gnc_pricedb_dom_tree_create (gnc_pricedb_get_db (book)));
if (allow_incompat)
{
accnode = gnc_account_dom_tree_create (account, FALSE);
xmlAddChild (ret, rootAccNode);
}
append_account_tree (ret, gnc_book_get_root (book));
xaccAccountTreeForEachTransaction (gnc_book_get_root_account (book),
traverse_txns, ret);
/* xxx FIXME hack alert how are we going to handle
* gnc_book_get_template_group handled ??? */
xmlAddChild (ret, gnc_schedXaction_dom_tree_create (
gnc_book_get_schedxactions (book)));
#endif
return ret;
}

28
libgnucash/backend/xml/io-gncxml-v2.cpp
View File

@ -853,6 +853,9 @@ qof_session_load_from_xml_file_v2_full (
gnc_account_foreach_descendant (root,
(AccountCb) xaccAccountCommitEdit,
NULL);
gnc_account_foreach_descendant (gnc_book_get_template_root (book),
(AccountCb) xaccAccountCommitEdit,
NULL);
/* start logging again */
xaccLogEnable ();
@ -981,31 +984,6 @@ write_book (FILE* out, QofBook* book, sixtp_gdv2* gd)
{
struct file_backend be_data;
#ifdef IMPLEMENT_BOOK_DOM_TREES_LATER
/* We can't just blast out the dom tree, because the dom tree
* doesn't have the books, transactions, etc underneath it.
* But that is just as well, since I think the performance
* will be much better if we write out as we go along
*/
xmlNodePtr node;
node = gnc_book_dom_tree_create (book);
if (!node)
{
return FALSE;
}
xmlElemDump (out, NULL, node);
xmlFreeNode (node);
if (ferror (out) || fprintf (out, "\n") < 0)
{
return FALSE;
}
#endif
be_data.out = out;
be_data.book = book;
be_data.gd = gd;

2
libgnucash/engine/iso-4217-currencies.xml
View File

@ -1734,6 +1734,7 @@
local-symbol="MOP$"
/>
<!-- "MRO" - "Ouguiya"
2018-01-01 "MRU" 10
-->
<currency
isocode="MRO"
@ -1747,6 +1748,7 @@
local-symbol="UM"
/>
<!-- "MRU" - "Ouguiya"
;; Bug 797319: In cash parts-per-unit is still 5, but not in banking
-->
<currency
isocode="MRU"