From 23ffb366f2810875eff6d9365bb897e22d20854f Mon Sep 17 00:00:00 2001 From: Dave Peticolas Date: Wed, 30 Aug 2000 07:46:19 +0000 Subject: [PATCH] Robert Graham Merkel's relative date option patch. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2729 57a11ea4-9604-0410-9ed3-97b8803252fd --- ChangeLog | 34 ++ make-gnucash-patch.in | 1 + src/gnome/dialog-options.c | 426 +++++++++++++++++++++++--- src/scm/date-utilities.scm | 382 ++++++++++++++++++++++- src/scm/options.scm | 298 ++++++++++++------ src/scm/prefs.scm | 37 +-- src/scm/report/account-summary.scm | 8 +- src/scm/report/average-balance.scm | 13 +- src/scm/report/balance-and-pnl.scm | 14 +- src/scm/report/folio.scm | 4 +- src/scm/report/hello-world.scm | 44 ++- src/scm/report/transaction-report.scm | 22 +- 12 files changed, 1085 insertions(+), 198 deletions(-) diff --git a/ChangeLog b/ChangeLog index 74ef669091..da4523b1e2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,37 @@ +2000-08-30 Robert Graham Merkel + + * 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 * src/engine/Group.c (xaccGetAccountRoot): remove unnecessary diff --git a/make-gnucash-patch.in b/make-gnucash-patch.in index c58c3b627f..200424c605 100644 --- a/make-gnucash-patch.in +++ b/make-gnucash-patch.in @@ -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 diff --git a/src/gnome/dialog-options.c b/src/gnome/dialog-options.c index 5adf5c5821..8dec4ca8a2 100644 --- a/src/gnome/dialog-options.c +++ b/src/gnome/dialog-options.c @@ -21,7 +21,6 @@ \********************************************************************/ #include - #include #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) { diff --git a/src/scm/date-utilities.scm b/src/scm/date-utilities.scm index 9d2eae4357..83f60482ef 100644 --- a/src/scm/date-utilities.scm +++ b/src/scm/date-utilities.scm @@ -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) \ No newline at end of file diff --git a/src/scm/options.scm b/src/scm/options.scm index ea325a4055..28aaf91505 100644 --- a/src/scm/options.scm +++ b/src/scm/options.scm @@ -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 diff --git a/src/scm/prefs.scm b/src/scm/prefs.scm index cccc359d9d..14fdaf7004 100644 --- a/src/scm/prefs.scm +++ b/src/scm/prefs.scm @@ -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 diff --git a/src/scm/report/account-summary.scm b/src/scm/report/account-summary.scm index 4cc226aa3d..2e1bdcb980 100644 --- a/src/scm/report/account-summary.scm +++ b/src/scm/report/account-summary.scm @@ -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 diff --git a/src/scm/report/average-balance.scm b/src/scm/report/average-balance.scm index b0e728d415..adf84f61b0 100644 --- a/src/scm/report/average-balance.scm +++ b/src/scm/report/average-balance.scm @@ -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")) diff --git a/src/scm/report/balance-and-pnl.scm b/src/scm/report/balance-and-pnl.scm index 62cee70e7f..54bd5b0f14 100644 --- a/src/scm/report/balance-and-pnl.scm +++ b/src/scm/report/balance-and-pnl.scm @@ -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)))) diff --git a/src/scm/report/folio.scm b/src/scm/report/folio.scm index afe7ac192f..85e834f6c6 100644 --- a/src/scm/report/folio.scm +++ b/src/scm/report/folio.scm @@ -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*) diff --git a/src/scm/report/hello-world.scm b/src/scm/report/hello-world.scm index 0efe7b5e0e..aac6b3a57f 100644 --- a/src/scm/report/hello-world.scm +++ b/src/scm/report/hello-world.scm @@ -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. - "

" (string-db 'lookup 'title) "

" + "

Hello World

" ;; 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.") diff --git a/src/scm/report/transaction-report.scm b/src/scm/report/transaction-report.scm index 331b3fba05..8ecf318016 100644 --- a/src/scm/report/transaction-report.scm +++ b/src/scm/report/transaction-report.scm @@ -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