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

* src/scm/report/report-list.scm: load tax report if possibly in

Browse Source 
US locale.

	* src/scm/report/taxtxf.scm: work on tax report (unfinished)

	* src/scm/report/hello-world.scm: use new html format functions.
	Add scheme reference.

	* src/gnome/dialog-fincalc.c (gnc_ui_fincalc_dialog_create): hide
	schedule button. Use 'lookup_widget'.

	* src/gnome/gnc-html.c (gnc_html_export): handle cancelling

	* src/scm/html-style-info.scm: remove cruft


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3761 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2001-03-08 11:24:36 +00:00
parent 2921fad829
commit cad90da64b
11 changed files with 503 additions and 458 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
ChangeLog
View File

@ -1,10 +1,26 @@
<<<<<<< ChangeLog 2001-03-08 Dave Peticolas <dave@krondo.com>
* src/scm/report/report-list.scm: load tax report if possibly in
US locale.
* src/scm/report/taxtxf.scm: work on tax report (unfinished)
2001-03-07 Dave Peticolas <dave@krondo.com>
* src/scm/report/hello-world.scm: use new html format functions.
Add scheme reference.
* src/gnome/dialog-fincalc.c (gnc_ui_fincalc_dialog_create): hide
schedule button. Use 'lookup_widget'.
* src/gnome/gnc-html.c (gnc_html_export): handle cancelling
* src/scm/html-style-info.scm: remove cruft
2001-03-08 Robert Graham Merkel <rgmerk@mira.net> 2001-03-08 Robert Graham Merkel <rgmerk@mira.net>
* src/scm/report/transaction-report.scm: More colourization. * src/scm/report/transaction-report.scm: More colourization.
=======
2001-03-07 Bill Gribble <grib@billgribble.com> 2001-03-07 Bill Gribble <grib@billgribble.com>
* summary: separate the HTML and HTTP processing functions into * summary: separate the HTML and HTTP processing functions into
@ -42,7 +58,6 @@
(html-markup/format "%a %a %a %a" 1 2 3 4) does what you'd expect, (html-markup/format "%a %a %a %a" 1 2 3 4) does what you'd expect,
even if the non-format args are html-markup objects. even if the non-format args are html-markup objects.
>>>>>>> 1.251
2001-03-07 Dave Peticolas <dave@krondo.com> 2001-03-07 Dave Peticolas <dave@krondo.com>
* src/gnome/top-level.c (gnc_ui_check_events): add timeout * src/gnome/top-level.c (gnc_ui_check_events): add timeout

47
src/gnome/dialog-fincalc.c
View File

@ -31,6 +31,7 @@
#include "finproto.h" #include "finproto.h"
#include "finvar.h" #include "finvar.h"
#include "glade-gnc-dialogs.h" #include "glade-gnc-dialogs.h"
#include "glade-support.h"
#include "gnc-amount-edit.h" #include "gnc-amount-edit.h"
#include "gnc-commodity.h" #include "gnc-commodity.h"
#include "gnc-component-manager.h" #include "gnc-component-manager.h"
@ -528,7 +529,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PAYMENT_PERIODS] = edit; fcd->amounts[PAYMENT_PERIODS] = edit;
gtk_widget_show (edit); gtk_widget_show (edit);
hbox = gtk_object_get_data(fcdo, "payment_periods_hbox"); hbox = lookup_widget (fcd->dialog, "payment_periods_hbox");
gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0); gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry; entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -544,7 +545,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[INTEREST_RATE] = edit; fcd->amounts[INTEREST_RATE] = edit;
gtk_widget_show (edit); gtk_widget_show (edit);
hbox = gtk_object_get_data(fcdo, "interest_rate_hbox"); hbox = lookup_widget (fcd->dialog, "interest_rate_hbox");
gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0); gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry; entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -562,7 +563,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PRESENT_VALUE] = edit; fcd->amounts[PRESENT_VALUE] = edit;
gtk_widget_show (edit); gtk_widget_show (edit);
hbox = gtk_object_get_data(fcdo, "present_value_hbox"); hbox = lookup_widget (fcd->dialog, "present_value_hbox");
gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0); gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry; entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -578,7 +579,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PERIODIC_PAYMENT] = edit; fcd->amounts[PERIODIC_PAYMENT] = edit;
gtk_widget_show (edit); gtk_widget_show (edit);
hbox = gtk_object_get_data(fcdo, "periodic_payment_hbox"); hbox = lookup_widget (fcd->dialog, "periodic_payment_hbox");
gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0); gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry; entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -594,7 +595,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[FUTURE_VALUE] = edit; fcd->amounts[FUTURE_VALUE] = edit;
gtk_widget_show (edit); gtk_widget_show (edit);
hbox = gtk_object_get_data(fcdo, "future_value_hbox"); hbox = lookup_widget (fcd->dialog, "future_value_hbox");
gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0); gtk_box_pack_start (GTK_BOX (hbox), edit, TRUE, TRUE, 0);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry; entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -602,83 +603,87 @@ gnc_ui_fincalc_dialog_create(void)
GTK_SIGNAL_FUNC(fincalc_entry_changed), fcd); GTK_SIGNAL_FUNC(fincalc_entry_changed), fcd);
button = gtk_object_get_data(fcdo, "payment_periods_calc_button"); button = lookup_widget (fcd->dialog, "payment_periods_calc_button");
fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button); fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button);
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(calc_payment_periods), fcd); GTK_SIGNAL_FUNC(calc_payment_periods), fcd);
button = gtk_object_get_data(fcdo, "interest_rate_calc_button"); button = lookup_widget (fcd->dialog, "interest_rate_calc_button");
fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button); fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button);
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(calc_interest_rate), fcd); GTK_SIGNAL_FUNC(calc_interest_rate), fcd);
button = gtk_object_get_data(fcdo, "present_value_calc_button"); button = lookup_widget (fcd->dialog, "present_value_calc_button");
fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button); fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button);
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(calc_present_value), fcd); GTK_SIGNAL_FUNC(calc_present_value), fcd);
button = gtk_object_get_data(fcdo, "periodic_payment_calc_button"); button = lookup_widget (fcd->dialog, "periodic_payment_calc_button");
fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button); fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button);
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(calc_periodic_payment), fcd); GTK_SIGNAL_FUNC(calc_periodic_payment), fcd);
button = gtk_object_get_data(fcdo, "future_value_calc_button"); button = lookup_widget (fcd->dialog, "future_value_calc_button");
fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button); fcd->calc_buttons = g_list_prepend(fcd->calc_buttons, button);
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(calc_future_value), fcd); GTK_SIGNAL_FUNC(calc_future_value), fcd);
button = gtk_object_get_data(fcdo, "payment_periods_clear_button"); button = lookup_widget (fcd->dialog, "payment_periods_clear_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(fincalc_entry_clear_clicked), GTK_SIGNAL_FUNC(fincalc_entry_clear_clicked),
fcd->amounts[PAYMENT_PERIODS]); fcd->amounts[PAYMENT_PERIODS]);
button = gtk_object_get_data(fcdo, "interest_rate_clear_button"); button = lookup_widget (fcd->dialog, "interest_rate_clear_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked), GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked),
fcd->amounts[INTEREST_RATE]); fcd->amounts[INTEREST_RATE]);
button = gtk_object_get_data(fcdo, "present_value_clear_button"); button = lookup_widget (fcd->dialog, "present_value_clear_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked), GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked),
fcd->amounts[PRESENT_VALUE]); fcd->amounts[PRESENT_VALUE]);
button = gtk_object_get_data(fcdo, "periodic_payment_clear_button"); button = lookup_widget (fcd->dialog, "periodic_payment_clear_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked), GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked),
fcd->amounts[PERIODIC_PAYMENT]); fcd->amounts[PERIODIC_PAYMENT]);
button = gtk_object_get_data(fcdo, "future_value_clear_button"); button = lookup_widget (fcd->dialog, "future_value_clear_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked), GTK_SIGNAL_FUNC(fincalc_amount_clear_clicked),
fcd->amounts[FUTURE_VALUE]); fcd->amounts[FUTURE_VALUE]);
menu = gtk_object_get_data(fcdo, "compounding_menu"); menu = lookup_widget (fcd->dialog, "compounding_menu");
fcd->compounding_menu = menu; fcd->compounding_menu = menu;
gnc_option_menu_init(menu); gnc_option_menu_init(menu);
menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu)); menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu));
gtk_container_forall(GTK_CONTAINER(menu), connect_fincalc_menu_item, fcd); gtk_container_forall(GTK_CONTAINER(menu), connect_fincalc_menu_item, fcd);
menu = gtk_object_get_data(fcdo, "payment_menu"); menu = lookup_widget (fcd->dialog, "payment_menu");
fcd->payment_menu = menu; fcd->payment_menu = menu;
gnc_option_menu_init(menu); gnc_option_menu_init(menu);
menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu)); menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu));
gtk_container_forall(GTK_CONTAINER(menu), connect_fincalc_menu_item, fcd); gtk_container_forall(GTK_CONTAINER(menu), connect_fincalc_menu_item, fcd);
button = gtk_object_get_data(fcdo, "period_payment_radio"); button = lookup_widget (fcd->dialog, "period_payment_radio");
fcd->end_of_period_radio = button; fcd->end_of_period_radio = button;
gtk_signal_connect(GTK_OBJECT(button), "toggled", gtk_signal_connect(GTK_OBJECT(button), "toggled",
GTK_SIGNAL_FUNC(fincalc_radio_toggled), fcd); GTK_SIGNAL_FUNC(fincalc_radio_toggled), fcd);
button = gtk_object_get_data(fcdo, "discrete_compounding_radio"); button = lookup_widget (fcd->dialog, "discrete_compounding_radio");
fcd->discrete_compounding_radio = button; fcd->discrete_compounding_radio = button;
gtk_signal_connect(GTK_OBJECT(button), "toggled", gtk_signal_connect(GTK_OBJECT(button), "toggled",
GTK_SIGNAL_FUNC(fincalc_radio_toggled), fcd); GTK_SIGNAL_FUNC(fincalc_radio_toggled), fcd);
button = gtk_object_get_data(fcdo, "close_button"); button = lookup_widget (fcd->dialog, "close_button");
gtk_signal_connect(GTK_OBJECT(button), "clicked", gtk_signal_connect(GTK_OBJECT(button), "clicked",
GTK_SIGNAL_FUNC(close_button_clicked), fcd); GTK_SIGNAL_FUNC(close_button_clicked), fcd);
fcd->payment_total_label = gtk_object_get_data (fcdo, "payment_total_label"); fcd->payment_total_label = lookup_widget (fcd->dialog,
"payment_total_label");
button = lookup_widget (fcd->dialog, "schedule_button");
gtk_widget_hide (button);
init_fi(fcd); init_fi(fcd);

