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>
* src/scm/report/transaction-report.scm: More colourization.
=======
2001-03-07 Bill Gribble <grib@billgribble.com>
* 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,
even if the non-format args are html-markup objects.
>>>>>>> 1.251
2001-03-07 Dave Peticolas <dave@krondo.com>
* 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 "finvar.h"
#include "glade-gnc-dialogs.h"
#include "glade-support.h"
#include "gnc-amount-edit.h"
#include "gnc-commodity.h"
#include "gnc-component-manager.h"
@ -528,7 +529,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PAYMENT_PERIODS] = 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);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -544,7 +545,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[INTEREST_RATE] = 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);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -562,7 +563,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PRESENT_VALUE] = 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);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -578,7 +579,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[PERIODIC_PAYMENT] = 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);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -594,7 +595,7 @@ gnc_ui_fincalc_dialog_create(void)
fcd->amounts[FUTURE_VALUE] = 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);
entry = GNC_AMOUNT_EDIT (edit)->amount_entry;
@ -602,83 +603,87 @@ gnc_ui_fincalc_dialog_create(void)
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);
gtk_signal_connect(GTK_OBJECT(button), "clicked",
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);
gtk_signal_connect(GTK_OBJECT(button), "clicked",
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);
gtk_signal_connect(GTK_OBJECT(button), "clicked",
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);
gtk_signal_connect(GTK_OBJECT(button), "clicked",
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);
gtk_signal_connect(GTK_OBJECT(button), "clicked",
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_FUNC(fincalc_entry_clear_clicked),
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_FUNC(fincalc_amount_clear_clicked),
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_FUNC(fincalc_amount_clear_clicked),
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_FUNC(fincalc_amount_clear_clicked),
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_FUNC(fincalc_amount_clear_clicked),
fcd->amounts[FUTURE_VALUE]);
menu = gtk_object_get_data(fcdo, "compounding_menu");
menu = lookup_widget (fcd->dialog, "compounding_menu");
fcd->compounding_menu = menu;
gnc_option_menu_init(menu);
menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu));
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;
gnc_option_menu_init(menu);
menu = gtk_option_menu_get_menu(GTK_OPTION_MENU(menu));
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;
gtk_signal_connect(GTK_OBJECT(button), "toggled",
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;
gtk_signal_connect(GTK_OBJECT(button), "toggled",
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_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);

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

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

@ -115,41 +115,36 @@
#f
(N_ "Enable debugging mode"))
(cons
"loglevel"
(list 'integer
(list "loglevel"
'integer
(lambda (val)
(gnc:config-var-value-set! gnc:*loglevel* #f val))
"LOGLEVEL"
(N_ "Set the logging level from 0 (least) to 6 (most)")))
(N_ "Set the logging level from 0 (least) to 6 (most)"))
(cons
"nofile"
(list 'boolean
(list "nofile"
'boolean
(lambda (val)
(gnc:config-var-value-set! gnc:*arg-no-file* #f val))
#f
(N_ "Do not load the last file opened")))
(N_ "Do not load the last file opened"))
(cons
"config-dir"
(list 'string
(list "config-dir"
'string
(lambda (val)
(gnc:config-var-value-set! gnc:*config-dir* #f val))
"CONFIGDIR"
(N_ "Set configuration directory")))
(N_ "Set configuration directory"))
(cons
"share-dir"
(list 'string
(list "share-dir"
'string
(lambda (val)
(gnc:config-var-value-set! gnc:*share-dir* #f val))
"SHAREDIR"
(N_ "Set shared directory")))
(N_ "Set shared directory"))
(cons
"load-path"
(list 'string
(list "load-path"
'string
(lambda (val)
(let ((path-list
(call-with-input-string val (lambda (port) (read port)))))
@ -159,11 +154,10 @@
(gnc:error "non-list given for --load-path: " val)
(gnc:shutdown 1)))))
"LOADPATH"
(N_ "Set the search path for .scm files.")))
(N_ "Set the search path for .scm files."))
(cons
"doc-path"
(list 'string
(list "doc-path"
'string
(lambda (val)
(gnc:debug "parsing --doc-path " val)
(let ((path-list
@ -174,27 +168,25 @@
(gnc:error "non-list given for --doc-path: " val)
(gnc:shutdown 1)))))
"DOCPATH"
(N_ "Set the search path for documentation files")))
(N_ "Set the search path for documentation files"))
(cons
"evaluate"
(list 'string
(list "evaluate"
'string
(lambda (val)
(set! gnc:*batch-mode-things-to-do*
(cons val gnc:*batch-mode-things-to-do*)))
"COMMAND"
(N_ "Evaluate the guile command")))
(N_ "Evaluate the guile command"))
;; Given a string, --load will load the indicated file, if possible.
(cons
"load"
(list 'string
(list "load"
'string
(lambda (val)
(set! gnc:*batch-mode-things-to-do*
(cons (lambda () (load val))
gnc:*batch-mode-things-to-do*)))
"FILE"
(N_ "Load the given .scm file")))
(N_ "Load the given .scm file"))
; (cons "add-price-quotes"
; (cons 'string
@ -216,19 +208,17 @@
;
; gnc:*batch-mode-things-to-do*)))))
(cons
"load-user-config"
(list 'boolean
(list "load-user-config"
'boolean
gnc:load-user-config-if-needed
#f
(N_ "Load the user configuation")))
(N_ "Load the user configuation"))
(cons
"load-system-config"
(list 'boolean
(list "load-system-config"
'boolean
gnc:load-system-config-if-needed
#f
(N_ "Load the system configuation")))))
(N_ "Load the system configuation"))))
(define (gnc:cmd-line-get-boolean-arg args)
;; --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)
(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)
(gnc:amount->string-helper
@ -290,13 +289,6 @@
(gnc:double-to-gnc-numeric datum 100 GNC-RND-ROUND)
(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

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:define-html-style-sheet
'version 1.0
'version 1
'name "Sample Style Sheet"
'renderer sample-renderer
'options sample-options))

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

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

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

@ -313,62 +313,76 @@ option like this.")
document
(gnc:make-html-text
(gnc:html-markup-p
(gnc:html-markup/format
(_ "This is a sample GnuCash report. \
See the guile (scheme) source code in ")
See the guile (scheme) source code in %s \
for details on writing your own reports, \
or extending existing reports.")
(gnc:html-markup-tt
gnc:_share-dir-default_ "/gnucash/scm/report")
(_ "for details on writing your own reports, \
or extending existing reports."))
(gnc:html-markup-p
(_ "For help on writing reports, or to contribute your brand \
new, totally cool report, consult the mailing list ")
(gnc:html-markup-anchor
"mailto:gnucash-devel@gnucash.org"
(gnc:html-markup-tt "gnucash-devel@gnucash.org")) ". "
(_ "For details on subscribing to that list, see ")
(gnc:html-markup-anchor
"http://www.gnucash.org"
(gnc:html-markup-tt
"www.gnucash.org")) ".")
(gnc:html-markup-p
(_ "The current time is ")
(gnc:html-markup-b time-string) ".")
(gnc:html-markup-p
(_ "The boolean option is ")
(gnc:html-markup-b (if bool-val (_ "true") (_ "false"))) ".")
(gnc:html-markup-p
(_ "The multi-choice option is ")
(gnc:html-markup-b (symbol->string mult-val)) ".")
(gnc:html-markup-p
(_ "The string option is ")
(gnc:html-markup-b string-val) ".")
(gnc:html-markup-p
(_ "The date option is ")
(gnc:html-markup-b date-string) ".")
(gnc:html-markup-p
(_ "The date and time option is ")
(gnc:html-markup-b date-string2) ".")
gnc:_share-dir-default_ "/gnucash/scm/report")))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The relative date option is %a.")
(_ "For help on writing reports, or to contribute your brand \
new, totally cool report, consult the mailing list %s.")
(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"
(gnc:html-markup-tt
"www.gnucash.org")))
(gnc:html-markup/format
(_ "You can learn more about writing scheme using this %s.")
(gnc:html-markup-anchor
"http://www.scheme.com/tspl2d/index.html"
(_ "online book"))))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The current time is %s.")
(gnc:html-markup-b time-string)))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The boolean option is %s.")
(gnc:html-markup-b (if bool-val (_ "true") (_ "false")))))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The multi-choice option is %s.")
(gnc:html-markup-b (symbol->string mult-val))))
(gnc:html-markup-p
(gnc:html-markup/format
(_ "The string option is %s.")
(gnc:html-markup-b string-val)))
(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
(_ "The relative date option is %s.")
(gnc:html-markup-b rel-date-string)))
(gnc:html-markup-p
(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-p
(gnc:html-markup/format
(_ "The number option is %a.")
(_ "The number option is %s.")
(gnc:html-markup-b (number->string num-val))))
;; Here we print the value of the number option formatted as
@ -379,7 +393,7 @@ new, totally cool report, consult the mailing list ")
;; it yourself -- it will be wrong in other locales.
(gnc:html-markup-p
(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:amount->string num-val (gnc:default-print-info #f)))))))

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

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

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

@ -8,8 +8,13 @@
;; reports
(gnc:depend "report/account-summary.scm")
(gnc:depend "report/average-balance.scm")
(gnc:depend "report/pnl.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")
;; style sheets

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

@ -1,7 +1,5 @@
;; -*-scheme-*-
;; $Id$
;; by Richard -Gilligan- Uschold
;; Extensivbly modified from balance-and-pnl.scm
;;
;; This prints Tax related accounts and exports TXF files for import to
;; TaxCut, TurboTax, etc.
@ -40,8 +38,23 @@
(gnc:depend "report/txf-export.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)
(define (make-level-collector num-levels)
(let ((level-collector (make-vector num-levels)))
(do ((i 0 (+ i 1)))
((= i num-levels) i)
(vector-set! level-collector i (gnc:make-stats-collector)))
level-collector))
;; Just a private scope.
(let* ((MAX-LEVELS 16) ; Maximum Account Levels
(levelx-collector (make-level-collector MAX-LEVELS))
(bg-color "#f6ffdb")
(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))
@ -54,9 +67,9 @@
(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
;; 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
@ -65,9 +78,9 @@
(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)
;; 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)
@ -76,37 +89,38 @@
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)
;; 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)
;; some html helpers
(define (html-blue html)
(if html
(string-append "<font color=\"#0000ff\">" html "</font>")
#f))
(define (html-red html)
(define (html-red html)
(if html
(string-append "<font color=\"#ff0000\">" html "</font>")
#f))
(define (html-black html)
(define (html-black html)
(if html
(string-append "<font color=\"#000000\">" html "</font>")
#f))
(define (html-table-row-align-color color lst align-list)
(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>")))
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)
;; 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)))
@ -124,10 +138,10 @@
match))
match)))
(define (string-search? string sub-str start)
(define (string-search? string sub-str start)
(number? (string-search string sub-str start)))
(define (string-substitute string search-str 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)))
@ -135,23 +149,10 @@
(substring string (+ pos search-len))))
string)))
(define (make-level-collector num-levels)
(let ((level-collector (make-vector num-levels)))
(do ((i 0 (+ i 1)))
((= i num-levels) i)
(vector-set! level-collector i (gnc:make-stats-collector)))
level-collector))
;; Just a private scope.
(let* ((MAX-LEVELS 16) ; Maximum Account Levels
(levelx-collector (make-level-collector MAX-LEVELS))
(bg-color "#f6ffdb")
(white "#ffffff"))
(define (lx-collector level 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!
(define tax-qtr-real-qtr-year 10000)
@ -170,7 +171,6 @@
(define (gnc:register-tax-option new-option)
(gnc:register-option gnc:*tax-report-options* new-option))
(gnc:register-tax-option
(gnc:make-date-option
tab-title (N_ "From")
@ -226,8 +226,7 @@
tab-title (N_ "Select Accounts (none = all)")
"d" (N_ "Select accounts")
(lambda () (gnc:get-current-accounts))
#f
#t))
#f #t))
(gnc:register-tax-option
(gnc:make-simple-boolean-option
@ -267,8 +266,7 @@
(N_ "TXF Export Init") (N_ "Select Account")
"a" (N_ "Select Account")
(lambda () (gnc:get-current-accounts))
#f
#t))
#f #t))
(gnc:register-tax-option
(gnc:make-simple-boolean-option
@ -282,8 +280,7 @@
(N_ "For INCOME accounts, select here. < ^ # see help")
"c" (N_ "Select a TXF Income catagory")
'()
txf-income-catagories
))
txf-income-catagories))
(gnc:register-tax-option
;;(gnc:make-multichoice-option
@ -292,8 +289,7 @@
(N_ "For EXPENSE accounts, select here. < ^ # see help")
"d" (N_ "Select a TXF Expense catagory")
'()
txf-expense-catagories
))
txf-expense-catagories))
(gnc:register-tax-option
(gnc:make-multichoice-option
@ -307,8 +303,7 @@
(N_ "Use Current Account Name")))
(list->vector
(list 'parent (N_ "^ Parent Account")
(N_ "Use Parent Account Name")))
)))))
(N_ "Use Parent Account Name"))))))))
gnc:*tax-report-options*)
@ -574,7 +569,7 @@
(list account)))))))
;; Print error message for duplicate txf codes and accounts
(define (txf-print-dups)
(define (txf-print-dups doc)
(let ((dups (apply append
(map (lambda (x)
(let ((cnt (length (cdr x))))
@ -589,16 +584,21 @@
(map gnc:account-get-full-name
(cdr x))))
'())))
txf-dups-alist))))
txf-dups-alist)))
(text (gnc:make-html-text)))
(if (not (null? dups))
(cons
(html-para
(html-blue
(begin
(gnc:html-text-set-style! text 'font-color "#0000ff")
(gnc:html-document-add-object! doc text)
(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\
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
(define (txf-special-split? code)
@ -748,15 +748,13 @@
(define (generate-tax-or-txf report-name
report-description
options
report-obj
tax-mode-in)
;; These are some helper functions for looking up option values.
(define (get-op section name)
(gnc:lookup-option options section name))
(define (op-value section name)
(gnc:option-value (get-op section name)))
(define (get-option pagename optname)
(gnc:option-value
(gnc:lookup-option
(gnc:report-options report-obj) pagename optname)))
;; the number of account generations: children, grandchildren etc.
(define (num-generations account gen)
@ -774,16 +772,16 @@
report-name))
(tab-title (if hierarchical? hierarchical-tab-title tax-tab-title))
(from-value (gnc:date-option-absolute-time
(op-value tab-title "From")))
(get-option tab-title "From")))
(to-value (gnc:timepair-end-day-time
(gnc:date-option-absolute-time
(op-value tab-title "To"))))
(alt-period (op-value tab-title "Alternate Period"))
(suppress-0 (op-value tab-title "Suppress $0.00 values"))
(full-names (op-value tab-title
(get-option tab-title "To"))))
(alt-period (get-option tab-title "Alternate Period"))
(suppress-0 (get-option tab-title "Suppress $0.00 values"))
(full-names (get-option tab-title
"Print Full account names"))
(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)"))
(valid-user-sel-accnts (validate user-sel-accnts hierarchical?))
;; If no selected accounts, check all.
@ -872,10 +870,13 @@
(set! bdtm (gnc:timepair->date to-value)))))
(cons (car (mktime bdtm)) 0))))
(txf-help (if hierarchical? #f
(op-value "TXF Export Init" "Print extended TXF HELP\
messages")))
(txf-feedback-str-lst '()))
(txf-help
(if hierarchical? #f
(get-option "TXF Export Init"
"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)
(if (and (gnc:account-get-txf account)
@ -889,7 +890,7 @@
(equal? (strftime "%m%d" (localtime (car to-value)))
"1231")))
;; Adjust dates so we get the final Estimated Tax
;; paynemt from the right year
;; paymnent from the right year
(from-est (if full-year?
(let ((bdtm (gnc:timepair->date
(gnc:timepair-canonical-day-time
@ -990,17 +991,19 @@
'())))
(if (not hierarchical?)
(let* ((tax-stat (op-value tab-title "Set/Reset Tax Status"))
(txf-acc-lst (op-value "TXF Export Init" "Select Account"))
(let* ((tax-stat (get-option tab-title "Set/Reset Tax Status"))
(txf-acc-lst (get-option "TXF Export Init" "Select Account"))
(txf-account (if (null? txf-acc-lst)
(begin (set! txf-acc-lst '(#f))
#f)
(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"))
(txf-expense (op-value "TXF Export Init" "For EXPENSE\
(txf-expense (get-option "TXF Export Init"
"For EXPENSE\
accounts, select here. < ^ # see help"))
(txf-payer-source (op-value "TXF Export Init"
(txf-payer-source (get-option "TXF Export Init"
"< ^ Payer Name source"))
(txf-full-name-lst (if txf-account
(map gnc:account-get-full-name
@ -1036,7 +1039,7 @@
(report-title (if txf-help
(_ "Detailed TXF Category Descriptions")
report-name))
(file-name "????"))
(file-name #f))
;; Now, the main body
;; Reset all the balance collectors
@ -1070,13 +1073,14 @@
(if file-name ; cancel TXF if no file selected
(let* ((port (open-output-file file-name))
(output (list
(map (lambda (x) (handle-level-x-account
1 x))
(output
(list
(map (lambda (x) (handle-level-x-account 1 x))
selected-accounts)))
(output-txf (list
"V035"
"\nAGnuCash 1.5.2"
"\nAGnuCash "
gnc:version
"\n" today-date
"\n^"
output)))
@ -1098,49 +1102,73 @@
(map (lambda (x) (handle-level-x-account 1 x))
selected-accounts))))
(list ; Tax
"<html>"
"<head>"
"<title>" report-title "</title>"
"</head>\n"
"<body bgcolor=" bg-color ">"
"<center>"
"<h1>" report-title "</h1>\n"
"<p>"
(if txf-help
""
(html-black (string-append (_ "Period From:") " "
from-date " "
(_ "To:") " "
to-date)))
"</p>\n"
"<p>"
(html-blue (if hierarchical?
""
(gnc:html-document-set-title! doc report-title)
(gnc:html-document-set-style!
doc "body"
'attribute (list "bgcolor" bg-color)
'tag "center")
(gnc:html-document-add-object!
doc
(gnc:make-html-text
(gnc:html-markup-p
(gnc:html-markup/format
(_ "Period from %s to %s") from-date to-date))))
(let ((text (gnc:make-html-text)))
(gnc:html-text-set-style! text 'font-color "#0000ff")
(gnc:html-document-add-object! doc text)
(if (not hierarchical?)
(if tax-mode-in
(if txf-help
""
(_ "Blue items are exportable to a TXF file"))
(if (not txf-help)
(gnc:html-text-append!
text
(gnc:html-markup-p
(_ "Blue items are exportable to a TXF file."))))
(gnc:html-text-append!
text
(gnc:html-markup-p
(if file-name
(string-append
(_ "Blue items were exported to file: \"")
file-name "\"")
(_ "Blue items were <b>NOT</b> exported to \
txf file!")))))
"</p>\n"
"</center>"
(if (or hierarchical? txf-help)
""
(map html-para (map html-blue txf-feedback-str-lst)))
(txf-print-dups)
"<table " (if txf-help "border=1 " "border=0 ") "cellpadding=1>"
"<tr>"
"<th>"
(gnc:html-markup/format
(_ "Blue items were exported to file %s.")
(gnc:html-markup-tt file-name))
(_ "Blue items were <em>not</em> exported to \
txf file!"))))))
(if (not (or hierarchical? txf-help))
(map (lambda (s)
(gnc:html-text-append! text (gnc:html-markup-p s)))
txf-feedback-str-lst)))
(txf-print-dups doc)
(gnc:html-document-add-object! doc table)
(if txf-help
(list (_ "Tax Form \\ TXF Code") "<br>"
(gnc:html-table-set-style! 'attribute (list "border" "1")))
(if txf-help
(gnc:html-table-append-row!
table
(list
(gnc:make-html-table-header-cell
(_ "Tax Form \\ TXF Code")
(gnc:html-markup-br)
(_ "Description"))
(_ "Account Name"))
"</th>\n"
(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))
@ -1152,8 +1180,6 @@ txf file!")))))
(list "<th>" (_ "Extended TXF Help messages")
(html-blue " Income") (html-red " Expense"))
(list "<th align=right>" (_ "Total")))
"</th>\n"
"</tr>\n"
output
"</table>\n"
(if (null? (car output))
@ -1167,45 +1193,45 @@ txf file!")))))
" ")
"</body>"
"</html>")
)))
doc)))
;; copy help strings to catagory structures.
;; copy help strings to category structures.
(txf-help txf-income-catagories)
(txf-help txf-expense-catagories)
(txf-help txf-help-catagories)
(gnc:define-report
'version 1
'name (N_ "Hierarchical")
'options-generator hierarchical-options-generator
'renderer (lambda (options)
(generate-tax-or-txf
(_ "Hierarchical Accounts Report")
(_ "This page shows your Taxable Income and \
Deductable Expenses.")
options
#t)))
; (gnc:define-report
; 'version 1
; 'name (N_ "Hierarchical")
; 'options-generator hierarchical-options-generator
; 'renderer (lambda (report-obj)
; (generate-tax-or-txf
; (_ "Hierarchical Accounts Report")
; (_ "This page shows your Taxable Income and \
;Deductable Expenses.")
; report-obj
; #t)))
(gnc:define-report
'version 1
'name (N_ "Tax")
'options-generator tax-options-generator
'renderer (lambda (options)
'renderer (lambda (report-obj)
(generate-tax-or-txf
(_ "Taxable Income / Deductible Expenses")
(_ "This page shows your Taxable Income and \
Deductable Expenses.")
options
report-obj
#t)))
(gnc:define-report
'version 1
'name (N_ "Export .TXF")
'options-generator tax-options-generator
'renderer (lambda (options)
'renderer (lambda (report-obj)
(generate-tax-or-txf
(_ "Taxable Income / Deductible Expenses")
(_ "This page shows your Taxable Income and \
Deductable Expenses.")
options
report-obj
#f))))