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

*** empty log message ***

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2062 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2000-03-07 02:03:00 +00:00
parent bd06f3d020
commit 92f50014ea
22 changed files with 1485 additions and 516 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
ChangeLog
View File

@ -1,3 +1,19 @@
2000-03-06 Dave Peticolas <peticola@cs.ucdavis.edu>
* src/register/gnome/gnucash-sheet.c
(gnucash_sheet_update_adjustments): set the step increment.
2000-03-06 Heath Martin <martinh@pegasus.cc.ucf.edu>
* src/register/gnome/gnucash-style.c
(gnucash_sheet_style_set_col_width): Adjust the overall style
width, too.
* src/register/gnome/gnucash-header.c
(gnucash_header_auto_resize_column): Resize the window to fit the
register.
(gnucash_header_event): ditto on a column resize.
2000-03-05 Rob Browning <rlb@cs.utexas.edu>
* src/scm/report/transaction-report.scm: add support for depend
@ -50,6 +66,61 @@
* src/reports/File.c (gncFindFile): take out dead code.
2000-03-04 Heath Martin <martinh@pegasus.cc.ucf.edu>
* src/register/gnome/gnucash-style.c (set_dimensions_pass_one):
Only set the dimensions based on percentages if the dimensions
have not been set before. This gets rid of some strange behavior
where styles change width by a few pixels when window size was
changed.
(gnucash_sheet_style_set_dimensions): Add a width argument; now we
compute dimensions to fit "width" as best as possible. Most of
the time width should be the allocation width of the sheet, except
that when the style is first compiled, the allocation width may be
unavailable.
(style_recompute_layout_dimensions): Set dimensions->width
properly.
(gnucash_style_default_width): Nuke this function, since we can
now use dimensions->width.
(gnucash_sheet_style_compile): Use a default width to set
dimensions.
* src/register/gnome/gnucash-sheet.c (gnucash_sheet_set_top_row):
Update the canvas before the scroll. This helps eliminate some of
the flashing when the register scrolls. Still not perfect,
though.
2000-03-03 Heath Martin <martinh@pegasus.cc.ucf.edu>
* src/register/gnome/gnucash-sheet.c
(gnucash_sheet_size_allocate): Keep track of the allocation and
update everything only if the allocation changes. This is needed
because gnome canvas widget items always do a gtk_widget_set_usize
(), which in turn forces a reconfigure of the parent widgets. So
we were getting size_allocate events even when the size of the
window was not changing.
(gnucash_sheet_set_top_row): Scroll the sheet by setting the
adjustment values rather than calling gnome_canvas_scroll_to ().
* src/register/gnome/gnucash-header.c
(gnucash_header_reconfigure): Set the sheet width from the header.
* src/register/gnome/gnucash-sheet.c
(gnucash_sheet_block_set_from_table): Check to see if the style
has changed before we reallocate all the entries and colors.
(gnucash_sheet_block_set_entries): Don't strdup the entries from
the table.
(gnucash_sheet_block_clear_entries): Don't free the text in the
entries, since now the table owns this.
(gnucash_sheet_set_scroll_region): New function; sets the scroll
region on the register canvas.
(gnucash_sheet_update_adjustments): This was being done
incorrectly. The layout widget on which the gnome canvas is based
takes care of the adjustments, and we've just connected to these
adjustments in the smooth-scroll case. Now that the scroll region
is set correctly, just let the layout manage the adjustments.
2000-03-03 Dave Peticolas <peticola@cs.ucdavis.edu>
* src/register/pricecell.c (PriceMV): accept thousands separators.

9
Docs/C/xacc-about.html
View File

@ -234,8 +234,7 @@
Browne</a></dt>
<dd>for perl stock scripts, Guile-based QIF import code, lots
of changes to English documentation<br>
</dd>
of changes to English documentation, and lots of guile code</dd>
<dt> <a href="mailto:grahamc@zeta.org.au"> Graham
Chapman</a></dt>
@ -320,6 +319,10 @@
<dd>for SuSE README file</dd>
<dt><a href="mailto:blarsen@ada-works.com"> Bryan Larsen</a></dt>
<dd>guile budget report</dd>
<dt> <a href="mailto:mellon@andare.fugue.com"> Ted
Lemon</a></dt>
@ -338,7 +341,7 @@
<dt> <a href="mailto:martinh@pegasus.cc.ucf.edu"> Heath
Martin</a></dt>
<dd>gnome and register patches</dd>
<dd>major work on the gnome register</dd>
<dt> <a href="mailto:mgmartin@abacusnet.net"> Matt
Martin</a></dt>

5
README
View File

@ -532,7 +532,7 @@ Andrew Arensburger <arensb@cfar.umd.edu> for FreeBSD & other patches
Matt Armstrong <matt_armstrong@bigfoot.com> for misc fixes
Fred Baube <fred@moremagic.com> for attempted Java port/MoneyDance
Per Bojsen <bojsen@worldnet.att.net> several core dump fixes
Christopher B. Browne <cbbrowne@hex.net> for perl, scheme scripts
Christopher B. Browne <cbbrowne@hex.net> for perl and lots of scheme
Graham Chapman <grahamc@zeta.org.au> for the xacc-rpts addon package
George Chen <georgec@sco.com> for MS-Money QIF's & fixes
Albert Chin-A-Young <china@thewrittenword.com> configure.in patch
@ -552,11 +552,12 @@ Prakash Kailasa <PrakashK@bigfoot.com> for gnome build fixes
Ben Kelly <ben.kelly@ieee.org> for motif menu bug fix, core dump fixes
Tom Kludy <tkludy@csd.sgi.com> for SGI Irix port
Sven Kuenzler <sk@xgm.de> for SuSE README file
Bryan Larsen <blarsen@ada-works.com> guile budget report
Graham Leggett <minfrin@sharp.fm> for fixing a hang
Ted Lemon <mellon@andare.fugue.com> for NetBSD port
Yannick Le Ny <y-le-ny@ifrance.com> pour la traduction en francais
Grant Likely <glikely@nortelnetworks.com> gnome and engine patches
Heath Martin <martinh@pegasus.cc.ucf.edu> gnome and register patches
Heath Martin <martinh@pegasus.cc.ucf.edu> gnome patches, major register work
Matt Martin <mgmartin@abacusnet.net> guile error handling code
Robert Graham Merkel <rgmerk@mira.net> reporting, gnome, and config patches.
Tim Mooney <mooney@dogbert.cc.ndsu.NoDak.edu> port to alpha-dec-osf4.0f

475
po/fr.po
View File

File diff suppressed because it is too large Load Diff

2
src/engine/Account.h
View File