9
src/gnome/gnc-html.c
View File

@ -244,7 +244,6 @@ extract_base_name(URLType type, const gchar * path) {
regex_t compiled_h, compiled_o; regex_t compiled_h, compiled_o;
regmatch_t match[4]; regmatch_t match[4];
char * machine=NULL, * location = NULL, * base=NULL; char * machine=NULL, * location = NULL, * base=NULL;
int free_location = 0;
regcomp(&compiled_h, http_rexp, REG_EXTENDED); regcomp(&compiled_h, http_rexp, REG_EXTENDED);
regcomp(&compiled_o, other_rexp, REG_EXTENDED); regcomp(&compiled_o, other_rexp, REG_EXTENDED);
@ -265,7 +264,6 @@ extract_base_name(URLType type, const gchar * path) {
location = g_new0(char, match[2].rm_eo - match[2].rm_so + 1); location = g_new0(char, match[2].rm_eo - match[2].rm_so + 1);
strncpy(location, path+match[2].rm_so, strncpy(location, path+match[2].rm_so,
match[2].rm_eo - match[2].rm_so); match[2].rm_eo - match[2].rm_so);
free_location = 1;
} }
} }
break; break;
@ -286,9 +284,7 @@ extract_base_name(URLType type, const gchar * path) {
regfree(&compiled_h); regfree(&compiled_h);
regfree(&compiled_o); regfree(&compiled_o);
if(free_location) { g_free(location);
g_free(location);
}
if(machine) { if(machine) {
strcat(machine, "/"); strcat(machine, "/");
@ -1100,6 +1096,9 @@ gnc_html_export(gnc_html * html) {
FILE *fh; FILE *fh;
filepath = fileBox (_("Save HTML To File"), NULL, NULL); filepath = fileBox (_("Save HTML To File"), NULL, NULL);
if (!filepath)
return;
PINFO (" user selected file=%s\n", filepath); PINFO (" user selected file=%s\n", filepath);
fh = fopen (filepath, "w"); fh = fopen (filepath, "w");
if (NULL == fh) { if (NULL == fh) {

158
src/scm/command-line.scm
View File

@ -115,86 +115,78 @@
#f #f
(N_ "Enable debugging mode")) (N_ "Enable debugging mode"))
(cons (list "loglevel"
"loglevel" 'integer
(list 'integer (lambda (val)
(lambda (val) (gnc:config-var-value-set! gnc:*loglevel* #f val))
(gnc:config-var-value-set! gnc:*loglevel* #f val)) "LOGLEVEL"
"LOGLEVEL" (N_ "Set the logging level from 0 (least) to 6 (most)"))
(N_ "Set the logging level from 0 (least) to 6 (most)")))
(cons (list "nofile"
"nofile" 'boolean
(list 'boolean (lambda (val)
(lambda (val) (gnc:config-var-value-set! gnc:*arg-no-file* #f val))
(gnc:config-var-value-set! gnc:*arg-no-file* #f val)) #f
#f (N_ "Do not load the last file opened"))
(N_ "Do not load the last file opened")))
(cons (list "config-dir"
"config-dir" 'string
(list 'string (lambda (val)
(lambda (val) (gnc:config-var-value-set! gnc:*config-dir* #f val))
(gnc:config-var-value-set! gnc:*config-dir* #f val)) "CONFIGDIR"
"CONFIGDIR" (N_ "Set configuration directory"))
(N_ "Set configuration directory")))
(cons (list "share-dir"
"share-dir" 'string
(list 'string (lambda (val)
(lambda (val) (gnc:config-var-value-set! gnc:*share-dir* #f val))
(gnc:config-var-value-set! gnc:*share-dir* #f val)) "SHAREDIR"
"SHAREDIR" (N_ "Set shared directory"))
(N_ "Set shared directory")))
(cons (list "load-path"
"load-path" 'string
(list 'string (lambda (val)
(lambda (val) (let ((path-list
(let ((path-list (call-with-input-string val (lambda (port) (read port)))))
(call-with-input-string val (lambda (port) (read port))))) (if (list? path-list)
(if (list? path-list) (gnc:config-var-value-set! gnc:*load-path* #f path-list)
(gnc:config-var-value-set! gnc:*load-path* #f path-list) (begin
(begin (gnc:error "non-list given for --load-path: " val)
(gnc:error "non-list given for --load-path: " val) (gnc:shutdown 1)))))
(gnc:shutdown 1))))) "LOADPATH"
"LOADPATH" (N_ "Set the search path for .scm files."))
(N_ "Set the search path for .scm files.")))
(cons (list "doc-path"
"doc-path" 'string
(list 'string (lambda (val)
(lambda (val) (gnc:debug "parsing --doc-path " val)
(gnc:debug "parsing --doc-path " val) (let ((path-list
(let ((path-list (call-with-input-string val (lambda (port) (read port)))))
(call-with-input-string val (lambda (port) (read port))))) (if (list? path-list)
(if (list? path-list) (gnc:config-var-value-set! gnc:*doc-path* #f path-list)
(gnc:config-var-value-set! gnc:*doc-path* #f path-list) (begin
(begin (gnc:error "non-list given for --doc-path: " val)
(gnc:error "non-list given for --doc-path: " val) (gnc:shutdown 1)))))
(gnc:shutdown 1))))) "DOCPATH"
"DOCPATH" (N_ "Set the search path for documentation files"))
(N_ "Set the search path for documentation files")))
(cons (list "evaluate"
"evaluate" 'string
(list 'string (lambda (val)
(lambda (val) (set! gnc:*batch-mode-things-to-do*
(set! gnc:*batch-mode-things-to-do* (cons val gnc:*batch-mode-things-to-do*)))
(cons val gnc:*batch-mode-things-to-do*))) "COMMAND"
"COMMAND" (N_ "Evaluate the guile command"))
(N_ "Evaluate the guile command")))
;; Given a string, --load will load the indicated file, if possible. ;; Given a string, --load will load the indicated file, if possible.
(cons (list "load"
"load" 'string
(list 'string (lambda (val)
(lambda (val) (set! gnc:*batch-mode-things-to-do*
(set! gnc:*batch-mode-things-to-do* (cons (lambda () (load val))
(cons (lambda () (load val)) gnc:*batch-mode-things-to-do*)))
gnc:*batch-mode-things-to-do*))) "FILE"
"FILE" (N_ "Load the given .scm file"))
(N_ "Load the given .scm file")))
; (cons "add-price-quotes" ; (cons "add-price-quotes"
; (cons 'string ; (cons 'string
@ -216,19 +208,17 @@
; ;
; gnc:*batch-mode-things-to-do*))))) ; gnc:*batch-mode-things-to-do*)))))
(cons (list "load-user-config"
"load-user-config" 'boolean
(list 'boolean gnc:load-user-config-if-needed
gnc:load-user-config-if-needed #f
#f (N_ "Load the user configuation"))
(N_ "Load the user configuation")))
(cons (list "load-system-config"
"load-system-config" 'boolean
(list 'boolean gnc:load-system-config-if-needed
gnc:load-system-config-if-needed #f
#f (N_ "Load the system configuation"))))
(N_ "Load the system configuation")))))
(define (gnc:cmd-line-get-boolean-arg args) (define (gnc:cmd-line-get-boolean-arg args)
;; --arg means #t ;; --arg means #t

8
src/scm/html-style-info.scm
View File

@ -278,7 +278,6 @@
(define (gnc:default-html-gnc-numeric-renderer datum params) (define (gnc:default-html-gnc-numeric-renderer datum params)
(gnc:amount->string-helper datum (gnc:default-print-info #f))) (gnc:amount->string-helper datum (gnc:default-print-info #f)))
; (sprintf #f "%.2f" (gnc:numeric-to-double datum)))
(define (gnc:default-html-gnc-monetary-renderer datum params) (define (gnc:default-html-gnc-monetary-renderer datum params)
(gnc:amount->string-helper (gnc:amount->string-helper
@ -290,13 +289,6 @@
(gnc:double-to-gnc-numeric datum 100 GNC-RND-ROUND) (gnc:double-to-gnc-numeric datum 100 GNC-RND-ROUND)
(gnc:default-print-info #f))) (gnc:default-print-info #f)))
; (gnc:print-double-amount datum))
; (sprintf #f "%.2f" datum))
; (format #f "~,2f" datum))
; "(NUM)")
; (sprintf 20 "%.2f" datum))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-style-table> class ;; <html-style-table> class

6
src/scm/report-html.txt
View File

@ -403,11 +403,7 @@ We have three different kinds of style control information available:
(gnc:html-document-render ssdoc))) (gnc:html-document-render ssdoc)))
(gnc:define-html-style-sheet (gnc:define-html-style-sheet
'version 1.0 'version 1
'name "Sample Style Sheet" 'name "Sample Style Sheet"
'renderer sample-renderer 'renderer sample-renderer
'options sample-options)) 'options sample-options))

4
src/scm/report/Makefile.am
View File

@ -9,7 +9,11 @@ gncscm_DATA = \
report-list.scm \ report-list.scm \
stylesheet-plain.scm \ stylesheet-plain.scm \
stylesheet-fancy.scm \ stylesheet-fancy.scm \
taxtxf.scm \
txf-export.scm \
txf-export-help.scm \
transaction-report.scm transaction-report.scm
EXTRA_DIST = \ EXTRA_DIST = \
.cvsignore \ .cvsignore \
${gncscm_DATA} ${gncscm_DATA}

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

@ -300,7 +300,7 @@ option like this.")
;; current locale, then the translation is returned, ;; current locale, then the translation is returned,
;; otherwise the original string is returned. ;; otherwise the original string is returned.
(gnc:html-document-set-title! document (_ "Hello, World")) (gnc:html-document-set-title! document (_ "Hello, World"))
;; we make a "text object" to add a bunch of text to. ;; we make a "text object" to add a bunch of text to.
;; the function gnc:make-html-text can take any number of ;; the function gnc:make-html-text can take any number of
;; arguments. The gnc:html-markup functions are designed ;; arguments. The gnc:html-markup functions are designed
@ -308,67 +308,81 @@ option like this.")
;; the appearance of the report from the Gnucash UI; you ;; the appearance of the report from the Gnucash UI; you
;; should use the HTML markup functions whenever possible ;; should use the HTML markup functions whenever possible
;; rather than including literal HTML in your report. ;; rather than including literal HTML in your report.
(gnc:html-document-add-object! (gnc:html-document-add-object!
document document
(gnc:make-html-text (gnc:make-html-text
(gnc:html-markup-p (gnc:html-markup-p
(_ "This is a sample GnuCash report. \ (gnc:html-markup/format
See the guile (scheme) source code in ") (_ "This is a sample GnuCash report. \
(gnc:html-markup-tt See the guile (scheme) source code in %s \
gnc:_share-dir-default_ "/gnucash/scm/report") for details on writing your own reports, \
(_ "for details on writing your own reports, \ or extending existing reports.")
or extending existing reports.")) (gnc:html-markup-tt
(gnc:html-markup-p gnc:_share-dir-default_ "/gnucash/scm/report")))
(_ "For help on writing reports, or to contribute your brand \
new, totally cool report, consult the mailing list ") (gnc:html-markup-p
(gnc:html-markup-anchor (gnc:html-markup/format
"mailto:gnucash-devel@gnucash.org" (_ "For help on writing reports, or to contribute your brand \
(gnc:html-markup-tt "gnucash-devel@gnucash.org")) ". " new, totally cool report, consult the mailing list %s.")
(_ "For details on subscribing to that list, see ")
(gnc:html-markup-anchor (gnc:html-markup-anchor
"mailto:gnucash-devel@gnucash.org"
(gnc:html-markup-tt "gnucash-devel@gnucash.org")))
(gnc:html-markup/format
(_ "For details on subscribing to that list, see %s.")
(gnc:html-markup-anchor
"http://www.gnucash.org" "http://www.gnucash.org"
(gnc:html-markup-tt (gnc:html-markup-tt
"www.gnucash.org")) ".") "www.gnucash.org")))
(gnc:html-markup/format
(gnc:html-markup-p (_ "You can learn more about writing scheme using this %s.")
(_ "The current time is ") (gnc:html-markup-anchor
(gnc:html-markup-b time-string) ".") "http://www.scheme.com/tspl2d/index.html"
(_ "online book"))))
(gnc:html-markup-p
(_ "The boolean option is ") (gnc:html-markup-p
(gnc:html-markup-b (if bool-val (_ "true") (_ "false"))) ".") (gnc:html-markup/format
(_ "The current time is %s.")
(gnc:html-markup-p (gnc:html-markup-b time-string)))
(_ "The multi-choice option is ")
(gnc:html-markup-b (symbol->string mult-val)) ".") (gnc:html-markup-p
(gnc:html-markup/format
(gnc:html-markup-p (_ "The boolean option is %s.")
(_ "The string option is ") (gnc:html-markup-b (if bool-val (_ "true") (_ "false")))))
(gnc:html-markup-b string-val) ".")
(gnc:html-markup-p
(gnc:html-markup-p (gnc:html-markup/format
(_ "The date option is ") (_ "The multi-choice option is %s.")
(gnc:html-markup-b date-string) ".") (gnc:html-markup-b (symbol->string mult-val))))
(gnc:html-markup-p (gnc:html-markup-p
(_ "The date and time option is ") (gnc:html-markup/format
(gnc:html-markup-b date-string2) ".") (_ "The string option is %s.")
(gnc:html-markup-b string-val)))
(gnc:html-markup-p
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The date option is %s.")
(gnc:html-markup-b date-string)))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The date and time option is %s.")
(gnc:html-markup-b date-string2)))
(gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
(_ "The relative date option is %a.") (_ "The relative date option is %s.")
(gnc:html-markup-b rel-date-string))) (gnc:html-markup-b rel-date-string)))
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
(_ "The combination date option is %a.") (_ "The combination date option is %s.")
(gnc:html-markup-b combo-date-string))) (gnc:html-markup-b combo-date-string)))
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
(_ "The number option is %a.") (_ "The number option is %s.")
(gnc:html-markup-b (number->string num-val)))) (gnc:html-markup-b (number->string num-val))))
;; Here we print the value of the number option formatted as ;; Here we print the value of the number option formatted as
@ -379,10 +393,10 @@ new, totally cool report, consult the mailing list ")
;; it yourself -- it will be wrong in other locales. ;; it yourself -- it will be wrong in other locales.
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
(_ "The number option formatted as currency is %a.") (_ "The number option formatted as currency is %s.")
(gnc:html-markup-b (gnc:html-markup-b
(gnc:amount->string num-val (gnc:default-print-info #f))))))) (gnc:amount->string num-val (gnc:default-print-info #f)))))))
;; you can add as many objects as you want. Here's another ;; you can add as many objects as you want. Here's another
;; one. We'll make a single-column table of the selected list ;; one. We'll make a single-column table of the selected list
;; options just for grins. ;; options just for grins.
@ -435,7 +449,7 @@ new, totally cool report, consult the mailing list ")
document document
(gnc:make-html-text (gnc:make-html-text
(gnc:html-markup-p (_ "You have selected no accounts."))))) (gnc:html-markup-p (_ "You have selected no accounts.")))))
(gnc:html-document-add-object! (gnc:html-document-add-object!
document document
(gnc:make-html-text (gnc:make-html-text

3
src/scm/report/pnl.scm
View File

@ -118,8 +118,7 @@
(from-date-tp (gnc:timepair-start-day-time (from-date-tp (gnc:timepair-start-day-time
(vector-ref (get-option pagename-general (vector-ref (get-option pagename-general
optname-from-date) 1))) optname-from-date) 1)))
(doc (gnc:make-html-document)) (doc (gnc:make-html-document)))
(txt (gnc:make-html-text)))
(gnc:html-document-set-title! (gnc:html-document-set-title!
doc (string-append (_ "Profit and Loss") " " doc (string-append (_ "Profit and Loss") " "

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

@ -8,8 +8,13 @@
;; reports ;; reports
(gnc:depend "report/account-summary.scm") (gnc:depend "report/account-summary.scm")
(gnc:depend "report/average-balance.scm") (gnc:depend "report/average-balance.scm")
(gnc:depend "report/pnl.scm")
(gnc:depend "report/hello-world.scm") (gnc:depend "report/hello-world.scm")
(gnc:depend "report/pnl.scm")
(let ((locale (setlocale LC_MESSAGES)))
(if (or (equal? locale "C")
(equal? locale "en")
(equal? locale "en_US"))
(gnc:depend "report/taxtxf.scm")))
(gnc:depend "report/transaction-report.scm") (gnc:depend "report/transaction-report.scm")
;; style sheets ;; style sheets

576
src/scm/report/taxtxf.scm
View File

@ -1,7 +1,5 @@
;; -*-scheme-*- ;; -*-scheme-*-
;; $Id$
;; by Richard -Gilligan- Uschold ;; by Richard -Gilligan- Uschold
;; Extensivbly modified from balance-and-pnl.scm
;; ;;
;; This prints Tax related accounts and exports TXF files for import to ;; This prints Tax related accounts and exports TXF files for import to
;; TaxCut, TurboTax, etc. ;; TaxCut, TurboTax, etc.
@ -40,101 +38,6 @@
(gnc:depend "report/txf-export.scm") (gnc:depend "report/txf-export.scm")
(gnc:depend "report/txf-export-help.scm") (gnc:depend "report/txf-export-help.scm")
;; This and the next function are the same as in transaction-report.scm
(define (make-split-list account split-filter-pred)
(let ((num-splits (gnc:account-get-split-count account)))
(let loop ((index 0)
(split (gnc:account-get-split account 0))
(slist '()))
(if (= index num-splits)
(reverse slist)
(loop (+ index 1)
(gnc:account-get-split account (+ index 1))
(if (split-filter-pred split)
(cons split slist)
slist))))))
;; returns a predicate that returns true only if a split is
;; between early-date and late-date
(define (split-report-make-date-filter-predicate begin-date-tp
end-date-tp)
(lambda (split)
(let ((tp
(gnc:transaction-get-date-posted
(gnc:split-get-parent split))))
(and (gnc:timepair-ge-date tp begin-date-tp)
(gnc:timepair-le-date tp end-date-tp)))))
;; This is nearly identical to, and could be shared with
;; display-report-list-item in report.scm. This adds warn-msg parameter
(define (gnc:display-report-list-item item port warn-msg)
(cond
((string? item) (display item port))
((null? item) #t)
((list? item) (map (lambda (item) (gnc:display-report-list-item item port
warn-msg))
item))
(else (gnc:warn warn-msg item " is the wrong type."))))
;; make a list of accounts from a group pointer
(define (gnc:group-ptr->list group-prt)
(if (not group-prt)
'()
(gnc:group-map-accounts (lambda (x) x) group-prt)))
;; some html helpers
(define (html-blue html)
(if html
(string-append "<font color=\"#0000ff\">" html "</font>")
#f))
(define (html-red html)
(if html
(string-append "<font color=\"#ff0000\">" html "</font>")
#f))
(define (html-black html)
(if html
(string-append "<font color=\"#000000\">" html "</font>")
#f))
(define (html-table-row-align-color color lst align-list)
(if (string? lst)
lst
(list "<TR bgcolor=" color ">"
(map html-table-col-align lst align-list)
"</TR>")))
;; a few string functions I couldn't find elsewhere
(define (string-search string sub-str start)
(do ((sub-len (string-length sub-str))
;; must recompute sub-len because order is unknown
(limit (- (string-length string) (string-length sub-str)))
(char0 (string-ref sub-str 0))
;; find first char of sub-str ; must recompute char0
(match0 (string-index string (string-ref sub-str 0) start) ; init
(string-index string char0 (+ 1 match0))) ; step
(match #f #f))
((or (not match0) (> match0 limit)
;; does entire sub-str match?
(let ()
(set! match (string=? sub-str (substring string match0
(+ match0 sub-len))))
(if match (set! match match0))
match))
match)))
(define (string-search? string sub-str start)
(number? (string-search string sub-str start)))
(define (string-substitute string search-str sub-str start)
(let ((pos (string-search string search-str start)))
(if pos
(let ((search-len (string-length search-str)))
(string-append (substring string 0 pos) sub-str
(substring string (+ pos search-len))))
string)))
(define (make-level-collector num-levels) (define (make-level-collector num-levels)
(let ((level-collector (make-vector num-levels))) (let ((level-collector (make-vector num-levels)))
(do ((i 0 (+ i 1))) (do ((i 0 (+ i 1)))
@ -146,15 +49,113 @@
(let* ((MAX-LEVELS 16) ; Maximum Account Levels (let* ((MAX-LEVELS 16) ; Maximum Account Levels
(levelx-collector (make-level-collector MAX-LEVELS)) (levelx-collector (make-level-collector MAX-LEVELS))
(bg-color "#f6ffdb") (bg-color "#f6ffdb")
(white "#ffffff")) (red "#ff0000")
(white "#ffffff")
(blue "#0000ff"))
;; This and the next function are the same as in transaction-report.scm
(define (make-split-list account split-filter-pred)
(let ((num-splits (gnc:account-get-split-count account)))
(let loop ((index 0)
(split (gnc:account-get-split account 0))
(slist '()))
(if (= index num-splits)
(reverse slist)
(loop (+ index 1)
(gnc:account-get-split account (+ index 1))
(if (split-filter-pred split)
(cons split slist)
slist))))))
;; returns a predicate that returns true only if a split is
;; between early-date and late-date
(define (split-report-make-date-filter-predicate begin-date-tp
end-date-tp)
(lambda (split)
(let ((tp
(gnc:transaction-get-date-posted
(gnc:split-get-parent split))))
(and (gnc:timepair-ge-date tp begin-date-tp)
(gnc:timepair-le-date tp end-date-tp)))))
;; This is nearly identical to, and could be shared with
;; display-report-list-item in report.scm. This adds warn-msg parameter
(define (gnc:display-report-list-item item port warn-msg)
(cond
((string? item) (display item port))
((null? item) #t)
((list? item) (map (lambda (item) (gnc:display-report-list-item item port
warn-msg))
item))
(else (gnc:warn warn-msg item " is the wrong type."))))
;; make a list of accounts from a group pointer
(define (gnc:group-ptr->list group-prt)
(if (not group-prt)
'()
(gnc:group-map-accounts (lambda (x) x) group-prt)))
;; some html helpers
(define (html-blue html)
(if html
(string-append "<font color=\"#0000ff\">" html "</font>")
#f))
(define (html-red html)
(if html
(string-append "<font color=\"#ff0000\">" html "</font>")
#f))
(define (html-black html)
(if html
(string-append "<font color=\"#000000\">" html "</font>")
#f))
(define (html-table-row-align-color color lst align-list)
(if (string? lst)
lst
lst))
; (list "<TR bgcolor=" color ">"
; (map html-table-col-align lst align-list)
; "</TR>")))
;; a few string functions I couldn't find elsewhere
(define (string-search string sub-str start)
(do ((sub-len (string-length sub-str))
;; must recompute sub-len because order is unknown
(limit (- (string-length string) (string-length sub-str)))
(char0 (string-ref sub-str 0))
;; find first char of sub-str ; must recompute char0
(match0 (string-index string (string-ref sub-str 0) start) ; init
(string-index string char0 (+ 1 match0))) ; step
(match #f #f))
((or (not match0) (> match0 limit)
;; does entire sub-str match?
(let ()
(set! match (string=? sub-str (substring string match0
(+ match0 sub-len))))
(if match (set! match match0))
match))
match)))
(define (string-search? string sub-str start)
(number? (string-search string sub-str start)))
(define (string-substitute string search-str sub-str start)
(let ((pos (string-search string search-str start)))
(if pos
(let ((search-len (string-length search-str)))
(string-append (substring string 0 pos) sub-str
(substring string (+ pos search-len))))
string)))
(define (lx-collector level action value) (define (lx-collector level action value)
((vector-ref levelx-collector (- level 1)) action value)) ((vector-ref levelx-collector (- level 1)) action value))
;; IRS asked congress to make the tax quarters sthe same as real quarters ;; IRS asked congress to make the tax quarters the same as real quarters
;; This is the year it is effective. THIS IS A Y10K BUG! ;; This is the year it is effective. THIS IS A Y10K BUG!
(define tax-qtr-real-qtr-year 10000) (define tax-qtr-real-qtr-year 10000)
(define tax-tab-title (N_ "TAX Report Options")) (define tax-tab-title (N_ "TAX Report Options"))
(define hierarchical-tab-title (N_ "Hierarchical Options")) (define hierarchical-tab-title (N_ "Hierarchical Options"))
@ -165,12 +166,11 @@
(define (hierarchical-options-generator) (define (hierarchical-options-generator)
(options-generator #t hierarchical-tab-title)) (options-generator #t hierarchical-tab-title))
(define (options-generator hierarchical? tab-title) (define (options-generator hierarchical? tab-title)
(define gnc:*tax-report-options* (gnc:new-options)) (define gnc:*tax-report-options* (gnc:new-options))
(define (gnc:register-tax-option new-option) (define (gnc:register-tax-option new-option)
(gnc:register-option gnc:*tax-report-options* new-option)) (gnc:register-option gnc:*tax-report-options* new-option))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-date-option (gnc:make-date-option
tab-title (N_ "From") tab-title (N_ "From")
@ -178,11 +178,11 @@
(lambda () (lambda ()
(let ((bdtm (gnc:timepair->date (gnc:timepair-canonical-day-time (let ((bdtm (gnc:timepair->date (gnc:timepair-canonical-day-time
(cons (current-time) 0))))) (cons (current-time) 0)))))
(set-tm:mday bdtm 1) ; 01 (set-tm:mday bdtm 1) ; 01
(set-tm:mon bdtm 0) ; Jan (set-tm:mon bdtm 0) ; Jan
(cons 'absolute (cons (car (mktime bdtm)) 0)))) (cons 'absolute (cons (car (mktime bdtm)) 0))))
#f 'absolute #f)) #f 'absolute #f))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-date-option (gnc:make-date-option
tab-title (N_ "To") tab-title (N_ "To")
@ -191,7 +191,7 @@
(cons 'absolute (gnc:timepair-canonical-day-time (cons 'absolute (gnc:timepair-canonical-day-time
(cons (current-time) 0)))) (cons (current-time) 0))))
#f 'absolute #f)) #f 'absolute #f))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-multichoice-option (gnc:make-multichoice-option
tab-title (N_ "Alternate Period") tab-title (N_ "Alternate Period")
@ -226,19 +226,18 @@
tab-title (N_ "Select Accounts (none = all)") tab-title (N_ "Select Accounts (none = all)")
"d" (N_ "Select accounts") "d" (N_ "Select accounts")
(lambda () (gnc:get-current-accounts)) (lambda () (gnc:get-current-accounts))
#f #f #t))
#t))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
tab-title (N_ "Suppress $0.00 values") tab-title (N_ "Suppress $0.00 values")
"f" (N_ "$0.00 valued Accounts won't be printed.") #t)) "f" (N_ "$0.00 valued Accounts won't be printed.") #t))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
tab-title (N_ "Print Full account names") tab-title (N_ "Print Full account names")
"g" (N_ "Print all Parent account names") #f)) "g" (N_ "Print all Parent account names") #f))
(if (not hierarchical?) (if (not hierarchical?)
(begin (begin
(gnc:register-tax-option (gnc:register-tax-option
@ -261,20 +260,19 @@
(N_ "Reset Tax Related & sub-accounts") (N_ "Reset Tax Related & sub-accounts")
(N_ "Reset Selected & sub-accounts as not Tax Related"))) (N_ "Reset Selected & sub-accounts as not Tax Related")))
))) )))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-account-list-option (gnc:make-account-list-option
(N_ "TXF Export Init") (N_ "Select Account") (N_ "TXF Export Init") (N_ "Select Account")
"a" (N_ "Select Account") "a" (N_ "Select Account")
(lambda () (gnc:get-current-accounts)) (lambda () (gnc:get-current-accounts))
#f #f #t))
#t))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
(N_ "TXF Export Init") (N_ "Print extended TXF HELP messages") (N_ "TXF Export Init") (N_ "Print extended TXF HELP messages")
"b" (N_ "Print TXF HELP") #f)) "b" (N_ "Print TXF HELP") #f))
(gnc:register-tax-option (gnc:register-tax-option
;;(gnc:make-multichoice-option ;;(gnc:make-multichoice-option
(gnc:make-list-option (gnc:make-list-option
@ -282,8 +280,7 @@
(N_ "For INCOME accounts, select here. < ^ # see help") (N_ "For INCOME accounts, select here. < ^ # see help")
"c" (N_ "Select a TXF Income catagory") "c" (N_ "Select a TXF Income catagory")
'() '()
txf-income-catagories txf-income-catagories))
))
(gnc:register-tax-option (gnc:register-tax-option
;;(gnc:make-multichoice-option ;;(gnc:make-multichoice-option
@ -292,8 +289,7 @@
(N_ "For EXPENSE accounts, select here. < ^ # see help") (N_ "For EXPENSE accounts, select here. < ^ # see help")
"d" (N_ "Select a TXF Expense catagory") "d" (N_ "Select a TXF Expense catagory")
'() '()
txf-expense-catagories txf-expense-catagories))
))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-multichoice-option (gnc:make-multichoice-option
@ -307,15 +303,14 @@
(N_ "Use Current Account Name"))) (N_ "Use Current Account Name")))
(list->vector (list->vector
(list 'parent (N_ "^ Parent Account") (list 'parent (N_ "^ Parent Account")
(N_ "Use Parent Account Name"))) (N_ "Use Parent Account Name"))))))))
)))))
gnc:*tax-report-options*) gnc:*tax-report-options*)
(define tax-key "{tax}") (define tax-key "{tax}")
(define tax-end-key "{/tax}") (define tax-end-key "{/tax}")
;; Render txf information ;; Render txf information
(define txf-last-payer "") ; if same as current, inc txf-l-coount (define txf-last-payer "") ; if same as current, inc txf-l-coount
; this only works if different ; this only works if different
@ -330,7 +325,7 @@
(define (txf-payer? str) (define (txf-payer? str)
(member str '("<" "^"))) (member str '("<" "^")))
;; These gnc:account-get-xxx functions will be relpaced when the tax ;; These gnc:account-get-xxx functions will be relpaced when the tax
;; and txf information gets its own account fields, and is no longer ;; and txf information gets its own account fields, and is no longer
;; in the notes field. ;; in the notes field.
@ -340,7 +335,7 @@
(define (gnc:account-get-tax account) (define (gnc:account-get-tax account)
(let* ((notes (gnc:account-get-notes account))) (let* ((notes (gnc:account-get-notes account)))
(string-search? (if notes notes "") tax-key 0))) (string-search? (if notes notes "") tax-key 0)))
(define (gnc:account-get-txf account) (define (gnc:account-get-txf account)
(let* ((notes (gnc:account-get-notes account))) (let* ((notes (gnc:account-get-notes account)))
(set! txf-notes (if notes notes "")) (set! txf-notes (if notes notes ""))
@ -350,7 +345,7 @@
(string-length tax-key))) (string-length tax-key)))
#t) #t)
#f))) #f)))
;; NOTE: You must call gnc:account-get-txf FIRST, or the txf-notes, tax-pos, ;; NOTE: You must call gnc:account-get-txf FIRST, or the txf-notes, tax-pos,
;; and txf-pos variables will not be valid!! ;; and txf-pos variables will not be valid!!
(define (gnc:account-get-txf-code account) (define (gnc:account-get-txf-code account)
@ -369,7 +364,7 @@
(if txf-pos (if txf-pos
(substring txf-notes tax-pos txf-pos) (substring txf-notes tax-pos txf-pos)
" ")) " "))
;; because we use the list-option input structure, we have to build our own ;; because we use the list-option input structure, we have to build our own
;; search function ;; search function
(define (txfq-ref key txf-list) (define (txfq-ref key txf-list)
@ -379,7 +374,7 @@
(if (>= i len) (if (>= i len)
(list-ref txf-list 0) (list-ref txf-list 0)
(list-ref txf-list i))))) (list-ref txf-list i)))))
;; return a string to insert in account-notes, or an error symbol ;; return a string to insert in account-notes, or an error symbol
;; We only want one, but list-option returns a list. ;; We only want one, but list-option returns a list.
(define (txf-string code-lst catagories-lst) (define (txf-string code-lst catagories-lst)
@ -400,7 +395,7 @@
(number->string (vector-ref txf-vec 3)) (number->string (vector-ref txf-vec 3))
" \\ " (symbol->string " \\ " (symbol->string
(car code-lst)))))))))) (car code-lst))))))))))
;; insert help strings in txf catagories ;; insert help strings in txf catagories
(define (txf-help cat-list) (define (txf-help cat-list)
(do ((i 0 (+ i 1)) (do ((i 0 (+ i 1))
@ -414,7 +409,7 @@
(list-set! cat-list i item) (list-set! cat-list i item)
#t) #t)
#f)))) #f))))
;; print txf help strings ;; print txf help strings
(define (txf-print-help vect inc) (define (txf-print-help vect inc)
(let* ((form-desc (vector-ref vect 1)) (let* ((form-desc (vector-ref vect 1))
@ -433,7 +428,7 @@
(list (html-red form-code-desc) (list (html-red form-code-desc)
(html-red help))) (html-red help)))
(list "left" "left")))) (list "left" "left"))))
;; Set or Reset txf string in account notes. str == #f resets. ;; Set or Reset txf string in account notes. str == #f resets.
;; Returns a code that indicates the function executed. ;; Returns a code that indicates the function executed.
(define (txf-status account key end-key str) (define (txf-status account key end-key str)
@ -444,7 +439,7 @@
(key-start (string-search notes key 0)) (key-start (string-search notes key 0))
(end-start (string-search notes end-key 0)) (end-start (string-search notes end-key 0))
(notes-len (string-length notes))) (notes-len (string-length notes)))
;; 8 conditions: (key-start, end-start, str) function ;; 8 conditions: (key-start, end-start, str) function
;; #f #f #f nothing ;; #f #f #f nothing
;; num #f #f nothing ;; num #f #f nothing
@ -454,7 +449,7 @@
;; num num str replace ;; num num str replace
;; #f #f str set, tax too ;; #f #f str set, tax too
;; num #f str set ;; num #f str set
(if key-start (if key-start
(let ((key-end (+ key-start key-len))) (let ((key-end (+ key-start key-len)))
(cond ((and end-start (not str)) (cond ((and end-start (not str))
@ -493,7 +488,7 @@
key str end-key notes)) key str end-key notes))
ret-val) ret-val)
'none2))))) 'none2)))))
;; execute the selected function on the account. Return a list ;; execute the selected function on the account. Return a list
;; containing the function code executed and the txf-string or error message ;; containing the function code executed and the txf-string or error message
(define (txf-function acc txf-inc txf-exp txf-payer) (define (txf-function acc txf-inc txf-exp txf-payer)
@ -536,7 +531,7 @@
(list fun str)) (list fun str))
(list 'notIE "txf-account not of type income or expense"))) (list 'notIE "txf-account not of type income or expense")))
(list 'noAcc "no txf-account"))) (list 'noAcc "no txf-account")))
;; generate a feedback string for the txf function executed ;; generate a feedback string for the txf function executed
(define (txf-feedback-str fun-str full-name) (define (txf-feedback-str fun-str full-name)
(case (car fun-str) (case (car fun-str)
@ -561,7 +556,7 @@
(string-append "TAX status was set and the TXF code: \"" (string-append "TAX status was set and the TXF code: \""
(cadr fun-str) "\", was added to account: \"" (cadr fun-str) "\", was added to account: \""
full-name "\"")))) full-name "\""))))
;; check for duplicate txf codes ;; check for duplicate txf codes
(define (txf-check-dups account) (define (txf-check-dups account)
(let* ((code (string->symbol (gnc:account-get-txf-code account))) (let* ((code (string->symbol (gnc:account-get-txf-code account)))
@ -572,9 +567,9 @@
(if item (if item
(cons account item) (cons account item)
(list account))))))) (list account)))))))
;; Print error message for duplicate txf codes and accounts ;; Print error message for duplicate txf codes and accounts
(define (txf-print-dups) (define (txf-print-dups doc)
(let ((dups (apply append (let ((dups (apply append
(map (lambda (x) (map (lambda (x)
(let ((cnt (length (cdr x)))) (let ((cnt (length (cdr x))))
@ -589,21 +584,26 @@
(map gnc:account-get-full-name (map gnc:account-get-full-name
(cdr x)))) (cdr x))))
'()))) '())))
txf-dups-alist)))) txf-dups-alist)))
(text (gnc:make-html-text)))
(if (not (null? dups)) (if (not (null? dups))
(cons (begin
(html-para (gnc:html-text-set-style! text 'font-color "#0000ff")
(html-blue (gnc:html-document-add-object! doc text)
(_ "ERROR: There are duplicate TXF codes assigned\ (gnc:html-text-append!
text
(gnc:html-markup-p
(_ "ERROR: There are duplicate TXF codes assigned\
to some accounts. Only TXF codes prefixed with \"&lt;\" or \"^\" may be\ to some accounts. Only TXF codes prefixed with \"&lt;\" or \"^\" may be\
repeated."))) repeated.")))
(map html-para (map html-blue dups))) (map (lambda (s)
'()))) (gnc:html-text-append! text (gnc:html-markup-p s)))
dups)))))
;; some codes require special handling ;; some codes require special handling
(define (txf-special-split? code) (define (txf-special-split? code)
(member code '("N521"))) ; only one for now (member code '("N521"))) ; only one for now
(define (render-txf-account account account-value date) (define (render-txf-account account account-value date)
(let* ((print-info (gnc:account-value-print-info account #f)) (let* ((print-info (gnc:account-value-print-info account #f))
(value (gnc:amount->string account-value print-info)) (value (gnc:amount->string account-value print-info))
@ -651,7 +651,7 @@
(else '())) (else '()))
"\n^")) "\n^"))
""))) "")))
;; Render any level ;; Render any level
(define (render-level-x-account level max-level account lx-value (define (render-level-x-account level max-level account lx-value
suppress-0 full-names txf-date hierarchical?) suppress-0 full-names txf-date hierarchical?)
@ -748,16 +748,14 @@
(define (generate-tax-or-txf report-name (define (generate-tax-or-txf report-name
report-description report-description
options report-obj
tax-mode-in) tax-mode-in)
;; These are some helper functions for looking up option values. (define (get-option pagename optname)
(define (get-op section name) (gnc:option-value
(gnc:lookup-option options section name)) (gnc:lookup-option
(gnc:report-options report-obj) pagename optname)))
(define (op-value section name)
(gnc:option-value (get-op section name)))
;; the number of account generations: children, grandchildren etc. ;; the number of account generations: children, grandchildren etc.
(define (num-generations account gen) (define (num-generations account gen)
(let ((children (gnc:account-get-children account))) (let ((children (gnc:account-get-children account)))
@ -774,17 +772,17 @@
report-name)) report-name))
(tab-title (if hierarchical? hierarchical-tab-title tax-tab-title)) (tab-title (if hierarchical? hierarchical-tab-title tax-tab-title))
(from-value (gnc:date-option-absolute-time (from-value (gnc:date-option-absolute-time
(op-value tab-title "From"))) (get-option tab-title "From")))
(to-value (gnc:timepair-end-day-time (to-value (gnc:timepair-end-day-time
(gnc:date-option-absolute-time (gnc:date-option-absolute-time
(op-value tab-title "To")))) (get-option tab-title "To"))))
(alt-period (op-value tab-title "Alternate Period")) (alt-period (get-option tab-title "Alternate Period"))
(suppress-0 (op-value tab-title "Suppress $0.00 values")) (suppress-0 (get-option tab-title "Suppress $0.00 values"))
(full-names (op-value tab-title (full-names (get-option tab-title
"Print Full account names")) "Print Full account names"))
(tax-mode tax-mode-in) ; these need to different later (tax-mode tax-mode-in) ; these need to different later
(user-sel-accnts (op-value tab-title (user-sel-accnts (get-option tab-title
"Select Accounts (none = all)")) "Select Accounts (none = all)"))
(valid-user-sel-accnts (validate user-sel-accnts hierarchical?)) (valid-user-sel-accnts (validate user-sel-accnts hierarchical?))
;; If no selected accounts, check all. ;; If no selected accounts, check all.
(selected-accounts (if (not (null? user-sel-accnts)) (selected-accounts (if (not (null? user-sel-accnts))
@ -797,7 +795,7 @@
selected-accounts)) selected-accounts))
0)) 0))
(max-level (min MAX-LEVELS (max 1 generations))) (max-level (min MAX-LEVELS (max 1 generations)))
;; Alternate dates are relative to from-date ;; Alternate dates are relative to from-date
(from-date (gnc:timepair->date from-value)) (from-date (gnc:timepair->date from-value))
(from-value (gnc:timepair-start-day-time (from-value (gnc:timepair-start-day-time
@ -829,7 +827,7 @@
((4th-est 4th-last) ; Oct 1 ((4th-est 4th-last) ; Oct 1
(set-tm:mon bdtm 9)))) (set-tm:mon bdtm 9))))
(cons (car (mktime bdtm)) 0)))) (cons (car (mktime bdtm)) 0))))
(to-value (gnc:timepair-end-day-time (to-value (gnc:timepair-end-day-time
(let ((bdtm from-date)) (let ((bdtm from-date))
(if (member alt-period (if (member alt-period
@ -872,11 +870,14 @@
(set! bdtm (gnc:timepair->date to-value))))) (set! bdtm (gnc:timepair->date to-value)))))
(cons (car (mktime bdtm)) 0)))) (cons (car (mktime bdtm)) 0))))
(txf-help (if hierarchical? #f (txf-help
(op-value "TXF Export Init" "Print extended TXF HELP\ (if hierarchical? #f
messages"))) (get-option "TXF Export Init"
(txf-feedback-str-lst '())) "Print extended TXF HELP messages")))
(txf-feedback-str-lst '())
(doc (gnc:make-html-document))
(table (gnc:make-html-table)))
(define (handle-txf-special-splits level account from-value to-value) (define (handle-txf-special-splits level account from-value to-value)
(if (and (gnc:account-get-txf account) (if (and (gnc:account-get-txf account)
(txf-special-split? (gnc:account-get-txf-code account))) (txf-special-split? (gnc:account-get-txf-code account)))
@ -889,21 +890,21 @@
(equal? (strftime "%m%d" (localtime (car to-value))) (equal? (strftime "%m%d" (localtime (car to-value)))
"1231"))) "1231")))
;; Adjust dates so we get the final Estimated Tax ;; Adjust dates so we get the final Estimated Tax
;; paynemt from the right year ;; paymnent from the right year
(from-est (if full-year? (from-est (if full-year?
(let ((bdtm (gnc:timepair->date (let ((bdtm (gnc:timepair->date
(gnc:timepair-canonical-day-time (gnc:timepair-canonical-day-time
from-value)))) from-value))))
(set-tm:mday bdtm 1) ; 01 (set-tm:mday bdtm 1) ; 01
(set-tm:mon bdtm 2) ; Mar (set-tm:mon bdtm 2) ; Mar
(cons (car (mktime bdtm)) 0)) (cons (car (mktime bdtm)) 0))
from-value)) from-value))
(to-est (if full-year? (to-est (if full-year?
(let* ((bdtm (gnc:timepair->date (let* ((bdtm (gnc:timepair->date
(gnc:timepair-canonical-day-time (gnc:timepair-canonical-day-time
from-value)))) from-value))))
(set-tm:mday bdtm 28) ; 28 (set-tm:mday bdtm 28) ; 28
(set-tm:mon bdtm 1) ; Feb (set-tm:mon bdtm 1) ; Feb
(set-tm:year bdtm (+ (tm:year bdtm) 1)) (set-tm:year bdtm (+ (tm:year bdtm) 1))
(cons (car (mktime bdtm)) 0)) (cons (car (mktime bdtm)) 0))
to-value)) to-value))
@ -929,7 +930,7 @@
(render-txf-account account value date)))) (render-txf-account account value date))))
split-list)) split-list))
'())) '()))
(define (handle-level-x-account level account) (define (handle-level-x-account level account)
(let ((type (gw:enum-GNCAccountType-val->sym (let ((type (gw:enum-GNCAccountType-val->sym
(gnc:account-get-type account) #f)) (gnc:account-get-type account) #f))
@ -948,13 +949,13 @@
(+ 1 level) x) (+ 1 level) x)
'())) '()))
children))) children)))
(account-balance (if (or hierarchical? (account-balance (if (or hierarchical?
(gnc:account-get-tax account)) (gnc:account-get-tax account))
(d-gnc:account-get-balance-interval (d-gnc:account-get-balance-interval
account from-value to-value #f) account from-value to-value #f)
0))) ; don't add non tax related 0))) ; don't add non tax related
(set! account-balance (+ (if (> max-level level) (set! account-balance (+ (if (> max-level level)
(lx-collector (+ 1 level) (lx-collector (+ 1 level)
'total #f) 'total #f)
@ -988,20 +989,22 @@
(list level-x-output childrens-output))))))) (list level-x-output childrens-output)))))))
;; Ignore ;; Ignore
'()))) '())))
(if (not hierarchical?) (if (not hierarchical?)
(let* ((tax-stat (op-value tab-title "Set/Reset Tax Status")) (let* ((tax-stat (get-option tab-title "Set/Reset Tax Status"))
(txf-acc-lst (op-value "TXF Export Init" "Select Account")) (txf-acc-lst (get-option "TXF Export Init" "Select Account"))
(txf-account (if (null? txf-acc-lst) (txf-account (if (null? txf-acc-lst)
(begin (set! txf-acc-lst '(#f)) (begin (set! txf-acc-lst '(#f))
#f) #f)
(car txf-acc-lst))) (car txf-acc-lst)))
(txf-income (op-value "TXF Export Init" "For INCOME accounts,\ (txf-income (get-option "TXF Export Init"
"For INCOME accounts,\
select here. < ^ # see help")) select here. < ^ # see help"))
(txf-expense (op-value "TXF Export Init" "For EXPENSE\ (txf-expense (get-option "TXF Export Init"
"For EXPENSE\
accounts, select here. < ^ # see help")) accounts, select here. < ^ # see help"))
(txf-payer-source (op-value "TXF Export Init" (txf-payer-source (get-option "TXF Export Init"
"< ^ Payer Name source")) "< ^ Payer Name source"))
(txf-full-name-lst (if txf-account (txf-full-name-lst (if txf-account
(map gnc:account-get-full-name (map gnc:account-get-full-name
txf-acc-lst) txf-acc-lst)
@ -1016,14 +1019,14 @@
(key-status user-sel-accnts #t tax-key tax-end-key #t)) (key-status user-sel-accnts #t tax-key tax-end-key #t))
((tax-reset-kids) ((tax-reset-kids)
(key-status user-sel-accnts #f tax-key tax-end-key #t)))) (key-status user-sel-accnts #f tax-key tax-end-key #t))))
(txf-fun-str-lst (map (lambda (a) (txf-function (txf-fun-str-lst (map (lambda (a) (txf-function
a txf-income txf-expense a txf-income txf-expense
txf-payer-source)) txf-payer-source))
txf-acc-lst))) txf-acc-lst)))
(set! txf-feedback-str-lst (map txf-feedback-str txf-fun-str-lst (set! txf-feedback-str-lst (map txf-feedback-str txf-fun-str-lst
txf-full-name-lst)))) txf-full-name-lst))))
(let ((output '()) (let ((output '())
(from-date (strftime "%Y-%b-%d" (localtime (car from-value)))) (from-date (strftime "%Y-%b-%d" (localtime (car from-value))))
(to-date (strftime "%Y-%b-%d" (localtime (car to-value)))) (to-date (strftime "%Y-%b-%d" (localtime (car to-value))))
@ -1036,8 +1039,8 @@
(report-title (if txf-help (report-title (if txf-help
(_ "Detailed TXF Category Descriptions") (_ "Detailed TXF Category Descriptions")
report-name)) report-name))
(file-name "????")) (file-name #f))
;; Now, the main body ;; Now, the main body
;; Reset all the balance collectors ;; Reset all the balance collectors
(do ((i 1 (+ i 1))) (do ((i 1 (+ i 1)))
@ -1067,25 +1070,26 @@
#f) #f)
#t)) #t))
fname))) fname)))
(if file-name ; cancel TXF if no file selected (if file-name ; cancel TXF if no file selected
(let* ((port (open-output-file file-name)) (let* ((port (open-output-file file-name))
(output (list (output
(map (lambda (x) (handle-level-x-account (list
1 x)) (map (lambda (x) (handle-level-x-account 1 x))
selected-accounts))) selected-accounts)))
(output-txf (list (output-txf (list
"V035" "V035"
"\nAGnuCash 1.5.2" "\nAGnuCash "
gnc:version
"\n" today-date "\n" today-date
"\n^" "\n^"
output))) output)))
(gnc:display-report-list-item output-txf port (gnc:display-report-list-item output-txf port
"taxtxf.scm - ") "taxtxf.scm - ")
(newline port) (newline port)
(close-output-port port))))) (close-output-port port)))))
(set! tax-mode #t) ; now do tax mode to display report (set! tax-mode #t) ; now do tax mode to display report
(set! output (list (set! output (list
(if txf-help (if txf-help
@ -1097,63 +1101,85 @@
txf-expense-catagories)) txf-expense-catagories))
(map (lambda (x) (handle-level-x-account 1 x)) (map (lambda (x) (handle-level-x-account 1 x))
selected-accounts)))) selected-accounts))))
(list ; Tax (gnc:html-document-set-title! doc report-title)
"<html>"
"<head>" (gnc:html-document-set-style!
"<title>" report-title "</title>" doc "body"
"</head>\n" 'attribute (list "bgcolor" bg-color)
"<body bgcolor=" bg-color ">" 'tag "center")
"<center>"
"<h1>" report-title "</h1>\n" (gnc:html-document-add-object!
"<p>" doc
(if txf-help (gnc:make-html-text
"" (gnc:html-markup-p
(html-black (string-append (_ "Period From:") " " (gnc:html-markup/format
from-date " " (_ "Period from %s to %s") from-date to-date))))
(_ "To:") " "
to-date))) (let ((text (gnc:make-html-text)))
"</p>\n" (gnc:html-text-set-style! text 'font-color "#0000ff")
"<p>" (gnc:html-document-add-object! doc text)
(html-blue (if hierarchical?
"" (if (not hierarchical?)
(if tax-mode-in (if tax-mode-in
(if txf-help (if (not txf-help)
"" (gnc:html-text-append!
(_ "Blue items are exportable to a TXF file")) text
(if file-name (gnc:html-markup-p
(string-append (_ "Blue items are exportable to a TXF file."))))
(_ "Blue items were exported to file: \"") (gnc:html-text-append!
file-name "\"") text
(_ "Blue items were <b>NOT</b> exported to \ (gnc:html-markup-p
txf file!"))))) (if file-name
"</p>\n" (gnc:html-markup/format
"</center>" (_ "Blue items were exported to file %s.")
(if (or hierarchical? txf-help) (gnc:html-markup-tt file-name))
"" (_ "Blue items were <em>not</em> exported to \
(map html-para (map html-blue txf-feedback-str-lst))) txf file!"))))))
(txf-print-dups)
"<table " (if txf-help "border=1 " "border=0 ") "cellpadding=1>" (if (not (or hierarchical? txf-help))
"<tr>" (map (lambda (s)
"<th>" (gnc:html-text-append! text (gnc:html-markup-p s)))
(if txf-help txf-feedback-str-lst)))
(list (_ "Tax Form \\ TXF Code") "<br>"
(_ "Description")) (txf-print-dups doc)
(_ "Account Name"))
"</th>\n" (gnc:html-document-add-object! doc table)
(if txf-help
"" (if txf-help
(do ((i (- max-level 1) (- i 1)) (gnc:html-table-set-style! 'attribute (list "border" "1")))
(head "" (string-append
head "<th align=right>" (_ "(Sub ") (if txf-help
(number->string i) ")</th>"))) (gnc:html-table-append-row!
((< i 1) head))) table
(list
(gnc:make-html-table-header-cell
(_ "Tax Form \\ TXF Code")
(gnc:html-markup-br)
(_ "Description"))
(gnc:make-html-table-header-cell "")
(gnc:make-html-table-header-cell
(_ "Extended TXF Help messages") " "
(html-blue "Income") " "
(html-red "Expense"))))
(gnc:html-table-append-row!
table
(list
(gnc:make-html-table-header-cell
(_ "Account Name")))))
(list
(if txf-help
""
(do ((i (- max-level 1) (- i 1))
(head "" (string-append
head "<th align=right>" (_ "(Sub ")
(number->string i) ")</th>")))
((< i 1) head)))
(if txf-help (if txf-help
(list "<th>" (_ "Extended TXF Help messages") (list "<th>" (_ "Extended TXF Help messages")
(html-blue " Income") (html-red " Expense")) (html-blue " Income") (html-red " Expense"))
(list "<th align=right>" (_ "Total"))) (list "<th align=right>" (_ "Total")))
"</th>\n"
"</tr>\n"
output output
"</table>\n" "</table>\n"
(if (null? (car output)) (if (null? (car output))
@ -1167,45 +1193,45 @@ txf file!")))))
" ") " ")
"</body>" "</body>"
"</html>") "</html>")
))) doc)))
;; copy help strings to catagory structures. ;; copy help strings to category structures.
(txf-help txf-income-catagories) (txf-help txf-income-catagories)
(txf-help txf-expense-catagories) (txf-help txf-expense-catagories)
(txf-help txf-help-catagories) (txf-help txf-help-catagories)
(gnc:define-report ; (gnc:define-report
'version 1 ; 'version 1
'name (N_ "Hierarchical") ; 'name (N_ "Hierarchical")
'options-generator hierarchical-options-generator ; 'options-generator hierarchical-options-generator
'renderer (lambda (options) ; 'renderer (lambda (report-obj)
(generate-tax-or-txf ; (generate-tax-or-txf
(_ "Hierarchical Accounts Report") ; (_ "Hierarchical Accounts Report")
(_ "This page shows your Taxable Income and \ ; (_ "This page shows your Taxable Income and \
Deductable Expenses.") ;Deductable Expenses.")
options ; report-obj
#t))) ; #t)))
(gnc:define-report (gnc:define-report
'version 1 'version 1
'name (N_ "Tax") 'name (N_ "Tax")
'options-generator tax-options-generator 'options-generator tax-options-generator
'renderer (lambda (options) 'renderer (lambda (report-obj)
(generate-tax-or-txf (generate-tax-or-txf
(_ "Taxable Income / Deductible Expenses") (_ "Taxable Income / Deductible Expenses")
(_ "This page shows your Taxable Income and \ (_ "This page shows your Taxable Income and \
Deductable Expenses.") Deductable Expenses.")
options report-obj
#t))) #t)))
(gnc:define-report (gnc:define-report
'version 1 'version 1
'name (N_ "Export .TXF") 'name (N_ "Export .TXF")
'options-generator tax-options-generator 'options-generator tax-options-generator
'renderer (lambda (options) 'renderer (lambda (report-obj)
(generate-tax-or-txf (generate-tax-or-txf
(_ "Taxable Income / Deductible Expenses") (_ "Taxable Income / Deductible Expenses")
(_ "This page shows your Taxable Income and \ (_ "This page shows your Taxable Income and \
Deductable Expenses.") Deductable Expenses.")
options report-obj
#f)))) #f))))