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

Robert Graham Merkel's relative date option patch.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2729 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2000-08-30 07:46:19 +00:00
parent c7b731c074
commit 23ffb366f2
12 changed files with 1085 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
ChangeLog
View File

@ -1,3 +1,37 @@
2000-08-30 Robert Graham Merkel <rgmerk@mira.net>
* src/scm/report/hello-world.scm: A couple of new functions to test the relative
and combination date style options.
* src/scm/report/*.scm: Modified date options to take the new function. Most
are still using absolute options at this stage, will get modified to use relative
dates later.
* src/scm/options.scm (gnc:make-option): new argument (option-data-fns)
for manipulating multi-choice style options. Changes
to option-makers to either support this.
(gnc:make-date-option): modified to support relative and combination dates.
* src/scm/date-utilities.scm: Extensive additions for manipulating
relative dates.
* src/guile/option-util.c: Support for new relative-date and
combination options , and use of scheme getters
rather than direct data structure manipulation.
(gnc_oiption_db_lookup_date_option): modified to
support relative and combination date options.
(gnc_option_date_option_get_subtype: new function.
* src/guile/guile-util.c (gnc_timepair2timespec): Check to make
sure it's a timepair before doing conversion.
* src/gnome/dialog-options.c: Extensive changes to support relative
and combination date options. Also changed multichoice callback
to use wrapped scheme getter rather than directly manipulating
scheme data structure.
* make-gnucash-patch.in: Exclude generated HTML.
2000-08-26 Dave Peticolas <dave@krondo.com>
* src/engine/Group.c (xaccGetAccountRoot): remove unnecessary

1
make-gnucash-patch.in
View File

@ -160,5 +160,6 @@ src/optional/swig/gnucash.engine_wrap.doc
src/optional/swig/libgncswig.la
src/quotes/gnc-prices
src/scm/bootstrap.scm
doc/sgml/C/gnucash
stamp-cat-id
stamp-h

426
src/gnome/dialog-options.c
View File

@ -21,7 +21,6 @@
\********************************************************************/
#include <top-level.h>
#include <gnome.h>
#include "dialog-options.h"
@ -42,6 +41,89 @@
/* This static indicates the debugging module that this .o belongs to. */
static short module = MOD_GUI;
typedef enum {
GNC_RD_WID_AB_BUTTON_POS = 0,
GNC_RD_WID_AB_WIDGET_POS,
GNC_RD_WID_REL_BUTTON_POS,
GNC_RD_WID_REL_WIDGET_POS} GNCRdPositions;
static void
gnc_option_changed_cb(GtkEditable *editable, gpointer data)
{
GtkWidget *raw, *pbox;
GNCOption *option = data;
raw = GTK_WIDGET(editable);
option->changed = TRUE;
gnc_option_call_option_widget_changed_proc(option);
pbox = gtk_widget_get_toplevel(raw);
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static void
gnc_date_option_changed_cb(GtkWidget *dummy, gpointer data)
{
GtkWidget *pbox;
GNCOption *option = data;
option->changed = TRUE;
gnc_option_call_option_widget_changed_proc(option);
pbox = gtk_widget_get_toplevel(option->widget);
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static void
gnc_date_option_set_select_method(GNCOption *option, gboolean use_absolute,
gboolean set_buttons)
{
GList* widget_list;
GtkWidget *ab_button, *rel_button, *rel_widget, *ab_widget;
widget_list = gtk_container_children(GTK_CONTAINER(option->widget));
ab_button = g_list_nth_data(widget_list, GNC_RD_WID_AB_BUTTON_POS);
ab_widget = g_list_nth_data(widget_list, GNC_RD_WID_AB_WIDGET_POS);
rel_button = g_list_nth_data(widget_list, GNC_RD_WID_REL_BUTTON_POS);
rel_widget = g_list_nth_data(widget_list, GNC_RD_WID_REL_WIDGET_POS);
if(use_absolute)
{
gtk_widget_set_sensitive(ab_widget, TRUE);
gtk_widget_set_sensitive(rel_widget, FALSE);
if(set_buttons)
{
gtk_toggle_button_set_active(GTK_TOGGLE_BUTTON(ab_button), TRUE);
}
}
else
{
gtk_widget_set_sensitive(rel_widget, TRUE);
gtk_widget_set_sensitive(ab_widget, FALSE);
if (set_buttons)
{
gtk_toggle_button_set_active(GTK_TOGGLE_BUTTON(rel_button), TRUE);
}
}
}
static void
gnc_rd_option_ab_set_cb(GtkWidget *widget, gpointer *raw_option)
{
GNCOption *option = (GNCOption *) raw_option;
gnc_date_option_set_select_method(option, TRUE, FALSE);
gnc_date_option_changed_cb(widget, option);
}
static void
gnc_rd_option_rel_set_cb(GtkWidget *widget, gpointer *raw_option)
{
GNCOption *option = (GNCOption *) raw_option;
gnc_date_option_set_select_method(option, FALSE, FALSE);
gnc_date_option_changed_cb(widget, option);
return;
}
/********************************************************************\
* gnc_option_set_ui_value *
@ -120,15 +202,95 @@ gnc_option_set_ui_value(GNCOption *option, gboolean use_default)
}
else if (safe_strcmp(type, "date") == 0)
{
Timespec ts;
if (gnc_timepair_p(value))
SCM symbol;
int index;
char *date_option_type;
char *symbol_str;
date_option_type = gnc_option_date_option_get_subtype(option);
if (gh_vector_p(value))
{
ts = gnc_timepair2timespec(value);
gnc_date_edit_set_time(GNC_DATE_EDIT(option->widget), ts.tv_sec);
symbol = gh_vector_ref(value, gh_int2scm(0));
if(gh_symbol_p(symbol))
{
symbol_str = gh_symbol2newstr(symbol, NULL);
if (safe_strcmp(symbol_str, "relative") == 0)
{
index = gnc_option_permissible_value_index(option, gh_vector_ref(value, gh_int2scm(2)));
if (safe_strcmp(date_option_type, "relative") == 0)
{
gtk_object_set_data(GTK_OBJECT(option->widget),
"gnc_multichoice_index",
GINT_TO_POINTER(index));
gtk_option_menu_set_history(GTK_OPTION_MENU(option->widget),
index);
}
else if (safe_strcmp(date_option_type, "both") == 0)
{
GList *widget_list;
GtkWidget *rel_date_widget;
widget_list = gtk_container_children(GTK_CONTAINER(option->widget));
rel_date_widget = g_list_nth_data(widget_list,
GNC_RD_WID_REL_WIDGET_POS);
gnc_date_option_set_select_method(option, FALSE, TRUE);
gtk_object_set_data(GTK_OBJECT(rel_date_widget),
"gnc_multichoice_index",
GINT_TO_POINTER(index));
gtk_option_menu_set_history(GTK_OPTION_MENU(rel_date_widget),
index);
}
else
{
bad_value = TRUE;
}
}
else if (safe_strcmp(symbol_str, "absolute") == 0)
{
Timespec ts;
SCM tp;
tp = gh_vector_ref(value, gh_int2scm(1));
if (gnc_timepair_p(tp))
{
ts = gnc_timepair2timespec(tp);
if (safe_strcmp(date_option_type, "absolute") == 0)
{
gnc_date_edit_set_time(GNC_DATE_EDIT(option->widget), ts.tv_sec);
}
else if (safe_strcmp(date_option_type, "both") == 0)
{
GList *widget_list;
GtkWidget *ab_widget;
widget_list = gtk_container_children(GTK_CONTAINER(option->widget));
ab_widget = g_list_nth_data(widget_list,
GNC_RD_WID_AB_WIDGET_POS);
gnc_date_option_set_select_method(option, TRUE, TRUE);
gnc_date_edit_set_time(GNC_DATE_EDIT(option->widget), ts.tv_sec);
}
else
{
bad_value = TRUE;
}
}
else
{
bad_value = TRUE;
}
}
else
{
bad_value = TRUE;
}
free(symbol_str);
}
}
else
{
bad_value = TRUE;
}
g_free(date_option_type);
}
else if (safe_strcmp(type, "account-list") == 0)
{
@ -292,14 +454,57 @@ gnc_option_get_ui_value(GNCOption *option)
}
else if (safe_strcmp(type, "date") == 0)
{
Timespec ts;
int index;
SCM type, val;
char *subtype = gnc_option_date_option_get_subtype(option);
if(safe_strcmp(subtype, "relative") == 0)
{
index = GPOINTER_TO_INT(gtk_object_get_data(GTK_OBJECT(option->widget),
"gnc_multichoice_index"));
type = gh_symbol2scm("relative");
val = gnc_option_permissible_value(option, index);
result = gh_cons(type, val);
}
else if (safe_strcmp(subtype, "absolute") == 0)
{
Timespec ts;
ts.tv_sec = gnc_date_edit_get_date(GNC_DATE_EDIT(option->widget));
ts.tv_nsec = 0;
result = gh_cons(gh_symbol2scm("absolute"), gnc_timespec2timepair(ts));
}
else if (safe_strcmp(subtype, "both") == 0)
{
Timespec ts;
int index;
SCM val;
GList *widget_list;
GtkWidget *ab_button, *rel_widget, *ab_widget;
widget_list = gtk_container_children(GTK_CONTAINER(option->widget));
ab_button = g_list_nth_data(widget_list, GNC_RD_WID_AB_BUTTON_POS);
ab_widget = g_list_nth_data(widget_list, GNC_RD_WID_AB_WIDGET_POS);
rel_widget = g_list_nth_data(widget_list, GNC_RD_WID_REL_WIDGET_POS);
ts.tv_sec = gnc_date_edit_get_date(GNC_DATE_EDIT(option->widget));
ts.tv_nsec = 0;
result = gnc_timespec2timepair(ts);
/* if it's an absolute date */
if(gtk_toggle_button_get_active(GTK_TOGGLE_BUTTON(ab_button)))
{
ts.tv_sec = gnc_date_edit_get_date(GNC_DATE_EDIT(ab_widget));
ts.tv_nsec = 0;
result = gh_cons(gh_symbol2scm("absolute"), gnc_timespec2timepair(ts));
}
else
{
index = GPOINTER_TO_INT(gtk_object_get_data(GTK_OBJECT(rel_widget),
"gnc_multichoice_index"));
val = gnc_option_permissible_value(option, index);
result = gh_cons(gh_symbol2scm("relative"), val);
}
}
g_free(subtype);
}
else if (safe_strcmp(type, "account-list") == 0)
else if (safe_strcmp(type, "account-list") == 0)
{
GNCAccountTree *tree;
GList *list;
@ -385,7 +590,7 @@ gnc_option_get_ui_value(GNCOption *option)
* GUI option. *
* *
* Args: section - section of option *
* name - name of option
* name - name of option *
* selectable - if false, update the widget so that it *
* cannot be selected by the user. If true, *
* update the widget so that it can be selected.*
@ -451,19 +656,6 @@ gnc_option_toggled_cb(GtkToggleButton *button, gpointer data)
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static void
gnc_option_changed_cb(GtkEditable *editable, gpointer data)
{
GtkWidget *pbox;
GNCOption *option = data;
option->changed = TRUE;
gnc_option_call_option_widget_changed_proc(option);
pbox = gtk_widget_get_toplevel(GTK_WIDGET(editable));
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static void
gnc_option_multichoice_cb(GtkWidget *w, gint index, gpointer data)
@ -493,6 +685,154 @@ gnc_option_multichoice_cb(GtkWidget *w, gint index, gpointer data)
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static void
gnc_option_rd_combo_cb(GtkWidget *w, gint index, gpointer data)
{
GtkWidget *widget, *pbox, *omenu;
GList *children;
GNCOption *option = data;
gpointer _current;
gint current;
children = gtk_container_children(GTK_CONTAINER(option->widget));
widget = g_list_nth_data(children, GNC_RD_WID_REL_WIDGET_POS);
_current = gtk_object_get_data(GTK_OBJECT(widget),
"gnc_multichoice_index");
current = GPOINTER_TO_INT(_current);
if (current == index)
return;
gtk_option_menu_set_history(GTK_OPTION_MENU(widget), index);
gtk_object_set_data(GTK_OBJECT(widget), "gnc_multichoice_index",
GINT_TO_POINTER(index));
option->changed = TRUE;
gnc_option_call_option_widget_changed_proc(option);
omenu = gtk_object_get_data(GTK_OBJECT(w), "gnc_option_menu");
pbox = gtk_widget_get_toplevel(omenu);
gnome_property_box_changed(GNOME_PROPERTY_BOX(pbox));
}
static GtkWidget *
gnc_option_create_date_widget (GNCOption *option)
{
GtkWidget * box = NULL;
GtkWidget *rel_button= NULL, *ab_button=NULL;
GtkWidget *rel_widget=NULL, *ab_widget=NULL;
GtkWidget *entry;
gboolean show_time, use24;
GNCOptionInfo *info;
char *type;
char **raw_strings;
char **raw;
int num_values;
type = gnc_option_date_option_get_subtype(option);
show_time = gnc_option_show_time(option);
use24 = gnc_lookup_boolean_option("International",
"Use 24-hour time format", FALSE);
if(safe_strcmp(type, "relative") != 0)
{
ab_widget = gnc_date_edit_new(time(NULL), show_time, use24);
entry = GNC_DATE_EDIT(ab_widget)->date_entry;
gtk_signal_connect(GTK_OBJECT(entry), "changed",
GTK_SIGNAL_FUNC(gnc_date_option_changed_cb), option);
if (show_time)
{
entry = GNC_DATE_EDIT(ab_widget)->time_entry;
gtk_signal_connect(GTK_OBJECT(entry), "changed",
GTK_SIGNAL_FUNC(gnc_date_option_changed_cb), option);
}
}
if(safe_strcmp(type, "absolute") != 0)
{
int i;
num_values = gnc_option_num_permissible_values(option);
g_return_val_if_fail(num_values >= 0, NULL);
info = g_new0(GNCOptionInfo, num_values);
raw_strings = g_new0(char *, num_values * 2);
raw = raw_strings;
for (i = 0; i < num_values; i++)
{
*raw = gnc_option_permissible_value_name(option, i);
if (*raw != NULL)
info[i].name = _(*raw);
else
info[i].name = "";
raw++;
*raw = gnc_option_permissible_value_description(option, i);
if (*raw != NULL)
info[i].tip = _(*raw);
else
info[i].tip = "";
if(safe_strcmp(type, "both") == 0)
{
info[i].callback = gnc_option_rd_combo_cb;
}
else
{
info[i].callback = gnc_option_multichoice_cb;
}
info[i].user_data = option;
}
rel_widget = gnc_build_option_menu(info, num_values);
for (i = 0; i < num_values * 2; i++)
if (raw_strings[i] != NULL)
free(raw_strings[i]);
g_free(raw_strings);
g_free(info);
}
if(safe_strcmp(type, "absolute") == 0)
{
free(type);
option->widget = ab_widget;
return ab_widget;
}
else if (safe_strcmp(type, "relative") == 0)
{
option->widget = rel_widget;
free(type);
return rel_widget;
}
else if (safe_strcmp(type, "both") == 0)
{
box = gtk_hbox_new(FALSE, 5);
ab_button = gtk_radio_button_new(NULL);
gtk_signal_connect(GTK_OBJECT(ab_button), "toggled",
GTK_SIGNAL_FUNC(gnc_rd_option_ab_set_cb), option);
rel_button = gtk_radio_button_new_from_widget(GTK_RADIO_BUTTON(ab_button));
gtk_signal_connect(GTK_OBJECT(rel_button), "toggled",
GTK_SIGNAL_FUNC(gnc_rd_option_rel_set_cb), option);
gtk_box_pack_start(GTK_BOX(box), ab_button, FALSE, FALSE, 0);
gtk_box_pack_start(GTK_BOX(box), ab_widget, FALSE, FALSE, 0);
gtk_box_pack_start(GTK_BOX(box), rel_button, FALSE, FALSE, 0);
gtk_box_pack_start(GTK_BOX(box), rel_widget, FALSE, FALSE, 0);
free(type);
option->widget = box;
return box;
}
else /* can't happen */
{
return NULL;
}
}
static GtkWidget *
gnc_option_create_multichoice_widget(GNCOption *option)
{
@ -529,6 +869,7 @@ gnc_option_create_multichoice_widget(GNCOption *option)
info[i].callback = gnc_option_multichoice_cb;
info[i].user_data = option;
raw++;
}
widget = gnc_build_option_menu(info, num_values);
@ -536,7 +877,7 @@ gnc_option_create_multichoice_widget(GNCOption *option)
for (i = 0; i < num_values * 2; i++)
if (raw_strings[i] != NULL)
free(raw_strings[i]);
g_free(raw_strings);
g_free(info);
@ -614,7 +955,7 @@ gnc_option_create_account_widget(GNCOption *option, char *name)
gnc_account_tree_refresh(GNC_ACCOUNT_TREE(tree));
if (multiple_selection)
gtk_clist_set_selection_mode(GTK_CLIST(tree), GTK_SELECTION_MULTIPLE);
else
else
gtk_clist_set_selection_mode(GTK_CLIST(tree), GTK_SELECTION_BROWSE);
scroll_win = gtk_scrolled_window_new(NULL, NULL);
@ -962,11 +1303,8 @@ gnc_option_set_ui_widget(GNCOption *option,
}
else if (safe_strcmp(type, "date") == 0)
{
GtkWidget *entry;
GtkWidget *label;
gchar *colon_name;
gboolean show_time;
gboolean use24;
colon_name = g_strconcat(name, ":", NULL);
label= gtk_label_new(colon_name);
@ -975,33 +1313,19 @@ gnc_option_set_ui_widget(GNCOption *option,
enclosing = gtk_hbox_new(FALSE, 5);
show_time = gnc_option_show_time(option);
use24 = gnc_lookup_boolean_option("International",
"Use 24-hour time format", FALSE);
value = gnc_date_edit_new(time(NULL), show_time, use24);
value = gnc_option_create_date_widget(option);
option->widget = value;
gnc_option_set_ui_value(option, FALSE);
entry = GNC_DATE_EDIT(value)->date_entry;
gtk_tooltips_set_tip(tooltips, entry, documentation, NULL);
gtk_signal_connect(GTK_OBJECT(entry), "changed",
GTK_SIGNAL_FUNC(gnc_option_changed_cb), option);
if (show_time)
{
entry = GNC_DATE_EDIT(value)->time_entry;
gtk_tooltips_set_tip(tooltips, entry, documentation, NULL);
gtk_signal_connect(GTK_OBJECT(entry), "changed",
GTK_SIGNAL_FUNC(gnc_option_changed_cb), option);
}
gtk_box_pack_start(GTK_BOX(enclosing), label, FALSE, FALSE, 0);
gtk_box_pack_start(GTK_BOX(enclosing), value, FALSE, FALSE, 0);
gtk_box_pack_end(GTK_BOX(enclosing),
gnc_option_create_default_button(option, tooltips),
FALSE, FALSE, 0);
FALSE, FALSE, 0);
gtk_box_pack_start(page_box, enclosing, FALSE, FALSE, 5);
packed = TRUE;
gnc_option_set_ui_value(option, FALSE);
}
else if (safe_strcmp(type, "account-list") == 0)
{

382
src/scm/date-utilities.scm
View File

@ -19,7 +19,7 @@
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
(gnc:support "dateutils.scm")
(gnc:support "date-utilities.scm")
(gnc:depend "srfi/srfi-19.scm")
(define (gnc:timepair->secs tp)
@ -27,6 +27,9 @@
(+ (car tp)
(/ (cdr tp) 1000000000))))
(define (gnc:secs->timepair secs)
(cons secs 0))
(define (gnc:timepair->date tp)
(localtime (gnc:timepair->secs tp)))
@ -283,3 +286,380 @@
(set-tm:hour bdt 23)
(let ((newtime (car (mktime bdt))))
(cons newtime 0))))
(define (gnc:reldate-get-symbol x) (vector-ref x 0))
(define (gnc:reldate-get-string x) (vector-ref x 1))
(define (gnc:reldate-get-desc x) (vector-ref x 2))
(define (gnc:reldate-get-fn x) (vector-ref x 3))
(define (gnc:make-reldate-hash hash reldate-list)
(map (lambda (reldate) (hash-set!
hash
(gnc:reldate-get-symbol reldate)
reldate))
reldate-list))
(define gnc:reldate-string-db (gnc:make-string-database))
(define gnc:relative-date-values '())
(define gnc:relative-date-hash (make-hash-table 23))
(define (gnc:get-absolute-from-relative-date date-symbol)
(let ((rel-date-data (hash-ref gnc:relative-date-hash date-symbol)))
(if rel-date-data
((gnc:reldate-get-fn rel-date-data))
(gnc:error "Tried to look up an undefined date symbol"))))
(define (gnc:get-relative-date-strings date-symbol)
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(cons (gnc:reldate-get-string rel-date-info)
(gnc:relate-get-desc rel-date-info))))
(define (gnc:get-relative-date-string date-symbol)
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(gnc:reldate-get-string rel-date-info)))
(define (gnc:get-relative-date-desc date-symbol)
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
(gnc:reldate-get-desc rel-date-info)))
(define (gnc:get-start-cal-year)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 0)
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-start-prev-year)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 0)
(set-tm:year now (- (tm:year now) 1))
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-end-prev-year)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now 31)
(set-tm:mon now 11)
(set-tm:year now (- (tm:year now) 1))
(gnc:secs->timepair (car (mktime now)))))
;; FIXME:: Replace with option when it becomes available
(define (gnc:get-start-cur-fin-year)
(let ((now (localtime (current-time))))
(if (< (tm:mon now) 6)
(begin
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 6)
(set-tm:year now (- (tm:year now) 1))
(gnc:secs->timepair (car (mktime now))))
(begin
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 6)
(gnc:secs->timepair (car (mktime now)))))))
(define (gnc:get-start-prev-fin-year)
(let ((now (localtime (current-time))))
(if (< (tm:mon now) 6)
(begin
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 6)
(set-tm:year now (- (tm:year now) 2))
(cons (car (mktime now)) 0))
(begin
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:mon now 6)
(set-tm:year now (- (tm:year now) 2))
(cons (car (mktime now)) 0)))))
(define (gnc:get-end-prev-fin-year)
(let ((now (localtime (current-time))))
(if (< (tm:mon now) 6)
(begin
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now 30)
(set-tm:mon now 5)
(cons (car (mktime now)) 0))
(begin
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now 30)
(set-tm:mon now 5)
(set-tm:year now (- (tm:year now) 1))
(cons (car (mktime now)) 0)))))
(define (gnc:get-start-this-month)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(cons (car (mktime now)) 0)))
(define (gnc:get-start-prev-month)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(if (= (tm:mon now) 0)
(begin
(set-tm:mon now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:mon now (- (tm:mon now) 1)))
(cons (car (mktime now)) 0)))
(define (gnc:get-end-prev-month)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (= (tm:month now 0))
(begin
(set-tm:month now 11)
(set-tm:year (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now) 1)))
(set-tm:mday (gnc:days-in-month (+ (tm:month now) 1)) (+ (tm:year) 1900))
(cons (car (mktime now)) 0)))
(define (gnc:get-start-current-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:month now (- (tm:month now) (mod (tm:month now) 3)))
(cons (car (mktime now)) 0)))
(define (gnc:get-start-prev-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:month now (- (tm:month now) (mod (tm:month now) 3)))
(if (= (tm:month now) 0)
(begin
(set-tm:month now 9)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm-month now) 3)))
(cons (car (mktime now) 0))))
(define (gnc:get-end-prev-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (< (tm:month now) 3)
(begin
(set-tm:month now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now)
(3 + (mod (tm:month now) 3)))))
(set-tm:mday (gnc:days-in-month
(+ (tm:month now) 1)) (+ (tm:year) 1900))
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-today)
(cons (current-time) 0))
(define (gnc:get-one-month-ago)
(let ((now (localtime (current-time))))
(if (= (tm:month now) 0)
(begin
(set-tm:month now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now) 1)))
(let ((month-length (gnc:days-in-month (+ (tm:month now) 1)
(+ (tm:year now) 1900))))
(if (> month-length (tm:mday now))
(set-tm:mday month-length))
(gnc:secs->timepair (car (mktime now))))))
(define (gnc:get-three-months-ago)
(let ((now (localtime (current-time))))
(if (< (tm:month now) 3)
(begin
(set:tm-month now (+ (tm:month now) 12))
(set:tm-year now (- (tm:year now) 1))))
(set:tm-month now (- (tm:month now) 3))
(let ((month-days) (gnc:days-in-month
(+ (tm:month now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
(gnc:secs->timepair (car (mktime now))))))
(define (gnc:get-six-months-ago)
(let ((now (localtime (current-time))))
(if (< (tm:month now) 6)
(begin
(set:tm-month now (+ (tm:month now) 12))
(set:tm-year now (- (tm:year now) 1))))
(set:tm-month now (- (tm:month now) 6))
(let ((month-days) (gnc:days-in-month
(+ (tm:month now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
(gnc:secs->timepair (car (mktime now))))))
(define (gnc:get-one-year-ago)
(let ((now (localtime (current-time))))
(set:tm-year now (- (tm:year now) 1))
(let ((month-days) (gnc:days-in-month
(+ (tm:month now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
(gnc:secs->timepair (car (mktime now))))))
(define (gnc:reldate-all-reldates)
(list 'start-cal-year 'start-prev-year 'end-prev-year 'start-cur-fin-year 'start-prev-fin-year
'start-this-month 'start-prev-month 'end-prev-month 'start-current-quarter
'start-prev-quarter 'end-prev-quarter 'today 'one-month-ago 'three-months-ago
'six-months-ago
'one-year-ago))
(gnc:reldate-string-db 'store 'start-cal-year-string "Current Year Start")
(gnc:reldate-string-db 'store 'start-cal-year-desc "Start of the current calendar year")
(gnc:reldate-string-db 'store 'start-prev-year-string "Previous Year Start")
(gnc:reldate-string-db 'store 'start-prev-year-desc "Beginning of the previous calendar year")
(gnc:reldate-string-db 'store 'end-prev-year-string "Previous Year End")
(gnc:reldate-string-db 'store 'end-prev-year-desc "End of the Previous Year")
(gnc:reldate-string-db 'store 'start-cur-fin-year-string "Current Financial Year Start")
(gnc:reldate-string-db 'store 'start-cur-fin-year-desc "Start of the current financial year/accounting period")
(gnc:reldate-string-db 'store 'start-prev-fin-year-string "Previous Financial Year Start")
(gnc:reldate-string-db 'store 'start-prev-financial-year-desc "The start of the previous financial year/accounting period")
(gnc:reldate-string-db 'store 'end-prev-fin-year-string "End Previous Financial Year")
(gnc:reldate-string-db 'store 'end-prev-fin-year-desc "End of the previous Financial year/Accounting Period")
(gnc:reldate-string-db 'store 'start-this-month-string "Start of this month")
(gnc:reldate-string-db 'store 'start-this-month-desc "Start of the current month")
(gnc:reldate-string-db 'store 'start-prev-month-string "Start of previous month")
(gnc:reldate-string-db 'store 'start-prev-month-desc "The beginning of the previous month")
(gnc:reldate-string-db 'store 'end-prev-month-string "End of previous month")
(gnc:reldate-string-db 'store 'end-prev-month-description "Last day of previous month")
(gnc:reldate-string-db 'store 'start-current-quarter-string "Start of current quarter")
(gnc:reldate-string-db 'store 'start-current-quarter-desc "The start of the latest quarterly accounting period")
(gnc:reldate-string-db 'store 'start-prev-quarter-string "Start of previous quarter")
(gnc:reldate-string-db 'store 'start-prev-quarter-desc "The start of the previous quarterly accounting period")
(gnc:reldate-string-db 'store 'end-prev-quarter-string "End of previous quarter")
(gnc:reldate-string-db 'store 'end-prev-quarter-desc "End of previous quarterly accounting period")
(gnc:reldate-string-db 'store 'today-string "Today")
(gnc:reldate-string-db 'store 'today-desc "The current date")
(gnc:reldate-string-db 'store 'one-month-ago-string "One Month Ago")
(gnc:reldate-string-db 'store 'one-month-ago-desc "One Month Ago")
(gnc:reldate-string-db 'store 'one-week-ago-string "One Week Ago")
(gnc:reldate-string-db 'store 'one-week-ago-desc "One Week Ago")
(gnc:reldate-string-db 'store 'three-months-ago-string "Three Months Ago")
(gnc:reldate-string-db 'store 'three-months-ago-desc "Three Months Ago")
(gnc:reldate-string-db 'store 'six-months-ago-string "Six Months Ago")
(gnc:reldate-string-db 'store 'six-months-ago-string "Six Months Ago")
(gnc:reldate-string-db 'store 'one-year-ago-string "One Year Ago")
(gnc:reldate-string-db 'store 'one-year-ago-desc "One Year Ago")
(set! gnc:relative-date-values
(list
(vector 'start-cal-year
(gnc:reldate-string-db 'lookup 'start-cal-year-string)
(gnc:reldate-string-db 'lookup 'start-cal-year-desc)
gnc:get-start-cal-year)
(vector 'start-prev-year
(gnc:reldate-string-db 'lookup 'start-prev-year-string)
(gnc:reldate-string-db 'lookup 'start-prev-year-desc)
gnc:get-start-prev-year)
(vector 'end-prev-year
(gnc:reldate-string-db 'lookup 'end-prev-year-string)
(gnc:reldate-string-db 'lookup 'end-prev-year-desc)
gnc:get-end-prev-year)
(vector 'start-cur-fin-year
(gnc:reldate-string-db 'lookup 'start-cur-fin-year-string)
(gnc:reldate-string-db 'lookup 'start-cur-fin-year-desc)
gnc:get-start-cur-fin-year)
(vector 'start-prev-fin-year
(gnc:reldate-string-db 'lookup 'start-prev-fin-year-string)
(gnc:reldate-string-db 'lookup 'start-prev-fin-year-desc)
gnc:get-start-prev-fin-year)
(vector 'end-prev-fin-year
(gnc:reldate-string-db 'lookup 'end-prev-fin-year-string)
(gnc:reldate-string-db 'lookup 'end-prev-fin-year-desc)
gnc:get-end-prev-fin-year)
(vector 'start-this-month
(gnc:reldate-string-db 'lookup 'start-this-month-string)
(gnc:reldate-string-db 'lookup 'start-this-month-desc)
gnc:get-start-this-month)
(vector 'start-prev-month
(gnc:reldate-string-db 'lookup 'start-prev-month-string)
(gnc:reldate-string-db 'lookup 'start-prev-month-desc)
gnc:get-start-prev-month)
(vector 'end-prev-month
(gnc:reldate-string-db 'lookup 'end-prev-month-string)
(gnc:reldate-string-db 'lookup 'end-prev-month-desc)
gnc:get-end-prev-month)
(vector 'start-current-quarter
(gnc:reldate-string-db 'lookup 'start-current-quarter-string)
(gnc:reldate-string-db 'lookup 'start-current-quarter-desc)
gnc:get-start-current-quarter)
(vector 'start-prev-quarter
(gnc:reldate-string-db 'lookup 'start-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'start-prev-quarter-desc)
gnc:get-start-prev-quarter)
(vector 'end-prev-quarter
(gnc:reldate-string-db 'lookup 'end-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'end-prev-quarter-desc)
gnc:get-end-prev-quarter)
(vector 'today
(gnc:reldate-string-db 'lookup 'end-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'end-prev-quarter-desc)
gnc:get-today)
(vector 'one-month-ago
(gnc:reldate-string-db 'lookup 'one-month-ago-string)
(gnc:reldate-string-db 'lookup 'one-month-ago-desc)
gnc:get-one-month-ago)
(vector 'three-months-ago
(gnc:reldate-string-db 'lookup 'three-months-ago-string)
(gnc:reldate-string-db 'lookup 'three-months-ago-desc)
gnc:get-three-months-ago)
(vector 'six-months-ago
(gnc:reldate-string-db 'lookup 'six-months-ago-string)
(gnc:reldate-string-db 'lookup 'six-months-ago-desc)
gnc:get-three-months-ago)
(vector 'one-year-ago
(gnc:reldate-string-db 'lookup 'one-year-ago-string)
(gnc:reldate-string-db 'lookup 'one-year-ago-desc)
gnc:get-one-year-ago)))
(gnc:make-reldate-hash gnc:relative-date-hash gnc:relative-date-values)

298
src/scm/options.scm
View File

@ -39,18 +39,36 @@
;; on success, and (#f "failure-message") on failure. If #t,
;; the supplied value will be used by the gui to set the option.
value-validator
option-data
;; This function should return a list of all the strings in the
;; option other than the section, name, and documentation-string
;; that might be displayed to the user (and thus should be
;;; free-form storage depending on type.
option-data
;; If this is a "multiple choice" type of option,
;; this should be a vector of the following five functions
;; one taking no arguments giving the number of choices
;; one taking one argument, a non-negative integer, that
;; returns the scheme value (usually a symbol) matching the
;; nth choice
;;
;; one taking one argument, a non-negative integer,
;; that returns the string matching the nth choice
;;
;; the third takes one argument and returns the description
;; containing the nth choice
;;
;; the fourth giving a possible value and returning the index
;; if an option doesn't use these, this should just be a #f
option-data-fns
;; This function should return a list of all the strings
;; in the option other than the section, name, (define
;; (list-lookup list item) and documentation-string that
;; might be displayed to the user (and thus should be
;; translated).
strings-getter
;; This function will be called when the GUI representation
;; of the option is changed. This will normally occure before
;; of the option is changed. This will normally occur before
;; the setter is called, because setters are only called when
;; the user selects "OK" or "Apply". Therefore, this callback
;; shouldn't be used to make changes to the actual options
;; database.
;; the user selects "OK" or "Apply". Therefore, this
;; callback shouldn't be used to make changes to the actual
;; options database.
option-widget-changed-proc)
(let ((changed-callback #f))
(vector section
@ -58,14 +76,15 @@
sort-tag
type
documentation-string
getter
(lambda args
getter
(lambda args
(apply setter args)
(if changed-callback (changed-callback)))
default-getter
generate-restore-form
value-validator
option-data
option-data-fns
(lambda (callback) (set! changed-callback callback))
strings-getter
option-widget-changed-proc)))
@ -88,22 +107,50 @@
(vector-ref option 7))
(define (gnc:option-generate-restore-form option)
(vector-ref option 8))
(define (gnc:option-value-validator option)
(define (gnc:option-value-validator option)
(vector-ref option 9))
(define (gnc:option-data option)
(vector-ref option 10))
(vector-ref option 10))
(define (gnc:option-data-fns option)
(vector-ref option 11))
(define (gnc:option-set-changed-callback option callback)
(let ((cb-setter (vector-ref option 11)))
(let ((cb-setter (vector-ref option 12)))
(cb-setter callback)))
(define (gnc:option-strings-getter option)
(vector-ref option 12))
(define (gnc:option-widget-changed-proc option)
(vector-ref option 13))
(define (gnc:option-widget-changed-proc option)
(vector-ref option 14))
(define (gnc:option-value option)
(let ((getter (gnc:option-getter option)))
(getter)))
(define (gnc:option-index-get-name option index)
(let* ((option-data-fns (gnc:option-data-fns option))
(name-fn (vector-ref option-data-fns 2)))
(name-fn index)))
(define (gnc:option-index-get-description option index)
(let* ((option-data-fns (gnc:option-data-fns option))
(name-fn (vector-ref option-data-fns 3)))
(name-fn index)))
(define (gnc:option-index-get-value option index)
(let* ((option-data-fns (gnc:option-data-fns option))
(name-fn (vector-ref option-data-fns 1)))
(name-fn index)))
(define (gnc:option-value-get-index option value)
(let* ((option-data-fns (gnc:option-data-fns option))
(name-fn (vector-ref option-data-fns 4)))
(name-fn value)))
(define (gnc:option-number-of-indices option)
(let* ((option-data-fns (gnc:option-data-fns option))
(name-fn (vector-ref option-data-fns 0)))
(name-fn)))
(define (gnc:option-default-value option)
(let ((getter (gnc:option-default-getter option)))
(getter)))
@ -137,13 +184,14 @@
(lambda (x)
(cond ((string? x)(list #t x))
(else (list #f "string-option: not a string"))))
#f #f #f)))
#f #f #f #f)))
;;; font options store fonts as strings a la the X Logical
;;; Font Description. You should always provide a default
;;; value, as currently there seems to be no way to go from
;;; an actual font to a logical font description, and thus
;;; there is no way for the gui to pick a default value.
;; font options store fonts as strings a la the X Logical
;; Font Description. You should always provide a default
;; value, as currently there seems to be no way to go from
;; an actual font to a logical font description, and thus
;; there is no way for the gui to pick a default value.
(define (gnc:make-font-option
section
name
@ -153,15 +201,19 @@
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'font documentation-string
section
name
sort-tag
'font
documentation-string
(lambda () value)
(lambda (x) (set! value x))
(lambda () default-value)
(gnc:restore-form-generator value->string)
(gnc:restore-form-generator value->string)
(lambda (x)
(cond ((string? x)(list #t x))
(else (list #f "font-option: not a string"))))
#f #f #f)))
#f #f #f #f)))
;; currency options use a specialized widget for entering currencies
;; in the GUI implementation.
@ -169,29 +221,29 @@
section
name
sort-tag
documentation-string
default-value)
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'currency documentation-string
(lambda () value)
(lambda (x) (set! value x))
(lambda () default-value)
(gnc:restore-form-generator value->string)
(lambda (x)
(cond ((string? x)(list #t x))
(else (list #f "currency-option: not a currency code"))))
#f #f #f)))
documentation-string
default-value)
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'currency documentation-string
(lambda () value)
(lambda (x) (set! value x))
(lambda () default-value)
(gnc:restore-form-generator value->string)
(lambda (x)
(cond ((string? x)(list #t x))
(else (list #f "currency-option: not a currency code"))))
#f #f #f #f)))
(define (gnc:make-simple-boolean-option
section
name
sort-tag
documentation-string
default-value)
section
name
sort-tag
documentation-string
default-value)
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'boolean documentation-string
(lambda () value)
@ -200,9 +252,9 @@
(gnc:restore-form-generator value->string)
(lambda (x)
(if (boolean? x)
(list #t x)
(list #f "boolean-option: not a boolean")))
#f #f #f)))
(list #t x)
(list #f "boolean-option: not a boolean")))
#f #f #f #f)))
;; Complex boolean options are the same as simple boolean options,
@ -220,63 +272,114 @@
;; setter-function-called-cb is checked here.
(define (gnc:make-complex-boolean-option
section
name
sort-tag
documentation-string
default-value
setter-function-called-cb
option-widget-changed-cb)
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'boolean documentation-string
(lambda () value)
(if (procedure? setter-function-called-cb)
(lambda (x) (set! value x)
(setter-function-called-cb x))
(lambda (x) (set! value x)))
(lambda () default-value)
(gnc:restore-form-generator value->string)
(lambda (x)
(if (boolean? x)
(list #t x)
(list #f "boolean-option: not a boolean")))
#f #f (lambda (x) (option-widget-changed-cb x)))))
section
name
sort-tag
documentation-string
default-value
setter-function-called-cb
option-widget-changed-cb)
(let* ((value default-value)
(value->string (lambda () (gnc:value->string value))))
(gnc:make-option
section name sort-tag 'boolean documentation-string
(lambda () value)
(lambda (x) (set! value x)
(setter-function-called-cb x))
(lambda () default-value)
(gnc:restore-form-generator value->string)
(lambda (x)
(if (boolean? x)
(list #t x)
(list #f "boolean-option: not a boolean")))
#f #f #f (lambda (x) (option-widget-changed-cb x)))))
;; date options use the option-data as a boolean value. If true,
;; the gui should allow the time to be entered as well.
;; subtype should be on of 'relative 'absolute or 'both
;; relative-date-list should be the list of relative dates permitted
;; gnc:all-relative-dates contains a list of all relative dates.
(define (gnc:make-date-option
section
name
sort-tag
sort-tag
documentation-string
default-getter
show-time)
show-time
subtype
relative-date-list)
(define (date-legal date)
(and (pair? date) (exact? (car date)) (exact? (cdr date))))
(and (pair? date)
(or
(and (eq? 'relative (car date)) (symbol? (cdr date)))
(and (eq? 'absolute (car date))
(pair? (cdr date))
(exact? (cadr date))
(exact? (cddr date))))))
(define (list-lookup list item)
(cond
((null? list) #f)
((eq? item (car list)) 0)
(else (+ 1 (list-lookup (cdr list) item)))))
(let* ((value (default-getter))
(value->string (lambda ()
(string-append "'" (gnc:value->string value)))))
(gnc:make-option
section name sort-tag 'date documentation-string
(lambda () value)
(lambda ()
(if (eq? (car value) 'relative)
(vector 'relative (gnc:get-absolute-from-relative-date
(cdr value)) (cdr value))
(vector 'absolute (cdr value))))
(lambda (date)
(if (date-legal date)
(set! value date)
(gnc:error "Illegal date value set")))
(gnc:error "Illegal date value set")))
default-getter
(gnc:restore-form-generator value->string)
(lambda (date)
(if (date-legal date)
(list #t date)
(list #f "date-option: illegal date")))
show-time #f #f)))
(list #f "date-option: illegal date")))
(vector subtype show-time relative-date-list)
(vector (lambda () (length relative-date-list))
(lambda (x) (list-ref relative-date-list x))
(lambda (x) (gnc:get-relative-date-string
(list-ref relative-date-list x)))
(lambda (x) (gnc:get-relative-date-desc
(list-ref relative-date-list x)))
(lambda (x) (list-lookup relative-date-list x)))
#f
#f)))
;; account-list options use the option-data as a boolean value. If
(define (gnc:get-rd-option-data-subtype option-data)
(vector-ref option-data 0))
(define (gnc:get-rd-option-data-show-time option-data)
(vector-ref option-data 1))
(define (gnc:get-rd-option-data-rd-list option-data)
(vector-ref option-data 2))
(define (gnc:date-option-get-subtype option)
(if (eq? (gnc:option-type option) 'date)
(gnc:get-rd-option-data-subtype (gnc:option-data option))
(gnc:error "Not a date option")))
(define (gnc:date-option-show-time? option)
(if (eq? (gnc:option-type option) 'date)
(gnc:get-rd-option-data-show-time (gnc:option-data option))
(gnc:error "Not a date option")))
(define (gnc:date-option-absolute-time option-value)
(vector-ref option-value 1))
(define (gnc:date-option-value-type option-value)
(vector-ref option-value 0))
(define (gnc:date-option-relative-time option-value)
(vector-ref option-value 2))
;; account-list options use the option-data as a boolean value. If
;; true, the gui should allow the user to select multiple accounts.
;; Internally, values are always a list of guids. Externally, both
;; guids and account pointers may be used to set the value of the
@ -294,6 +397,7 @@
(if (string? item)
item
(gnc:account-get-guid item)))
(define (convert-to-account item)
(if (string? item)
(gnc:account-lookup item)
@ -322,7 +426,13 @@
(lambda () (map convert-to-account (default-getter)))
#f
validator
multiple-selection #f #f)))
multiple-selection #f #f #f)))
(define (gnc:multichoice-list-lookup list item )
(cond
((null? list) #f)
((eq? item (vector-ref (car list) 0)) 0)
(else (+ 1 (gnc:multichoice-list-lookup (cdr list) item)))))
;; multichoice options use the option-data as a list of vectors.
;; Each vector contains a permissible value (scheme symbol), a
@ -334,7 +444,6 @@
documentation-string
default-value
ok-values)
(define (multichoice-legal val p-vals)
(cond ((null? p-vals) #f)
((eq? val (vector-ref (car p-vals) 0)) #t)
@ -364,6 +473,12 @@
(list #t x)
(list #f "multichoice-option: illegal choice")))
ok-values
(vector (lambda () (length ok-values))
(lambda (x) (vector-ref (list-ref ok-values x) 0))
(lambda (x) (vector-ref (list-ref ok-values x) 1))
(lambda (x) (vector-ref (list-ref ok-values x) 2))
(lambda (x)
(gnc:multichoice-list-lookup ok-values x)))
(lambda () (multichoice-strings ok-values)) #f)))
;; list options use the option-data in the same way as multichoice
@ -411,7 +526,12 @@
(if (list-legal x)
(list #t x)
(list #f "list-option: illegal value")))
ok-values
ok-values
(vector (lambda () (length ok-values))
(lambda (x) (vector-ref (list-ref ok-values x) 0))
(lambda (x) (vector-ref (list-ref ok-values x) 1))
(lambda (x) (vector-ref (ref ok-values x) 2))
(lambda (x) (gnc:multichoice-list-lookup ok-values x)))
(lambda () (list-strings ok-values)) #f)))
;; number range options use the option-data as a list whose
@ -441,7 +561,7 @@
(list #t x))
(else (list #f "number-range-option: out of range"))))
(list lower-bound upper-bound num-decimals step-size)
#f #f)))
#f #f #f)))
(define (gnc:make-internal-option
section
@ -456,7 +576,7 @@
(lambda () default-value)
(gnc:restore-form-generator value->string)
(lambda (x) (list #t x))
#f #f #f)))
#f #f #f #f)))
;; Color options store rgba values in a list.
;; The option-data is a list, whose first element
@ -502,7 +622,7 @@
(gnc:restore-form-generator value->string)
validate-color
(list range use-alpha)
#f #f)))
#f #f #f)))
(define (gnc:color->html color range)
@ -568,7 +688,7 @@
new-option
(lambda () (option-changed section name)))))
; Call (thunk option) for each option in the database
; Call (thunk option) for each option in the database
(define (options-for-each thunk)
(define (section-for-each section-hash thunk)
(hash-for-each

37
src/scm/prefs.scm
View File

@ -1,4 +1,4 @@
;; Preferences...
;; Preferences
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
@ -189,7 +189,6 @@ the account instead of opening a register." #f))
(gnc:make-simple-boolean-option
"International" "Use 24-hour time format"
"c" "Use a 24 hour (instead of a 12 hour) time format." #f))
(gnc:register-configuration-option
(gnc:make-simple-boolean-option
"International" "Enable EURO support"
@ -198,7 +197,7 @@ the account instead of opening a register." #f))
(gnc:locale-default-currency))))
;; Register options
;;; Register options
(gnc:register-configuration-option
(gnc:make-multichoice-option
@ -216,7 +215,7 @@ the account instead of opening a register." #f))
"Double line mode with a multi-line cursor")
)))
(gnc:register-configuration-option
(gnc:register-configuration-option
(gnc:make-simple-boolean-option
"Register" "Auto-Raise Lists"
"b" "Automatically raise the list of accounts or actions during input." #t))
@ -362,7 +361,7 @@ the account instead of opening a register." #f))
#f))
;; Reconcile Options
;;; Reconcile Options
(gnc:register-configuration-option
(gnc:make-simple-boolean-option
@ -371,7 +370,7 @@ the account instead of opening a register." #f))
#t))
;; General Options
;;; General Options
(gnc:register-configuration-option
(gnc:make-simple-boolean-option
@ -402,7 +401,7 @@ the account instead of opening a register." #f))
(gnc:make-multichoice-option
"General" "Reversed-balance account types"
"d" "The types of accounts for which balances are sign-reversed"
'default
'default
(list #(default "Income & Expense" "Reverse Income and Expense Accounts")
#(credit "Credit Accounts" "Reverse Credit Card, Liability, Equity, and Income Accounts")
#(none "None" "Don't reverse any accounts"))))
@ -434,6 +433,13 @@ the account instead of opening a register." #f))
"Auto Decimal Places"
x))))
(gnc:register-configuration-option
(gnc:make-complex-boolean-option
"General" "complex boolean test"
"h" "some random text" #f
(lambda (x) (gnc:warn "setter cb function"))
(lambda (x) (gnc:warn "widget cb function"))))
(gnc:register-configuration-option
(gnc:make-number-range-option
"General" "Auto Decimal Places"
@ -446,19 +452,9 @@ the account instead of opening a register." #f))
1.0 ;; step size
))
;(gnc:register-configuration-option
; (gnc:make-number-range-option
; "General" "Default precision"
; "f" "Default number of decimal places to display"
; 15.0 ;; default
; 1.0 ;; lower bound
; 200.0 ;; upper bound
; 0.0 ;; number of decimals
; 1.0 ;; step size
; ))
;; Configuation variables
;;; Configuation variables
(define gnc:*arg-show-version*
(gnc:make-config-var
@ -539,6 +535,7 @@ the current value of the path."
(gnc:config-var-value-set! gnc:*load-path* #f current-load-path))
(define gnc:*doc-path*
(gnc:make-config-var
"A list of strings indicating where to look for html and parsed-html files
Each element must be a string representing a directory or a symbol
@ -553,8 +550,8 @@ the current value of the path."
'(default)))
;; Internal options -- Section names that start with "__" are not
;; displayed in option dialogs.
;;; Internal options -- Section names that start with "__" are not
;;; displayed in option dialogs.
(gnc:register-configuration-option
(gnc:make-internal-option

8
src/scm/report/account-summary.scm
View File

@ -37,8 +37,8 @@
(set-tm:sec bdtime 59)
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(cons (car (mktime bdtime)) 0)))
#f))
(cons 'absolute (cons (car (mktime bdtime)) 0))))
#f 'absolute #f))
;; account(s) to do report on
(gnc:register-accsum-option
@ -182,8 +182,8 @@
(define (accsum-renderer options)
(let ((acctcurrency "USD")
(acctname "")
(enddate (gnc:option-value
(gnc:lookup-option options "Report Options" "To")))
(enddate (gnc:date-option-absolute-time (gnc:option-value
(gnc:lookup-option options "Report Options" "To"))))
(accounts (gnc:option-value
(gnc:lookup-option options "Report Options" "Account")))
(dosubs (gnc:option-value

13
src/scm/report/average-balance.scm
View File

@ -46,8 +46,9 @@
(set-tm:hour bdtime 0)
(set-tm:mday bdtime 1)
(set-tm:mon bdtime 0)
(cons (car (mktime bdtime)) 0)))
#f))
(cons 'absolute (cons (car (mktime bdtime)) 0))))
#f
'absolute #f))
;; to-date
(gnc:register-runavg-option
@ -59,8 +60,8 @@
(set-tm:sec bdtime 59)
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(cons (car (mktime bdtime)) 0)))
#f))
(cons 'absolute (cons (car (mktime bdtime)) 0))))
#f 'absolute #f))
;; account(s) to do report on
@ -322,8 +323,8 @@
value)))))
(let ((acctcurrency "USD")
(acctname "")
(begindate (gov-fun "From"))
(enddate (gnc:timepair-end-day-time (gov-fun "To")))
(begindate (gnc:date-option-absolute-time (gov-fun "From")))
(enddate (gnc:timepair-end-day-time (gnc:date-option-absolute-time(gov-fun "To"))))
(stepsize (eval (gov-fun "Step Size")))
(plotstr (eval (gov-fun "Plot Type")))
(accounts (gov-fun "Account"))

14
src/scm/report/balance-and-pnl.scm
View File

@ -47,8 +47,8 @@
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
(cons 'absolute(cons time 0)))))
#f 'absolute #f))
gnc:*balsht-report-options*)
(define (pnl-options-generator)
@ -81,8 +81,8 @@
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
(cons 'absolute (cons time 0)))))
#f 'absolute #f))
gnc:*pnl-report-options*)
(define (render-level-2-account level-2-account l2-value)
@ -128,10 +128,10 @@
balance-sheet?)
(let* ((from-option (gnc:lookup-option options "Report Options" "From"))
(from-value (if from-option (gnc:option-value from-option) #f))
(from-value (if from-option (gnc:date-option-absolute-time (gnc:option-value from-option)) #f))
(to-value (gnc:timepair-end-day-time
(gnc:option-value
(gnc:lookup-option options "Report Options" "To")))))
(gnc:date-option-absolute-time (gnc:option-value
(gnc:lookup-option options "Report Options" "To"))))))
(define (handle-level-1-account account options)
(let ((type (gnc:account-type->symbol (gnc:account-get-type account))))

4
src/scm/report/folio.scm
View File

@ -22,8 +22,8 @@
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
(cons 'absolute (cons time 0)))))
#f 'absolute #f))
gnc:*folio-report-options*)

44
src/scm/report/hello-world.scm
View File

@ -69,8 +69,8 @@
(gnc:make-date-option
"Hello, World!" "Just a Date Option"
"d" "This is a date option"
(lambda () (cons (current-time) 0))
#f))
(lambda () (cons 'absolute (cons (current-time) 0)))
#f 'absolute #f ))
;; This is another date option, but the user can also select
;; the time.
@ -78,9 +78,21 @@
(gnc:make-date-option
"Hello, World!" "Time and Date Option"
"e" "This is a date option with time"
(lambda () (cons (current-time) 0))
#t))
(lambda () (cons 'absolute (cons (current-time) 0)))
#t 'absolute #f ))
(gnc:register-hello-world-option
(gnc:make-date-option
"Hello, World!" "Combo Date Option"
"y" "This is a combination date option"
(lambda () (cons 'relative 'start-cal-year))
#f 'both '(start-cal-year start-prev-year end-prev-year) ))
(gnc:register-hello-world-option
(gnc:make-date-option
"Hello, World!" "Relative Date Option"
"x" "This is a relative date option"
(lambda () (cons 'relative 'start-cal-year))
#f 'relative '(start-cal-year start-prev-year end-prev-year) ))
;; This is a number range option. The user can enter a number
;; between a lower and upper bound given below. There are also
;; arrows the user can click to go up or down, the amount changed
@ -223,11 +235,14 @@
;; The first thing we do is make local variables for all the specific
;; options in the set of options given to the function. This set will
;; be generated by the options generator above.
(let ((bool-val (op-value "Hello, World!" "Boolean Option"))
(let ((dummy (display options))
(bool-val (op-value "Hello, World!" "Boolean Option"))
(mult-val (op-value "Hello, World!" "Multi Choice Option"))
(string-val (op-value "Hello, World!" "String Option"))
(date-val (op-value "Hello, World!" "Just a Date Option"))
(date2-val (op-value "Hello, World!" "Time and Date Option"))
(date-val (gnc:date-option-absolute-time (op-value "Hello, World!" "Just a Date Option")))
(date2-val (gnc:date-option-absolute-time (op-value "Hello, World!" "Time and Date Option")))
(rel-date-val (gnc:date-option-absolute-time (op-value "Hello, World!" "Relative Date Option")))
(combo-date-val (gnc:date-option-absolute-time (op-value "Hello, World!" "Combo Date Option")))
(num-val (op-value "Hello, World!" "Number Option"))
(color-op (get-op "Hello, World!" "Background Color"))
(accounts (op-value "Hello Again" "An account list option"))
@ -236,20 +251,23 @@
;; Crash if asked to.
(if crash-val (string-length #f));; string-length needs a string
(let ((time-string (strftime "%X" (localtime (current-time))))
(date-string (strftime "%x" (localtime (car date-val))))
(date-string2 (strftime "%x %X" (localtime (car date2-val)))))
(date-string2 (strftime "%x %X" (localtime (car date2-val))))
(rel-date-string (strftime "%x" (localtime (car rel-date-val))))
(combo-date-string (strftime "%x" (localtime (car combo-date-val)))))
;; Here's where we generate the html. A real report would need
;; much more code and involve many more utility functions. See
;; the other reports for details. Note that you can used nested
;; lists here, as well as arbitrary functions.
(list
(html-start-document-color (gnc:color-option->html color-op))
;; Here we get the title using the string database and 'lookup.
"<h2>" (string-db 'lookup 'title) "</h2>"
"<h2>Hello World </h2>"
;; Here we user our paragraph helper
(make-para 'para-1
@ -275,6 +293,10 @@
(make-para 'date-string (bold date-string))
(make-para 'time-date-string (bold date-string2))
(make-para 'rel-date-string (bold rel-date-string))
(make-para 'combo-date-string (bold combo-date-string))
(make-para 'num-string-1 (bold (number->string num-val)))
@ -335,6 +357,8 @@
(string-db 'store 'string-string "The string option is %s.")
(string-db 'store 'date-string "The date option is %s.")
(string-db 'store 'time-date-string "The date and time option is %s.")
(string-db 'store 'rel-date-string "The relative date option is %s.")
(string-db 'store 'combo-date-string "The combination date option is %s.")
(string-db 'store 'num-string-1 "The number option is %s.")
(string-db 'store 'num-string-2
"The number option formatted as currency is %s.")

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

@ -406,6 +406,8 @@
(gnc:register-option gnc:*transaction-report-options* new-option))
;; from date
;; hack alert - could somebody set this to an appropriate date?
(display "Got here 1")
(gnc:register-trep-option
(gnc:make-date-option
"Report Options" "From"
@ -418,15 +420,16 @@
(set-tm:mday bdtime 1)
(set-tm:mon bdtime 0)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
(cons 'absolute (cons time 0)))))
#f 'absolute #f))
(display "Got here 1a")
;; to-date
(gnc:register-trep-option
(gnc:make-date-option
"Report Options" "To"
"b" "Report items up to and including this date"
(lambda () (cons (current-time) 0))
#f))
(lambda () (cons 'absolute (cons (current-time) 0)))
#f 'absolute #f))
;; account to do report on
(gnc:register-trep-option
@ -444,6 +447,7 @@
(else ()))))
#f #t))
(display "got here 2")
(gnc:register-trep-option
(gnc:make-multichoice-option
"Report Options" "Style"
@ -518,7 +522,7 @@
(list
#(ascend "Ascending" "smallest to largest, earliest to latest")
#(descend "Descending" "largest to smallest, latest to earliest"))))
(display "Got here 3")
(gnc:register-trep-option
(gnc:make-multichoice-option
"Sorting" "Secondary Key"
@ -587,13 +591,15 @@
(gnc:options-set-default-section gnc:*transaction-report-options*
"Report Options")
(display "tr-report-options =")
(display gnc:*transaction-report-options*)
(display "\n")
gnc:*transaction-report-options*)
(define (gnc:trep-renderer options)
(let* ((begindate (gnc:lookup-option options "Report Options" "From"))
(enddate (gnc:lookup-option options "Report Options" "To"))
(let* ((begindate (gnc:date-option-absolute-time (gnc:lookup-option options "Report Options" "From")))
(enddate (gnc:date-option-absolute-time (gnc:lookup-option options "Report Options" "To")))
(tr-report-account-op (gnc:lookup-option
options "Report Options" "Account"))
(tr-report-primary-key-op (gnc:lookup-option options