@ -1,7 +1,7 @@
/********************************************************************\
* Account.h -- the Account data structure *
* Copyright (C) 1997 Robin D. Clark *
* Copyright (C) 1997, 1998, 1999 Linas Vepstas *
* Copyright (C) 1997, 1998, 1999, 2000 Linas Vepstas *
* *
* This program is free software; you can redistribute it and/or *
* modify it under the terms of the GNU General Public License as *

2
src/gnome/window-register.c
View File

@ -3,6 +3,7 @@
* Copyright (C) 1997 Robin D. Clark *
* Copyright (C) 1997, 1998 Linas Vepstas *
* Copyright (C) 1998 Rob Browning <rlb@cs.utexas.edu> *
* Copyright (C) 1999-2000 Dave Peticolas <peticola@cs.ucdavis.edu> *
* *
* This program is free software; you can redistribute it and/or *
* modify it under the terms of the GNU General Public License as *
@ -1465,6 +1466,7 @@ regWindowLedger(xaccLedgerDisplay *ledger)
gtk_container_add(GTK_CONTAINER(table_frame), register_widget);
regData->reg = GNUCASH_REGISTER(register_widget);
GNUCASH_SHEET(regData->reg->sheet)->window = register_window;
gtk_signal_connect(GTK_OBJECT(register_widget), "activate_cursor",
GTK_SIGNAL_FUNC(gnc_register_record_cb), regData);

1
src/register/gnome/combocell-gnome.c
View File

@ -23,6 +23,7 @@
* HISTORY:
* Copyright (c) 1998 Linas Vepstas <linas@linas.org>
* Copyright (c) 1998-1999 Rob Browning <rlb@cs.utexas.edu>
* Copyright (c) 2000 Linas Vepstas <linas@linas.org>
*/
/*

20
src/register/gnome/gnucash-header.c
View File

@ -218,10 +218,19 @@ gnucash_header_destroy (GtkObject *object)
void
gnucash_header_reconfigure (GnucashHeader *header)
{
GnomeCanvas *canvas = GNOME_CANVAS_ITEM(header)->canvas;
GtkWidget *widget = GTK_WIDGET (header->sheet);
int w, h;
GnomeCanvas *canvas;
GtkWidget *widget;
GnucashSheet *sheet;
g_return_if_fail (header != NULL);
g_return_if_fail (GNUCASH_IS_HEADER (header));
canvas = GNOME_CANVAS_ITEM(header)->canvas;
widget = GTK_WIDGET (header->sheet);
sheet = GNUCASH_SHEET(header->sheet);
header->style = header->sheet->cursor_style[header->type];
if (header->style == NULL)
@ -232,6 +241,8 @@ gnucash_header_reconfigure (GnucashHeader *header)
if (header->row < 0 || header->row >= header->style->nrows)
return;
sheet->width = header->style->dimensions->width;
w = MAX (widget->allocation.width, header->style->dimensions->width);
h = header->style->dimensions->height;
@ -321,7 +332,7 @@ gnucash_header_auto_resize_column (GnucashHeader *header, gint col)
gnucash_sheet_style_set_col_width (sheet, header->style,
col, width, FALSE);
gnucash_sheet_style_set_dimensions (sheet, header->style);
gtk_window_set_default_size(GTK_WINDOW(sheet->window), 0, 0);
gnucash_cursor_configure (GNUCASH_CURSOR(sheet->cursor));
item_edit_configure (ITEM_EDIT(sheet->item_editor));
@ -420,7 +431,8 @@ gnucash_header_event (GnomeCanvasItem *item, GdkEvent *event)
gnucash_sheet_style_set_col_width (sheet, header->style,
header->resize_col, header->resize_col_width, FALSE);
gnucash_sheet_style_set_dimensions (sheet, header->style);
gtk_window_set_default_size(GTK_WINDOW(sheet->window), 0, 0);
gnucash_cursor_configure (GNUCASH_CURSOR(sheet->cursor));
item_edit_configure (ITEM_EDIT(sheet->item_editor));

179
src/register/gnome/gnucash-sheet.c
View File

@ -376,7 +376,6 @@ gnucash_sheet_compute_visible_range (GnucashSheet *sheet)
if (y + style->dimensions->height >= height)
break;
y += style->dimensions->height;
block++;
} while (block < sheet->num_virt_rows - 1);
@ -447,10 +446,8 @@ gnucash_sheet_set_top_row (GnucashSheet *sheet, gint new_top_row, gint align)
x = cx;
height = GTK_WIDGET(sheet)->allocation.height;
distance = gnucash_sheet_row_get_distance(sheet, new_top_row,
sheet->num_virt_rows);
while ((new_top_row > 1) && height > distance)
{
SheetBlockStyle *style;
@ -472,11 +469,17 @@ gnucash_sheet_set_top_row (GnucashSheet *sheet, gint new_top_row, gint align)
y += diff;
sheet->top_block_offset = -diff;
sheet->top_block = new_top_row;
if (x != cx || y != cy) {
gnucash_sheet_compute_visible_range(sheet);
gnome_canvas_scroll_to (GNOME_CANVAS(sheet), x, y);
gnome_canvas_update_now (GNOME_CANVAS(sheet));
if (y != cy)
gtk_adjustment_set_value(sheet->vadj, y);
if (x != cx)
gtk_adjustment_set_value(sheet->hadj, x);
}
gnucash_sheet_update_adjustments (sheet);
@ -495,6 +498,8 @@ gnucash_sheet_make_cell_visible (GnucashSheet *sheet,
cell_row, cell_col))
return;
if (virt_row <= sheet->top_block)
gnucash_sheet_set_top_row (sheet, virt_row, GNUCASH_ALIGN_TOP);
else if (virt_row >= sheet->bottom_block)
@ -514,44 +519,25 @@ void
gnucash_sheet_update_adjustments (GnucashSheet *sheet)
{
GtkAdjustment *vadj;
GtkAdjustment *hadj;
GnucashCursor *cursor;
g_return_if_fail (sheet != NULL);
g_return_if_fail (GNUCASH_IS_SHEET (sheet));
g_return_if_fail (sheet->vadj != NULL);
g_return_if_fail (sheet->hadj != NULL);
g_return_if_fail (sheet->cursor != NULL);
vadj = sheet->vadj;
hadj = sheet->hadj;
cursor = GNUCASH_CURSOR(sheet->cursor);
if (sheet->smooth_scroll) {
vadj->lower = 0;
vadj->upper = sheet->height;
vadj->page_size = GTK_WIDGET(sheet)->allocation.height;
vadj->page_increment = vadj->page_size;
vadj->step_increment = vadj->page_size /
(sheet->bottom_block - sheet->top_block + 1);
}
else {
if (!sheet->smooth_scroll) {
vadj->lower = 1;
vadj->upper = MAX(sheet->bottom_block, sheet->num_virt_rows);
vadj->page_size = sheet->bottom_block - sheet->top_block + 1;
vadj->page_increment = vadj->page_size - 1;
vadj->step_increment = 1;
}
else
vadj->step_increment = vadj->page_size /
(sheet->bottom_block - sheet->top_block + 1);
gtk_adjustment_changed(vadj);
if (cursor->style) {
hadj->lower = 0;
hadj->upper = cursor->style->dimensions->width;
hadj->page_size = GTK_WIDGET(sheet)->allocation.width;
hadj->page_increment = hadj->page_size;
hadj->step_increment = hadj->page_size / 50.0;
gtk_adjustment_changed (hadj);
}
}
@ -583,8 +569,8 @@ gnucash_sheet_vadjustment_value_changed (GtkAdjustment *adj,
gint oy;
if (sheet->smooth_scroll) {
oy = (gint) adj->value;
new_top_row = gnucash_sheet_y_pixel_to_block (sheet, oy);
new_top_row = gnucash_sheet_y_pixel_to_block (sheet, (gint) adj->value);
if (new_top_row < 0) {
sheet->top_block = 0;
sheet->top_block_offset = 0;
@ -804,16 +790,16 @@ compute_optimal_width (GnucashSheet *sheet)
if ((sheet == NULL) || (sheet->cursor_style == NULL))
return DEFAULT_REGISTER_WIDTH;
#if 0
if (sheet->default_width >= 0)
return sheet->default_width;
#endif
style = sheet->cursor_style[GNUCASH_CURSOR_HEADER];
if ((style == NULL) || (style->widths == NULL))
return DEFAULT_REGISTER_WIDTH;
sheet->default_width = gnucash_style_default_width (sheet, style);
sheet->default_width = style->dimensions->width;
return sheet->default_width;
}
@ -849,6 +835,7 @@ gnucash_sheet_size_request (GtkWidget *widget, GtkRequisition *requisition)
{
GnucashSheet *sheet = GNUCASH_SHEET(widget);
requisition->width = compute_optimal_width (sheet);
requisition->height = compute_optimal_height (sheet);
}
@ -1140,14 +1127,20 @@ gnucash_sheet_size_allocate (GtkWidget *widget, GtkAllocation *allocation)
(*GTK_WIDGET_CLASS (sheet_parent_class)->size_allocate)
(widget, allocation);
if (allocation->height != sheet->window_height || allocation->width != sheet->window_width) {
sheet->window_height = allocation->height;
sheet->window_width = allocation->width;
for (i = GNUCASH_CURSOR_HEADER; i < GNUCASH_CURSOR_LAST; i++)
gnucash_sheet_style_set_dimensions(sheet,
sheet->cursor_style[i]);
sheet->cursor_style[i], allocation->width);
gnucash_cursor_configure (GNUCASH_CURSOR (sheet->cursor));
item_edit_configure (ITEM_EDIT(sheet->item_editor));
gnucash_header_reconfigure (GNUCASH_HEADER(sheet->header_item));
gnucash_sheet_set_scroll_region (sheet);
item_edit_configure (ITEM_EDIT(sheet->item_editor));
gnucash_sheet_update_adjustments (sheet);
}
}
@ -1920,7 +1913,7 @@ gnucash_sheet_block_get_text (GnucashSheet *sheet, gint virt_row,
static void
gnucash_sheet_block_clear_entries (SheetBlock *block)
{
gint i,j;
gint i;
gint num_rows, num_cols;
if (block && block->style) {
@ -1928,8 +1921,6 @@ gnucash_sheet_block_clear_entries (SheetBlock *block)
num_cols = block->style->ncols;
for (i = 0; i < num_rows; i++ ) {
for (j = 0; j < num_cols; j++)
g_free (block->entries[i][j]);
g_free (block->entries[i]);
g_free (block->fg_colors[i]);
g_free (block->bg_colors[i]);
@ -1967,10 +1958,8 @@ gnucash_sheet_block_set_entries (GnucashSheet *sheet, gint virt_row,
for (i = 0; i < block->style->nrows; i++) {
for (j = 0; j < block->style->ncols; j++) {
if (table->entries [phys_row_origin + i]
[phys_col_origin + j])
block->entries[i][j] =
g_strdup(table->entries [phys_row_origin + i][phys_col_origin + j]);
block->entries[i][j] = table->entries [phys_row_origin + i][phys_col_origin + j];
block->fg_colors[i][j] =
gnucash_color_argb_to_gdk(table->fg_colors [phys_row_origin + i][phys_col_origin + j]);
@ -1991,26 +1980,31 @@ gnucash_sheet_block_set_from_table (GnucashSheet *sheet, gint virt_row,
{
Table *table;
SheetBlock *block;
SheetBlockStyle *style;
gint i;
block = gnucash_sheet_get_block (sheet, virt_row, virt_col);
style = gnucash_sheet_get_style_from_table (sheet, virt_row, virt_col);
if (block) {
table = sheet->table;
if (block->style && block->style != style) {
gnucash_sheet_block_clear_entries (block);
if (block->style) {
/* the zero'th virtual row isn't drawn */
if (virt_row > 0)
sheet->height -= block->style->dimensions->height;
gnucash_style_unref (block->style);
block->style = NULL;
}
block->style = gnucash_sheet_get_style_from_table
(sheet, virt_row, virt_col);
if (block->style == NULL) {
block->style = style;
/* the zero'th virtual row isn't drawn */
if (virt_row > 0)
@ -2018,6 +2012,7 @@ gnucash_sheet_block_set_from_table (GnucashSheet *sheet, gint virt_row,
gnucash_style_ref(block->style);
block->entries = g_new0( gchar **, block->style->nrows);
for (i = 0; i < block->style->nrows; i++)
block->entries[i] = g_new0(gchar *,
@ -2032,6 +2027,7 @@ gnucash_sheet_block_set_from_table (GnucashSheet *sheet, gint virt_row,
for (i = 0; i < block->style->nrows; i++)
block->bg_colors[i] = g_new0(GdkColor *,
block->style->ncols);
}
gnucash_sheet_block_set_entries (sheet, virt_row, virt_col);
}
@ -2047,7 +2043,6 @@ gnucash_sheet_cell_set_from_table (GnucashSheet *sheet, gint virt_row,
Table *table;
gint p_row, p_col;
gchar *text;
g_return_if_fail (sheet != NULL);
g_return_if_fail (GNUCASH_IS_SHEET(sheet));
@ -2064,17 +2059,14 @@ gnucash_sheet_cell_set_from_table (GnucashSheet *sheet, gint virt_row,
if (cell_row >= 0 && cell_row <= style->nrows
&& cell_col >= 0 && cell_col <= style->ncols) {
if (block->entries[cell_row][cell_col])
g_free (block->entries[cell_row][cell_col]);
block->entries[cell_row][cell_col] = NULL;
p_row = table->rev_locators[virt_row][virt_col]->phys_row +
cell_row;
p_col = table->rev_locators[virt_row][virt_col]->phys_col +
cell_col;
text = table->entries[p_row][p_col];
block->entries[cell_row][cell_col] = g_strdup(text);
block->entries[cell_row][cell_col] = table->entries[p_row][p_col];
}
}
@ -2126,6 +2118,31 @@ gnucash_sheet_col_max_width (GnucashSheet *sheet, gint virt_col, gint cell_col)
return max;
}
void
gnucash_sheet_set_scroll_region (GnucashSheet *sheet)
{
int height, width;
GtkWidget *widget;
double x, y;
if (!sheet)
return;
widget = GTK_WIDGET(sheet);
if (!sheet->header_item || !GNUCASH_HEADER(sheet->header_item)->style)
return;
gnome_canvas_get_scroll_region (GNOME_CANVAS(sheet), NULL, NULL, &x, &y);
height = MAX(sheet->height, widget->allocation.height);
width = MAX (sheet->width, widget->allocation.width);
if (width != (int)x || height != (int)y)
gnome_canvas_set_scroll_region (GNOME_CANVAS(sheet), 0, 0, width, height);
}
static void
@ -2136,15 +2153,14 @@ gnucash_sheet_block_destroy (GnucashSheet *sheet, gint virt_row, gint virt_col)
block = gnucash_sheet_get_block (sheet, virt_row, virt_col);
if (block) {
gnucash_sheet_block_clear_entries (block);
if (block->style) {
sheet->height -= block->style->dimensions->height;
gnucash_style_unref (block->style);
}
gnucash_sheet_block_clear_entries (block);
g_hash_table_remove (sheet->blocks, block);
g_free (block);
}
}
@ -2172,48 +2188,35 @@ gnucash_sheet_block_new (GnucashSheet *sheet, gint virt_row, gint virt_col)
static void
gnucash_sheet_resize (GnucashSheet *sheet)
{
gint i, j;
gint diff_rows, diff_cols;
gint i;
gint diff_rows;
gint num_virt_rows;
g_return_if_fail (sheet != NULL);
g_return_if_fail (GNUCASH_IS_SHEET(sheet));
diff_rows = sheet->table->num_virt_rows - sheet->num_virt_rows;
diff_cols = sheet->table->num_virt_cols - sheet->num_virt_cols;
if (sheet->table->num_virt_cols > 1)
g_warning ("num_virt_cols > 1");
num_virt_rows = sheet->num_virt_rows;
diff_rows = sheet->table->num_virt_rows - num_virt_rows;
sheet->num_virt_cols = 1;
if (diff_rows < 0) {
/* we need to shrink the number of rows */
for (i = 0; i < -diff_rows; i++)
for (j = 0; j < sheet->num_virt_cols; j++)
gnucash_sheet_block_destroy
(sheet, sheet->num_virt_rows-i-1, j);
gnucash_sheet_block_destroy(sheet, num_virt_rows-i-1, 0);
}
else if (diff_rows > 0) {
/* we need some more rows */
for (i = 0; i < diff_rows; i++)
for ( j = 0; j < sheet->num_virt_cols + diff_cols; j++)
gnucash_sheet_block_new
(sheet, sheet->num_virt_rows + i, j);
gnucash_sheet_block_new(sheet, num_virt_rows + i, 0);
}
sheet->num_virt_rows = sheet->table->num_virt_rows;
if (diff_cols < 0) {
/* we need to shrink the number of cols */
for (j = 0; j < -diff_cols; j++)
for (i = 0; i < sheet->num_virt_rows; i++)
gnucash_sheet_block_destroy
(sheet, i, sheet->num_virt_cols-j-1);
}
else if (diff_cols > 0) {
/* we need some more cols */
for (j = 0; j < diff_cols; j++)
for ( i = 0; i < sheet->num_virt_rows; i++)
gnucash_sheet_block_new
(sheet, i, sheet->num_virt_cols + j);
}
sheet->num_virt_cols = sheet->table->num_virt_cols;
gnucash_sheet_set_scroll_region (sheet);
}
@ -2231,6 +2234,8 @@ gnucash_sheet_table_load (GnucashSheet *sheet)
table = sheet->table;
num_virt_rows = table->num_virt_rows;
gtk_layout_freeze (GTK_LAYOUT(sheet));
gnucash_sheet_stop_editing (sheet);
/* resize the sheet */
@ -2241,6 +2246,8 @@ gnucash_sheet_table_load (GnucashSheet *sheet)
for (j = 0; j < table->num_virt_cols; j++)
gnucash_sheet_block_set_from_table (sheet, i, j);
gnucash_sheet_set_scroll_region (sheet);
gnucash_sheet_set_top_row (sheet, sheet->top_block,
GNUCASH_ALIGN_BOTTOM);
@ -2248,6 +2255,7 @@ gnucash_sheet_table_load (GnucashSheet *sheet)
gnucash_sheet_cursor_set_from_table (sheet, TRUE);
gnucash_sheet_activate_cursor_cell (sheet, TRUE);
gtk_layout_thaw (GTK_LAYOUT(sheet));
}
@ -2425,10 +2433,6 @@ gnucash_sheet_new (Table *table)
sheet = gnucash_sheet_create (table);
/* FIXME: */
gnome_canvas_set_scroll_region(GNOME_CANVAS (sheet),
0, 0, 1000000, 1000000);
/* handy shortcuts */
sheet_canvas = GNOME_CANVAS (sheet);
sheet_group = gnome_canvas_root (GNOME_CANVAS(sheet));
@ -2441,11 +2445,8 @@ gnucash_sheet_new (Table *table)
sheet->grid = item;
/* some register data */
sheet->layout_info_hash_table = g_hash_table_new (g_str_hash,
g_str_equal);
sheet->dimensions_hash_table = g_hash_table_new (g_str_hash,
g_str_equal);
sheet->layout_info_hash_table = g_hash_table_new (g_str_hash, g_str_equal);
sheet->dimensions_hash_table = g_hash_table_new (g_str_hash, g_str_equal);
/* The cursor */
sheet->cursor = gnucash_cursor_new (sheet_group);

7
src/register/gnome/gnucash-sheet.h
View File

@ -130,6 +130,8 @@ typedef struct
typedef struct {
GnomeCanvas canvas;
GtkWidget *window;
Table *table;
SplitRegister *split_register;
@ -166,6 +168,9 @@ typedef struct {
gint width; /* the width in pixels of the sheet */
gint height;
gint window_height;
gint window_width;
gint alignment;
gint editing;
@ -229,6 +234,7 @@ const char * gnucash_sheet_modify_current_cell(GnucashSheet *sheet,
void gnucash_sheet_block_set_from_table (GnucashSheet *sheet, gint virt_row,
gint virt_col);
void gnucash_sheet_set_scroll_region (GnucashSheet *sheet);
void gnucash_sheet_cursor_set_from_table (GnucashSheet *sheet,
gncBoolean do_scroll);
@ -265,6 +271,7 @@ void gnucash_register_copy_clipboard (GnucashRegister *reg);
void gnucash_register_paste_clipboard (GnucashRegister *reg);
typedef struct {
GnomeCanvasClass parent_class;

79
src/register/gnome/gnucash-style.c
View File

@ -31,6 +31,7 @@
#define DEFAULT_FONT "-adobe-helvetica-medium-r-normal--*-120-*-*-*-*-*-*"
#define ITALIC_FONT "-adobe-helvetica-medium-o-normal--*-120-*-*-*-*-*-*"
#define DEFAULT_STYLE_WIDTH 680
GdkFont *gnucash_default_font = NULL;
GdkFont *gnucash_italic_font = NULL;
@ -448,7 +449,7 @@ static CellDimensions *
style_dimensions_new (SheetBlockStyle *style)
{
CellDimensions *dimensions;
int i;
int i, j;
dimensions = g_new0 (CellDimensions, 1);
dimensions->nrows = style->nrows;
@ -462,10 +463,16 @@ style_dimensions_new (SheetBlockStyle *style)
for (i=0; i < style->nrows; i++) {
dimensions->pixel_heights[i] = g_new0 (gint, style->ncols);
dimensions->pixel_widths[i] = g_new0 (gint, style->ncols);
for (j = 0; j < style->ncols; j++)
dimensions->pixel_widths[i][j] = -1;
dimensions->origin_x[i] = g_new0 (gint, style->ncols);
dimensions->origin_y[i] = g_new0 (gint, style->ncols);
}
return dimensions;
}
@ -539,6 +546,8 @@ set_dimensions_pass_one (GnucashSheet *sheet, CellLayoutInfo *layout_info,
g_return_if_fail (font != NULL);
for (j = 0; j < layout_info->ncols; j++) {
if (dimensions->pixel_widths[i][j] < 0)
dimensions->pixel_widths[i][j] = layout_info->cell_perc[i][j] * dimensions->width + 0.5;
dimensions->pixel_heights[i][j] =
font->ascent + font->descent +
@ -794,43 +803,6 @@ set_dimensions_pass_four(GnucashSheet *sheet, CellLayoutInfo *layout_info,
}
}
gint
gnucash_style_default_width(GnucashSheet *sheet, SheetBlockStyle *style)
{
CellLayoutInfo *layout_info;
CellDimensions *dimensions;
gint width;
gint i;
layout_info = style->layout_info;
dimensions = style->dimensions;
dimensions->height = 0;
width = dimensions->width = 0;
/* Well, this is kind of wierd, isn't it. We do this five times
* because pass one and pass two interact in a strange way. Pass
* one sets widths based on percentages, and then pass two fixes
* them up based on layout info. If we only do this once, then
* when we get the allocation and we recompute them below, the
* pass one iteration messes up the pass two fixes. Then, when
* pass two is run again, the size gets bumped up to compensate.
* Running these 5 times is a hack to make the window come up
* in full horizontal view. */
for (i = 0; i < 5; i++)
{
set_dimensions_pass_one(sheet, layout_info, dimensions, 0);
set_dimensions_pass_two(sheet, layout_info, dimensions, 0);
width = compute_row_width(dimensions, 0, 0,
layout_info->ncols - 1);
dimensions->width = width;
}
return width;
}
gint
gnucash_style_row_width(SheetBlockStyle *style, int row)
@ -871,13 +843,13 @@ compute_cell_origins_y (CellDimensions *dimensions)
}
static void
style_recompute_layout_dimensions (GnucashSheet *sheet, CellLayoutInfo *layout_info, CellDimensions *dimensions)
style_recompute_layout_dimensions (GnucashSheet *sheet, CellLayoutInfo *layout_info, CellDimensions *dimensions, int width)
{
int i;
int ideal_width;
dimensions->height = 0;
dimensions->width = GTK_WIDGET (sheet)->allocation.width;
dimensions->width = width;
ideal_width = dimensions->width;
/* First set the top rows */
@ -900,7 +872,7 @@ style_recompute_layout_dimensions (GnucashSheet *sheet, CellLayoutInfo *layout_i
}
#if 0
static void
sheet_recompute_style_dimensions_internal (gpointer _key, gpointer _layout_info, gpointer _data)
{
@ -922,18 +894,18 @@ gnucash_sheet_recompute_style_dimensions (GnucashSheet *sheet)
g_hash_table_foreach (sheet->layout_info_hash_table,
sheet_recompute_style_dimensions_internal, sheet);
}
#endif
void
gnucash_sheet_style_set_dimensions (GnucashSheet *sheet,
SheetBlockStyle *style)
SheetBlockStyle *style, int width)
{
g_return_if_fail (sheet != NULL);
g_return_if_fail (GNUCASH_IS_SHEET (sheet));
g_return_if_fail (style != NULL);
style_recompute_layout_dimensions (sheet, style->layout_info,
style->dimensions);
style->dimensions, width);
}
gint
@ -965,11 +937,13 @@ gnucash_sheet_style_set_col_width (GnucashSheet *sheet, SheetBlockStyle *style,
if (width >= 0) {
style->layout_info->pixels_width[0][col] = width;
/* Note that we may want to preserve the FILL flag on
* this, but for now let's leave it off.
* style->layout_info->flags[0][col] = PIXELS_FIXED |
* (style->layout_info->flags[0][col] & FILL); */
style->layout_info->flags[0][col] = PIXELS_FIXED;
style->layout_info->flags[0][col] = PIXELS_FIXED |
(style->layout_info->flags[0][col] & FILL);
/* adjust the overall width of this style */
style->dimensions->width -= style->dimensions->pixel_widths[0][col] - width;
style->dimensions->pixel_widths[0][col] = width;
for (i = 0; i < style->nrows; i++) {
@ -977,8 +951,11 @@ gnucash_sheet_style_set_col_width (GnucashSheet *sheet, SheetBlockStyle *style,
if ((style->layout_info->flags[i][j] & SAME_SIZE)
&& (style->layout_info->size_r[i][j] == 0)
&& (style->layout_info->size_c[i][j] == col)) {
if (same_size)
if (same_size) {
/* adjust the overall width of this style */
style->dimensions->width -= style->dimensions->pixel_widths[0][col] - width;
style->dimensions->pixel_widths[i][j] = width;
}
else
{
style->layout_info->flags[i][j] = PIXELS_FIXED;
@ -1196,7 +1173,7 @@ gnucash_sheet_style_compile (GnucashSheet *sheet, CellBlock *cellblock,
gnucash_style_layout_init (sheet, style);
gnucash_style_dimensions_init (sheet, style);
gnucash_sheet_style_set_dimensions (sheet, style);
gnucash_sheet_style_set_dimensions (sheet, style, DEFAULT_STYLE_WIDTH);
return style;
}

4
src/register/gnome/gnucash-style.h
View File

@ -39,12 +39,10 @@ void gnucash_sheet_style_set_col_width (GnucashSheet *sheet,
SheetBlockStyle *style,
int col, int width, int same_size);
gint gnucash_style_default_width(GnucashSheet *sheet, SheetBlockStyle *style);
gint gnucash_style_row_width(SheetBlockStyle *style, int row);
void gnucash_sheet_style_set_dimensions (GnucashSheet *sheet,
SheetBlockStyle *style);
SheetBlockStyle *style, int width);
void gnucash_sheet_style_destroy (GnucashSheet *sheet, SheetBlockStyle *style);

6
src/register/table-allgui.c
View File

@ -6,7 +6,7 @@
* Implements the gui-independent parts of the table infrastructure.
*
* HISTORY:
* Copyright (c) 1998,1999 Linas Vepstas
* Copyright (c) 1998,1999,2000 Linas Vepstas
*/
/********************************************************************\
@ -779,8 +779,10 @@ xaccGetUserData (Table *table, int phys_row, int phys_col)
* now is the time to initialize its GUI. */
void
xaccCreateCursor (Table * table, CellBlock *curs) {
xaccCreateCursor (Table * table, CellBlock *curs)
{
int i,j;
if (!curs || !table) return;
if (!table->table_widget) return;

2
src/register/table-allgui.h
View File

@ -73,7 +73,7 @@
* re-'printed'.
*
* HISTORY:
* Copyright (c) 1998,1999 Linas Vepstas
* Copyright (c) 1998,1999,2000 Linas Vepstas
*/
/********************************************************************\

1
src/register/table-gnome.c
View File

@ -10,6 +10,7 @@
* Copyright (c) 1998 Linas Vepstas
* Copyright (c) 1998 Rob Browning <rlb@cs.utexas.edu>
* Copyright (c) 1999 Heath Martin <martinh@pegasus.cc.ucf.edu>
* Copyright (c) 2000 Heath Martin <martinh@pegasus.cc.ucf.edu>
*/
/********************************************************************\

221
src/scm/gnumeric-utilities.scm Normal file
View File

@ -0,0 +1,221 @@
;;;; $Id$
;;;; gnumeric-utilities.scm - Gnumeric spreadsheet generation functions
(gnc:support "gnumeric-utilities.scm")
(gnc:depend "xml-generator.scm")
;;;; Gnumeric spreadsheet consists of:
;;;; gmr:Workbook
;;;; gmr:Summary Done
;;;; gmr:Geometry Done
;;;; gmr:Sheets
;;;; gmr:Sheet
;;;; gmr:Name - Need the Sheet name
;;;; gmr:MaxCol - omission OK
;;;; gmr:MaxRow - omission OK
;;;; gmr:Zoom - omission OK
;;;; gmr:PrintInformation - omission OK
;;;; gmr:Styles - Ok to omit
;;;; gmr:StyleRegion - optional
;;;; gmr:Style - optional
;;;; gmr:Font - optional
;;;; gmr:StyleBorder - optional
;;;; gmr:Top - optional
;;;; gmr:Bottom - optional
;;;; gmr:Left - optional
;;;; gmr:Right - optional
;;;; gmr:Diagonal - optional
;;;; gmr:Rev-Diagonal - optional
;;;; gmr:Cols - Optional, but should have this one...
;;;; gmr:ColInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Rows - Quite Optional
;;;; gmr:RowInfo (No Unit MarginA MarginB HardSize Hidden)
;;;; gmr:Cells - This is the meat of the matter...
;;;; gmr:Cell (Col Row Style)
;;;; gmr:Content
;;; Here's a kludgy function that is intended to compute the number of
;;; days since December 31, 1899. It is only approximate; feel free
;;; to suggest a better function.
;;; The point of this is that Gnumeric uses this as the "native" data
;;; representation.
(define (ymd->number y m d)
(+
1 ;;; Start at 1
(* (- y 1900) 365) ;;; 365 days per year
d ;;; Add the number of days
(vector-ref #(0 31 59 90 120 151 181 212 243 273 304 334)
(- m 1));;; Add in days associated with month
(truncate (/ (- y 1900) 4)) ;;; Add in leap days, valid 'til
;;; year 2100...
(if
(and (= 0 (modulo y 4)) ;;; If a leap year,
(> m 2)) ;;; and month is post-Feb
1 ;;; add an extra day
0)))
;;; gmr:Summary appears to be some metadata about who/what generated
;;; the document.
(define (make-gmr-summary)
(define (make-gmr-item name value)
(xml-element
'gmr:Item no-attributes
(list (xml-element 'gmr:name no-attributes name)
(xml-element 'gmr:val-string no-attributes value))))
(xml-element
'gmr:Summary no-attributes
(list
(make-gmr-item "application"
"gnumeric")
(make-gmr-item "Author"
"GnuCash Generator"))))
;;; This function generates a goodly chunk of the document structure;
;;; gmr:Workbook is the base element for Gnumeric
(define (gnumeric-workbook sheets)
(xml-element
'gmr:Workbook '((xmlns:gmr . "http://www.gnome.org/gnumeric/v2"))
(list
(make-gmr-summary)
(xml-element 'gmr:Geometry '((Width . 912) (Height . 720)) no-children)
(xml-element 'gmr:Sheets no-attributes sheets))))
(define (gnumeric-xml-cell row col contents)
(xml-element
'gmr:Cell
(xml-attributes (xml-attribute 'Col col)
(xml-attribute 'Row row)
(xml-attribute 'Style 0))
(list (xml-element 'gmr:Content no-attributes contents))))
;;; Generate a set of style regions for a given Sheet
;;; This ought also to support the notion of named styles, but that
;;; can wait
(define (gnumeric-styles rows colassoc)
(xml-element
'gmr:Styles no-attributes
(map
(lambda (coll)
(let ((col (car coll))
(fmt (cdr coll)))
(gnumeric-style-column rows col fmt)))
colassoc)))
;;; Generate a StyleRegion for the given column
(define (gnumeric-style-column totalrows col format)
(xml-element
'gmr:StyleRegion
(xml-attributes (xml-attribute 'startCol col)
(xml-attribute 'endCol col)
(xml-attribute 'startRow 0)
(xml-attribute 'endRow totalrows))
(list (xml-element 'gmr:Style
(xml-attributes
(xml-attribute 'Format format))
no-children))))
(define (gmr:cell col row cell-value)
(xml-element
'gmr:Cell
(xml-attributes
(xml-attribute 'Col col)
(xml-attribute 'Row row))
cell-value))
;;; Each Sheet requires Cols to define the widths of columns.
;;; Don't omit this.
(define (gnumeric-columns collist)
(xml-element 'gmr:Cols no-attributes
(map (lambda (colassoc)
(xml-element 'gmr:ColInfo colassoc no-children))
collist)))
;;; And here's a function that generates a whole Sheet.
;;; It forces in style info; that's probably not the best thing to do.
(define (gnumeric-sheet name rows cols cells)
(let ((namelst (xml-element 'gmr:Name no-attributes name))
(stylelst (gnumeric-styles
rows our-style-list))
(celllst (xml-element 'gmr:Cells no-attributes cells)))
(xml-element 'gmr:Sheet no-attributes
(list
namelst
cols
stylelst
celllst))))
;;; Define some wild accounting-oriented display formats
(define our-style-list
(let ((acctgstyle "_($*#,##0.00_);_($(#,##0.00);_($*&quot;-&quot;??_);(@_)")
(coloredstyle "$0.00_);[Red]($0.00)"))
(list (cons 0 "yyyy-mm-dd")
(cons 2 acctgstyle)
(cons 3 coloredstyle))))
(define (gen-cells-for-txn txn row)
(display txn) (newline)
(apply
(lambda (y m d descr amt)
(list
(gmr:cell 0 row (ymd->number y m d))
(gmr:cell 1 row descr)
(gmr:cell 2 row amt)
(gmr:cell 3 row (string-append "=D" (number->string row)
"+C"
(number->string (+ row 1))))))
txn))
(define (sample-cells)
(let loop
((txns
(sort
(append
'((1998 12 31 "Opening Balance" 0))
(map (lambda (x) (list 1999 x 1 "Rent" -500))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 1 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 15 "Salary" 1200))
'(1 2 3 4 5 6 7 8 9 10 11 12))
(map (lambda (x) (list 1999 x 12 "Phone" -35))
'(1 2 3 4 5 6 7 8 9 10 11 12)))
(lambda (lst1 lst2)
(if (= (car lst1) (car lst2))
(if (= (cadr lst1) (cadr lst2))
(if (= (caddr lst1) (caddr lst2))
(if (string=? (cadddr lst1) (cadddr lst2))
#t
(string<? (cadddr lst1) (cadddr lst2)))
(< (caddr lst1) (caddr lst2)))
(< (cadr lst1) (cadr lst2)))
(< (car lst1) (car lst2))))))
(row 1)
(cells '()))
(if (null? txns)
cells
(loop (cdr txns)
(+ row 1)
(let* ((txn (car txns)))
(append cells (gen-cells-for-txn txn row)))))))
(define (build-full-sample)
(let*
((cells (sample-cells))
(cols 4)
(collist '(((No . 0) (Unit . 85))
((No . 1) (Unit . 150))
((No . 2) (Unit . 75))
((No . 3) (Unit . 75))))
(rows (/ (length cells) cols))
(cols (gnumeric-columns collist))
(sheet (gnumeric-sheet "Sample" rows cols cells))
(sheets (list sheet)))
(gnumeric-workbook sheets)))
;;; This function generates a whole whack of cells and formulae
(define (generate-sampl filename)
(let ((p (open-output-file filename))
(ss (build-full-sample)))
(display "<?xml version=\"1.0\"?>" p)
(output-xml-element ss p)
(close-output-port p)))

45
src/scm/html-generator.scm Normal file
View File

@ -0,0 +1,45 @@
;;;; $Id$
;;;; HTML Support functions
(gnc:support "html-generator.scm")
(define (html-table-row header? . items)
(let loop
((cline "<TR>")
(ilist items))
(if (pair? ilist)
(loop (add-html-cell header? cline (car ilist))
(cdr ilist))
(string-append cline "</TR>"))))
(define (html-strong cell)
(string-append
"<STRONG>"
cell
"</STRONG>"))
(define (add-html-cell header? cline item)
(string-append cline (make-html-cell header? item)))
(define (make-html-cell header? item)
(let ((pre ;;; Opening tag
(cond
(header? "<TH justify=center>")
((number? item) "<TD ALIGN=RIGHT>")
(else "<TD>")))
(post ;;; Closing tag
(if header? "</TH>" "</TD>")))
(sprintf #f
(string-append
pre ;;; Start with opening tag
(cond ;;; Body
((string? item) item)
((number? item) (sprintf #f "%.2f" item))
(else ""))
post)))) ;;; closing tag
(define (make-html-cell-header item)
(make-html-cell #t item))
(define (make-html-cell-body item)
(make-html-cell #f item))

104
src/scm/report-utilities.scm Normal file
View File

@ -0,0 +1,104 @@
;;; $ID$
;;; Reporting utilities
(gnc:support "report-utilities.scm")
(define (gnc:filter-list the-list predicate)
(cond ((not (list? the-list))
(gnc:error("Attempted to filter a non-list object")))
((null? the-list) '())
((predicate (car the-list))
(cons (car the-list)
(gnc:filter-list (cdr the-list) predicate)))
(else (gnc:filter-list (cdr the-list) predicate))))
;; like map, but restricted to one dimension, and
;; guaranteed to have inorder semantics.
(define (gnc:inorder-map the-list fn)
(cond ((not (list? the-list))
(gnc:error("Attempted to map a non-list object")))
((not (procedure? fn))
(gnc:error("Attempted to map a non-function object to a list")))
((eq? the-list '()) '())
(else (cons (fn (car the-list))
(gnc:inorder-map (cdr the-list) fn)))))
(define (gnc:for-loop thunk first last step)
(cond ((< first last) (thunk first)
(gnc:for-loop thunk (+ first step) last step))
(else #f)))
;;; applies thunk to each split in account account
(define (gnc:for-each-split-in-account account thunk)
(gnc:for-loop (lambda (x) (thunk (gnc:account-get-split account x)))
0 (gnc:account-get-split-count account) 1))
(define (gnc:group-map-accounts thunk group)
(let loop
((num-accounts (gnc:group-get-num-accounts group))
(i 0))
(if (= i num-accounts)
'()
(cons (thunk (gnc:group-get-account group i))
(loop num-accounts (+ i 1))))))
; (define (gnc:account-transactions-for-each thunk account)
; ;; You must call gnc:group-reset-write-flags on the account group
; ;; before using this...
; (let loop ((num-splits (gnc:account-get-split-count account))
; (i 0))
; (if (< i num-splits)
; (let* ((split (gnc:account-get-split account i))
; (transaction (gnc:split-get-parent split)))
; ;; We don't use the flags just like FileIO does (only 1 pass here).
; (if (= (gnc:transaction-get-write-flag transaction) 0)
; (begin
; (thunk transaction)
; (gnc:transaction-set-write-flag transaction 2)))
; (loop num-splits (+ i 1))))))
(define (gnc:transaction-map-splits thunk transaction)
(let loop ((num-splits (gnc:transaction-get-split-count transaction))
(i 0))
(if (< i num-splits)
(cons
(thunk (gnc:transaction-get-split transaction i))
(loop num-splits (+ i 1)))
'())))
(define (makedrcr-collector)
(let
((debits 0)
(credits 0)
(totalitems 0))
(let
((adder (lambda (amount)
(if (> 0 amount)
(set! credits (- credits amount))
(set! debits (+ debits amount)))
(set! totalitems (+ 1 totalitems))))
(getdebits (lambda () debits))
(getcredits (lambda () credits))
(setdebits (lambda (amount)
(set! debits amount)))
(getitems (lambda () totalitems))
(reset-all (lambda ()
(set! credits 0)
(set! debits 0)
(set! totalitems 0))))
(lambda (action value)
(case action
('add (adder value))
('debits (getdebits))
('credits (getcredits))
('items (getitems))
('reset (reset-all)))))))
;; Add x to list lst if it is not already in there
(define (addunique lst x)
(if (null? lst)
(list x) ; all checked add it
(if (equal? x (car lst))
lst ; found, quit search and don't add again
(cons (car lst) (addunique (cdr lst) x))))) ; keep searching

318
src/scm/report/budget-report.scm Normal file
View File

@ -0,0 +1,318 @@
;; -*-scheme-*-
;; budget-report.scm
;; Report on budget
;; uses some functions from transaction-report
;; Bryan Larsen (blarsen@ada-works.com)
;; situations I want to handle
;; lunch M-F
;; xmas gifts & birthday gifts in same budget line
;; car repairs
;; car fuel-ups
;; paychecks & rent payments
(require 'sort)
;(require 'time)
(gnc:depend "report-utilities.scm")
;; time values
(define gnc:budget-day 1)
(define gnc:budget-week 2)
(define gnc:budget-month 3)
(define gnc:budget-year 4)
;; define the budget itself. For prototype, define inline.
;; the budget is a vector of vectors. the vectors contain:
;; 0 - description: a string describing the budget line
;; 1 - amount:
;; 2 - accounts: the list of accounts that this line spans
;; (in colon delimited format)
;; 3 - period: the time span of the budget line in #4
;; 4 - period-type:
;; 5 - triggers: as yet undefined
(define gnc:budget
#(#("lunch" 8 ("Food:Lunch") 1 gnc:budget-day)
#("junk food" 0.50 ("Food:Junk") 1 gnc:budget-day)))
(define (gnc:budget-get-description budget-line)
(vector-ref budget-line 0))
(define (gnc:budget-get-amount budget-line)
(vector-ref budget-line 1))
(define (gnc:budget-get-accounts budget-line)
(vector-ref budget-line 2))
(define (gnc:budget-get-period budget-line)
(vector-ref budget-line 3))
(define (gnc:budget-get-period-type budget-line)
(vector-ref budget-line 4))
;; budget report: a vector with indexes corresponding to the budget
;; 0 - actual: the amount spend / recieved
;; 1 - desired: the budgeted amount
;; 2 - periods: the number of periods for the line in the report
(define (gnc:budget-report-get-actual brep-line)
(vector-ref brep-line 0))
(define (gnc:budget-report-get-desired brep-line)
(vector-ref brep-line 1))
(define (gnc:budget-report-get-periods brep-line)
(vector-ref brep-line 2))
;; accumulate the actual amounts for the budget given a split and
;; a budget. returns the budget-report vector. The split is a 2 item list:
;; account name and value
;; obsolete
(define (gnc:budget-report-accumulate-actual sub-split budget budget-report)
(do ((i 0 (+ i 1)))
((= i (vector-length budget)) budget-report)
(let ((budget-line (vector-ref budget i))
(budget-report-line (vector-ref budget-report i))
(name (car sub-split))
(value (cadr sub-split)))
(for-each
(lambda (budget-account-name)
(if (string-ci=? name budget-account-name)
(begin
(vector-set! budget-report-line 0
(+ (gnc:budget-report-get-actual budget-report-line)
value)))))
(gnc:budget-get-accounts budget-line)))))
;; add a value to the budget accumulator
(define (gnc:budget-accumulate-actual value budget-report-line)
(vector-set! budget-report-line 0
(+ (gnc:budget-report-get-actual budget-report-line)
value))
budget-report-line)
;; convert budget-report to an html table
(define (gnc:budget-report-to-html budget budget-report)
(let ((budget-html ()))
(do ((i 0 (+ i 1)))
((= i (vector-length budget)) budget-html)
(let ((budget-line (vector-ref budget i))
(budget-report-line (vector-ref budget-report i)))
(set! budget-html
(append
budget-html
(list
(string-append
"<TR><TD>"
(gnc:budget-get-description budget-line)
"</TD><TD align=right>"
(sprintf
#f "%.1f"
(gnc:budget-report-get-periods budget-report-line))
"</TD><TD align=right>"
(sprintf
#f "%.2f" (gnc:budget-report-get-desired
budget-report-line))
"</TD><TD align=right>"
(sprintf
#f "%.2f" (gnc:budget-report-get-actual
budget-report-line))
"</TD><TD align=right>"
(sprintf
#f "%.2f" (- (gnc:budget-report-get-desired
budget-report-line)
(gnc:budget-report-get-actual
budget-report-line)))
"</TD></TR>"))))))))
;; given an account name, return the budget line number
;; return #f if there is no budget line for that account
(define (gnc:budget-get-line-number account-name budget)
(let loop ((i 0))
; (gnc:debug i)
; (gnc:debug (car (gnc:budget-get-accounts (vector-ref budget i))))
(cond ((= i (vector-length budget)) #f)
((let loop2
((accounts (gnc:budget-get-accounts (vector-ref budget i))))
(cond ((null? accounts) #f)
(else (or (string=? account-name (car accounts))
(loop2 (cdr accounts)))))) i)
; ((string=? account-name (car (gnc:budget-get-accounts (vector-ref budget i)))) i)
(else (loop (+ i 1))))))
;; get stuff from localtime date vector
(define (gnc:date-get-year datevec)
(vector-ref datevec 5))
(define (gnc:date-get-month-day datevec)
(vector-ref datevec 3))
;; get month with january==1
(define (gnc:date-get-month datevec)
(+ (vector-ref datevec 4) 1))
(define (gnc:date-get-week-day datevec)
(vector-ref datevec 6))
(define (gnc:date-get-year-day datevec)
(vector-ref datevec 7))
;; is leap year?
(define (gnc:leap-year? year)
(if (= (remainder year 4) 0)
(if (= (remainder year 100) 0)
(if (= (remainder year 400) 0) #t #f)
#t)
#f))
;; number of days in year
(define (gnc:days-in-year year)
(if (gnc:leap-year? year) 366 365))
;; number of days in month
(define (gnc:days-in-month month year)
(case month
((1 3 5 7 8 10 12) 31)
((4 6 9 11) 30)
((2) (if (gnc:leap-year? year) 29 28))))
;; convert a date in seconds since 1970 into # of years since 1970 as
;; a fraction.
(define (gnc:date-to-year-fraction caltime)
(let ((lt (localtime caltime)))
(+ (- (gnc:date-get-year lt) 1970)
(/ (gnc:date-get-year-day lt) (* 1.0 (gnc:days-in-year
(gnc:date-get-year lt)))))))
;; convert a date in seconds since 1970 into # of months since 1970
(define (gnc:date-to-month-fraction caltime)
(let ((lt (localtime caltime)))
(+ (* 12 (- (gnc:date-get-year lt) 1970.0))
(/ (- (gnc:date-get-month-day lt) 1.0) (gnc:days-in-month
(gnc:date-get-month lt))))))
;; convert a date in seconds since 1970 into # of weeks since Jan 4, 1970
;; ignoring leap-seconds
(define (gnc:date-to-week-fraction caltime)
(/ (- (/ (/ caltime 3600.0) 24) 3) 7))
;; convert a date in seconds since 1970 into # of days since Jan 1, 1970
;; ignoring leap-seconds
(define (gnc:date-to-day-fraction caltime)
(/ (/ caltime 3600.0) 24))
;; convert a date to a defined fraction
(define (gnc:date-to-N-fraction caltime type)
(case type
((gnc:budget-day) (gnc:date-to-day-fraction caltime))
((gnc:budget-week) (gnc:date-to-week-fraction caltime))
((gnc:budget-month) (gnc:date-to-month-fraction caltime))
((gnc:budget-year) (gnc:date-to-year-fraction caltime))
(else (gnc:debug "undefined period type in budget!") #f)))
;; calculate the # of periods on a budget line. return the budget report line
;; dates are in # seconds after 1970
(define (gnc:budget-calculate-periods budget-line budget-report-line
begin-date end-date)
(let* ((N-type (gnc:budget-get-period-type budget-line))
(begin-N (gnc:date-to-N-fraction begin-date N-type))
(end-N (gnc:date-to-N-fraction end-date N-type)))
(vector-set! budget-report-line 2
(/ (- end-N begin-N)
(gnc:budget-get-period budget-line)))
budget-report-line))
;; return what you are passed
(define (null-filter)
(lambda(x) x))
;; calculate the expected budget value. return the budget report line
(define (gnc:budget-calculate-expected budget-line budget-report-line
begin-date end-date)
(begin
(vector-set! budget-report-line 1
(* (gnc:budget-get-amount budget-line)
(gnc:budget-report-get-periods budget-report-line)))
budget-report-line))
(gnc:define-report
;; version
1
;; Name
"Budget"
;; Options
trep-options-generator
;; renderer
(lambda (options)
(let* ((begindate (gnc:lookup-option options "Report Options" "From"))
(enddate (gnc:lookup-option options "Report Options" "To"))
(tr-report-account-op (gnc:lookup-option options
"Report Options" "Account"))
(prefix (list "<HTML>" "<BODY bgcolor=#99ccff>"
"<TABLE border=1>"
"<TH>Description</TH>"
"<TH>Number of Periods</TH>"
"<TH>Amount Budgeted</TH>"
"<TH>Amount Spent</TH>"
"<TH>Delta</TH>"))
(suffix (list "</TABLE>" "</BODY>" "</HTML>"))
(input-transactions '())
(budget-report #())
(budget-html "")
(date-filter-pred (gnc:tr-report-make-filter-predicate
(gnc:option-value begindate)
(gnc:option-value enddate)))
(begin-date-secs (car (gnc:timepair-canonical-day-time
(gnc:option-value begindate))))
(end-date-secs (car (gnc:timepair-canonical-day-time
(gnc:option-value enddate))))
(accounts (gnc:option-value tr-report-account-op)))
(set! budget-report (make-vector
(vector-length gnc:budget)))
(do ((i 0 (+ i 1)))
((= i (vector-length gnc:budget)))
(vector-set! budget-report i (vector 0 0 0)))
(let loop ((group (gnc:get-current-group)))
(if (not (pointer-token-null? group))
(gnc:group-map-accounts
(lambda (account)
(let* ((name (gnc:account-get-full-name account))
(line (gnc:budget-get-line-number name gnc:budget))
(children (gnc:account-get-children account)))
(if line
(gnc:for-each-split-in-account
account
(lambda (split)
(vector-set!
budget-report line
(gnc:budget-accumulate-actual
(gnc:split-get-value split)
(vector-ref budget-report line))))))
(if (not (pointer-token-null? children)) (loop children))))
group)))
(gnc:debug budget-report)
(gnc:debug begin-date-secs)
(gnc:debug end-date-secs)
(gnc:debug (gnc:timepair-canonical-day-time
(gnc:option-value begindate)))
(gnc:debug (gnc:timepair-canonical-day-time
(gnc:option-value enddate)))
(do ((i 0 (+ i 1)))
((= i (vector-length gnc:budget)))
(vector-set! budget-report i
(gnc:budget-calculate-expected
(vector-ref gnc:budget i)
(gnc:budget-calculate-periods
(vector-ref gnc:budget i)
(vector-ref budget-report i)
begin-date-secs
end-date-secs)
begin-date-secs
end-date-secs)))
(gnc:debug budget-report)
(set! budget-html (gnc:budget-report-to-html
gnc:budget budget-report))
(append prefix budget-html suffix))))

2
src/scm/report/report-list.scm
View File

@ -7,3 +7,5 @@
(gnc:depend "report/folio.scm")
(gnc:depend "report/hello-world.scm")
(gnc:depend "report/transaction-report.scm")
(gnc:depend "report/budget-report.scm")

175
src/scm/report/transaction-report.scm
View File

@ -241,43 +241,53 @@
(define (gnc:split-get-description-from-parent split)
(gnc:transaction-get-description (gnc:split-get-parent split)))
;; get a full account name
(define (gnc:account-get-full-name account)
(cond ((pointer-token-null? account) "")
(else
(let ((parent-name
(gnc:account-get-full-name
(gnc:group-get-parent
(gnc:account-get-parent account)))))
(if (string=? parent-name "")
(gnc:account-get-name account)
(string-append
parent-name
":"
(gnc:account-get-name account)))))))
;; get the account name of a split
(define (gnc:split-get-account-name split)
(gnc:account-get-name (gnc:split-get-account split)))
(gnc:account-get-full-name (gnc:split-get-account split)))
;; builds a list of the account name and values for the other
;; splits in a transaction
(define (gnc:split-get-corresponding-account-name-and-values split)
(let* ((my-sign (positive? (gnc:split-get-value split)))
(diff-list '())
(define (gnc:split-get-corresponding-account-name-and-values
split split-filter)
(let* ((diff-list '())
(parent-transaction (gnc:split-get-parent split))
(num-splits (gnc:transaction-get-split-count parent-transaction)))
(cond
((= num-splits 1) '())
(else
(gnc:for-loop
(lambda (n)
(let ((split-in-trans
(gnc:transaction-get-split parent-transaction n)))
(if (not (eq? my-sign
(positive? (gnc:split-get-value split-in-trans))))
(set! diff-list
(cons
(let* ((split-in-trans
(gnc:transaction-get-split parent-transaction n))
(sub-split
(list
(gnc:split-get-account-name split-in-trans)
(gnc:split-get-value split-in-trans))
diff-list)))))
(gnc:split-get-value split-in-trans))))
(if (split-filter sub-split)
(set! diff-list
(cons sub-split diff-list)))))
0 num-splits 1)
(reverse diff-list)))))
(reverse diff-list)))
;; takes a C split, extracts relevant data and converts to a scheme
;; representation
;; representation. split-filter is a predicate that filters the splits.
(define (gnc:make-split-scheme-data split)
(define (gnc:make-split-scheme-data split split-filter)
(vector (gnc:split-get-memo split)
(gnc:split-get-action split)
(gnc:split-get-description-from-parent split)
@ -288,7 +298,8 @@
(gnc:split-get-share-price split)
(gnc:split-get-value split)
(gnc:transaction-get-num (gnc:split-get-parent split))
(gnc:split-get-corresponding-account-name-and-values split)))
(gnc:split-get-corresponding-account-name-and-values split
split-filter)))
;; timepair manipulation functions
;; hack alert - these should probably be put somewhere else
@ -307,7 +318,9 @@
(set-tm:min bdt 0)
(set-tm:hour bdt 12)
(let ((newtime (car (mktime bdt))))
(cons newtime (* 1000 newtime)))))
; alert - blarsen@ada-works.com fixed this. you may want to
; revert if I'm wrong.
(cons newtime 0))))
(define (gnc:timepair-earlier-or-eq-date t1 t2)
(let ((time1 (car (gnc:timepair-canonical-day-time t1)))
@ -416,6 +429,24 @@
(and (gnc:timepair-later-or-eq-date split-date early-date)
(gnc:timepair-earlier-or-eq-date split-date late-date)))))
;; applies
;; makes a predicate that returns true only if a sub-split account
;; does not match one of the accounts
(define (gnc:tr-report-make-sub-split-filter-predicate accounts)
(lambda (sub-split)
(let ((result #t))
(for-each
(lambda (account)
(set!
result
(not
(string=?
(gnc:account-get-full-name account)
(car sub-split)))))
accounts)
result)))
;; converts a scheme split representation to a line of HTML,
;; updates the values of total-inflow and total-outflow based
;; on the split value
@ -423,46 +454,54 @@
(define (gnc:tr-report-split-to-html split-scm
starting-balance)
(let ((other-splits (gnc:tr-report-get-other-splits split-scm)))
(string-append
"<TR><TD>"
(gnc:timepair-to-datestring
(gnc:tr-report-get-date split-scm))
"</TD><TD>"
(gnc:tr-report-get-num split-scm)
"</TD><TD>"
(gnc:tr-report-get-description split-scm)
"</TD><TD>"
(gnc:tr-report-get-memo split-scm)
"</TD><TD>"
(cond ((null? other-splits) "")
((= (length other-splits) 1)
(cond ((eqv? (caar other-splits) #f)
"-")
(else (caar other-splits))))
(else "Multi-split (not implemented yet)"))
"</TD><TD>"
(let ((other-splits (gnc:tr-report-get-other-splits split-scm))
(report-string ""))
(cond ((> (gnc:tr-report-get-value split-scm) 0)
(begin
(gnc:set-total-inflow! (+ gnc:total-inflow
(gnc:tr-report-get-value split-scm)))
(string-append
(sprintf #f "%.2f" (gnc:tr-report-get-value split-scm))
"</TD><TD>")))
(gnc:tr-report-get-value split-scm))))
(else
(begin
(gnc:set-total-outflow! (+ gnc:total-outflow
(- (gnc:tr-report-get-value split-scm))))
(- (gnc:tr-report-get-value split-scm))))))
(for-each
(lambda (split-sub first last)
(set! report-string
(string-append
report-string
"<TR><TD>"
(cond (first (gnc:timepair-to-datestring
(gnc:tr-report-get-date split-scm)))
(else ""))
"</TD><TD>"
(cond (first (gnc:tr-report-get-num split-scm))
(else ""))
"</TD><TD>"
(cond (first (gnc:tr-report-get-description split-scm))
(else ""))
"</TD><TD>"
(cond (first (gnc:tr-report-get-memo split-scm))
(else ""))
"</TD><TD>"
(car split-sub)
"</TD><TD>"
(cond ((< (cadr split-sub) 0)
(string-append
(sprintf #f "%.2f" (- (cadr split-sub)))
"</TD><TD>"))
(else
(string-append
"</TD><TD>"
(sprintf #f "%.2f"
(- (gnc:tr-report-get-value split-scm)))))))
"</TD><TD>"
(sprintf #f "%.2f" (cadr split-sub)))))
"</TD>"
(cond ((not last) "</TR>")
(else "")))))
other-splits
(append (list #t) (make-list (- (length other-splits) 1) #f))
(append (make-list (- (length other-splits) 1) #f) (list #t)))
(string-append
report-string
"<TD>"
(sprintf #f "%.2f" (- (+ starting-balance gnc:total-inflow)
gnc:total-outflow))
"</TD></TR>")))
;; gets the balance for a list of splits before beginning-date
@ -510,7 +549,8 @@
"Secondary Key"))
(tr-report-secondary-order-op
(gnc:lookup-option options "Sorting" "Secondary Sort Order"))
(prefix (list "<HTML>" "<BODY bgcolor=#99ccff>" "<TABLE>"
(prefix (list "<HTML>" "<BODY bgcolor=#99ccff>"
"<TABLE>"
"<TH>Date</TH>"
"<TH>Num</TH>"
"<TH>Description</TH>"
@ -524,27 +564,29 @@
(inflow-outflow-line '())
(net-inflow-line '())
(report-lines '())
(accounts (gnc:option-value tr-report-account-op))
(date-filter-pred (gnc:tr-report-make-filter-predicate
(gnc:option-value begindate)
(gnc:option-value enddate)))
(starting-balance 0)
(accounts (gnc:option-value tr-report-account-op)))
(sub-split-filter-pred (gnc:tr-report-make-sub-split-filter-predicate
accounts))
(starting-balance 0))
gnc:tr-report-initialize-inflow-and-outflow!
(if (null? accounts)
(set! report-lines
(list "<TR><TD>There are no accounts to report on.</TD></TR>"))
(begin
; reporting on more than one account not yet supported
(gnc:for-each-split-in-account
(car accounts)
(lambda (split)
(set! report-lines
(append! report-lines
(list (gnc:make-split-scheme-data split))))))
(list (gnc:make-split-scheme-data
split sub-split-filter-pred))))))
(set! starting-balance
(gnc:tr-report-get-starting-balance
report-lines (gnc:option-value begindate)))
(set! report-lines (gnc:filter-list report-lines date-filter-pred))
(set! report-lines
(sort!
@ -558,7 +600,7 @@
(set! report-lines (gnc:inorder-map report-lines html-mapper)))
(set!
balance-line
(list "<TR><TD><STRONG>Balance at: "
(list "<TR><TD><STRONG>"
(gnc:timepair-to-datestring (gnc:option-value begindate))
"</STRONG></TD>"
"<TD></TD>"
@ -598,3 +640,14 @@
"</TD></STRONG></TR>"))))
(append prefix balance-line report-lines
inflow-outflow-line net-inflow-line suffix))))

175
src/scm/xml-generator.scm Normal file
View File

@ -0,0 +1,175 @@
;;;;;;;;;;;;;
;;;; $Id$
;;;;;;;;;;;;; Generating XML out of Scheme Lists
(gnc:support "xml-generator.scm")
;;;;;;;;;;;;;
;;;; by Christopher Browne
;;;; <cbbrowne@hex.net>, <cbbrowne@ntlug.org>
;;;;
;;;; This was created for GnuCash to assist in creating
;;;; XML output to generate spreadsheets readable by
;;;; Gnumeric.
;;;;
;;;; The model is that an element consists of a list with
;;;; three entries. Elements are created thus:
;;;; (define (make-xml-element tag attributes children)
;;;; (list tag attributes children))
;;;; - The first entry is the tag name.
;;;; - The second entry optionally consists of an association list
;;;; containing the attributes of the element, or is #f.
;;;; - The third entry is either a list of children, or is #f.
;;;;
;;;; Notable idiosyncracies aka "features" aka "misfeatures":
;;;; - All elements may come in the form of symbols, strings, or
;;;; numbers. output-xml-element (and helpers) transform these all
;;;; into strings.
;;;; - It is possible that efficiency could be improved by memoizing
;;;; the strings that get generated. That way, we don't need to
;;;; generate a new string each time a symbol gets hit.
;;;; - The "children" can have three values:
;;;; a) #f, indicating that there are no children, as with:
;;;; (NoEndTag ((Att1 . 1) (Att2 . 2)) #f) which turns into
;;;; <NoEndTag Att1="1" Att2="2"/>
;;;; b) It may be a simple attribute, like "Contents" or 1.5, as
;;;; with (SimpleEndTag #f "Contents") which transforms to:
;;;; <SimpleEndTag>Contents</SimpleEndTag>
;;;; c) Otherwise, it must consist of a list of elements, thusly:
;;;; (Parent #f ((Child #f Value1) (Child #f Value2)) which turns
;;;; to: <Parent> <Child>Value1</Child> <Child>Value2</Child> </Parent>
;;;;
;;;; Usage
;;;; -------
;;;; The driver of it is (output-xml-element element port).
;;;; One might output an XML document with a root node, ROOT, thus:
;;;;(let ((port (open-output-file "/tmp/sampleoutput")))
;;;; (display "<?xml version=\"1.0\"?>" port)
;;;; (newline port)
;;;; (output-xml-element ROOT port)
;;;; (close-output-port port))
;;;;
;;;; If you have a Very Large Document, you might not want to
;;;; construct the whole document as One Big List;
;;;; output-xml-element will be useful for generating subtree output.
;;;; Your control structure will need to duplicate the structure of
;;;; output-xml-element. Alternatively, it would be a slick idea to
;;;; change output-xml-element so that "children" could be a thunk
;;;; (function with no arguments) that invokes output-xml-element
;;;; internally as needed.
(define xml-indentation 0)
(define (xml-display x port)
(if port
(display x port)
(display x)))
(define (xml-newline port)
(if port
(newline port)
(newline)))
(define (make-tabs port)
(let loop
((i 0))
(if (>= i xml-indentation)
#f
(begin
(xml-display " " port)
(loop (+ i 1)))))
(set! xml-indentation (+ xml-indentation 1)))
(define (output-xml-element-name elname port)
(xml-newline port)
(make-tabs port)
(xml-display
(string-append
"<"
(element-to-string elname))
port))
(define (output-xml-element-name-end elname port)
(set! xml-indentation (- xml-indentation 1))
(xml-display
(string-append
"</"
(element-to-string elname)
">")
port))
(define (output-xml-attribute att port)
; (display "output-xml-attribute: ") (display attribute) (newline)
(xml-display (string-append
" "
(element-to-string (car att))
"=\""
(element-to-string (cdr att))
"\"")
port))
(define (element-to-string obj)
; (display "[element-to-string: ") (display obj) (display "]") (newline)
(cond
((string? obj) obj)
((symbol? obj) (symbol->string obj))
((number? obj) (number->string obj))
(else
(string-append "[ERROR in element-to-string: "
(list->string (list obj))
" not a symbol, string or number.]"))))
(define (output-xml-attributes attributes port)
;(display "output-xml-attributes: ") (display attributes) (newline)
(if attributes
(for-each
(lambda (attribute)
(output-xml-attribute attribute port))
attributes)))
(define (output-xml-children children port)
; (display "[output-xml-children: ") (display children) (display "]")(newline)
(cond
((list? children)
(for-each (lambda (child)
(output-xml-element child port))
children))
(else
(xml-display (element-to-string children) port))))
(define (output-xml-element element port)
(let ((elname (car element))
(attributes (cadr element))
(children (caddr element)))
(output-xml-element-name elname port)
(output-xml-attributes attributes port)
(cond
((not children) ;;; If children is blank
(xml-display "/>" port)) ;;; Short result
((procedure? children) ;;; children is a function
(xml-display ">" port)
(children port) ;;; Invoke the function
(output-xml-element-name-end elname port))
(else
(xml-display ">" port)
(output-xml-children children port)
(output-xml-element-name-end elname port)))))
(define (xml-element tag attributes children)
(list tag attributes children))
(define (xml-attribute name value)
(cons name value))
(define (xml-attributes . alist)
alist)
;;; (if (> 0 (length alist)) ;;; If there's anything in the list
;;; alist ;;; Return the list
;;; #f)) ;;; Otherwise, blank to #f
(define no-attributes
(xml-attributes))
(define no-children
#f)