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

2001-04-28 Christian Stimming <stimming@tuhh.de>

Browse Source 
* src/scm/date-utilities.scm: Fixed a whole lot of bugs in the
	relative-date functions (did *nobody* ever test those???). Added
	relative dates end-cal-year, end-current-quarter, and
	end-this-month. Added comments.

	* src/scm/options-utilities.scm: Changed date-options to be combo
	options of both relative and absolute dates.

	* src/scm/report/portfolio.scm, taxtxf.scm: adapt to usual option
	conventions.

	* src/scm/report/account-summary.scm: Fix bug.


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@4079 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas 2001-04-30 01:23:18 +00:00
parent 421fc9542e
commit 47d926b814
6 changed files with 199 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
ChangeLog
View File

@ -1,3 +1,18 @@
2001-04-28 Christian Stimming <stimming@tuhh.de>
* src/scm/date-utilities.scm: Fixed a whole lot of bugs in the
relative-date functions (did *nobody* ever test those???). Added
relative dates end-cal-year, end-current-quarter, and
end-this-month. Added comments.
* src/scm/options-utilities.scm: Changed date-options to be combo
options of both relative and absolute dates.
* src/scm/report/portfolio.scm, taxtxf.scm: adapt to usual option
conventions.
* src/scm/report/account-summary.scm: Fix bug.
2001-04-27 Christian Stimming <stimming@tuhh.de>
* src/scm/report/balance-sheet.scm: Added workaround for gtkhtml

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

@ -374,6 +374,16 @@
(set-tm:isdst now -1)
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-end-cal-year)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now 31)
(set-tm:mon now 11)
(set-tm:isdst now -1)
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-start-prev-year)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
@ -449,6 +459,7 @@
(set-tm:hour now 23)
(set-tm:mday now 30)
(set-tm:mon now 5)
(set-tm:year now (- (tm:year now) 1))
(set-tm:isdst now -1)
(cons (car (mktime now)) 0))
(begin
@ -457,7 +468,6 @@
(set-tm:hour now 23)
(set-tm:mday now 30)
(set-tm:mon now 5)
(set-tm:year now (- (tm:year now) 1))
(set-tm:isdst now -1)
(cons (car (mktime now)) 0)))))
@ -470,6 +480,16 @@
(set-tm:isdst now -1)
(cons (car (mktime now)) 0)))
(define (gnc:get-end-this-month)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(cons (car (mktime now)) 0)))
(define (gnc:get-start-prev-month)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
@ -489,12 +509,13 @@
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (= (tm:month now 0))
(if (= (tm:mon now) 0)
(begin
(set-tm:month now 11)
(set-tm:mon now 11)
(set-tm:year (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now) 1)))
(set-tm:mday (gnc:days-in-month (+ (tm:month now) 1)) (+ (tm:year) 1900))
(set-tm:mon now (- (tm:mon now) 1)))
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(cons (car (mktime now)) 0)))
@ -504,38 +525,50 @@
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:month now (- (tm:month now) (mod (tm:month now) 3)))
(set-tm:mon now (- (tm:mon now) (modulo (tm:mon now) 3)))
(set-tm:isdst now -1)
(cons (car (mktime now)) 0)))
(define (gnc:get-end-current-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(set-tm:mon now (+ (tm:mon now)
(- 2 (modulo (tm:mon now) 3))))
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(gnc:secs->timepair (car (mktime now)))))
(define (gnc:get-start-prev-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 0)
(set-tm:min now 0)
(set-tm:hour now 0)
(set-tm:mday now 1)
(set-tm:month now (- (tm:month now) (mod (tm:month now) 3)))
(if (= (tm:month now) 0)
(set-tm:mon now (- (tm:mon now) (modulo (tm:mon now) 3)))
(if (= (tm:mon now) 0)
(begin
(set-tm:month now 9)
(set-tm:mon now 9)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm-month now) 3)))
(set-tm:mon now (- (tm:mon now) 3)))
(set-tm:isdst now -1)
(cons (car (mktime now) 0))))
(cons (car (mktime now)) 0)))
(define (gnc:get-end-prev-quarter)
(let ((now (localtime (current-time))))
(set-tm:sec now 59)
(set-tm:min now 59)
(set-tm:hour now 23)
(if (< (tm:month now) 3)
(if (< (tm:mon now) 3)
(begin
(set-tm:month now 11)
(set-tm:mon now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now)
(3 + (mod (tm:month now) 3)))))
(set-tm:mday now (gnc:days-in-month (+ (tm:month now) 1)
(+ (tm:year) 1900)))
(set-tm:mon now (- (tm:mon now)
(+ 1 (modulo (tm:mon now) 3)))))
(set-tm:mday now (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(set-tm:isdst now -1)
(gnc:secs->timepair (car (mktime now)))))
@ -544,12 +577,12 @@
(define (gnc:get-one-month-ago)
(let ((now (localtime (current-time))))
(if (= (tm:month now) 0)
(if (= (tm:mon now) 0)
(begin
(set-tm:month now 11)
(set-tm:mon now 11)
(set-tm:year now (- (tm:year now) 1)))
(set-tm:month now (- (tm:month now) 1)))
(let ((month-length (gnc:days-in-month (+ (tm:month now) 1)
(set-tm:mon now (- (tm:mon now) 1)))
(let ((month-length (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900))))
(if (> month-length (tm:mday now))
(set-tm:mday now month-length))
@ -558,12 +591,12 @@
(define (gnc:get-three-months-ago)
(let ((now (localtime (current-time))))
(if (< (tm:month now) 3)
(if (< (tm:mon now) 3)
(begin
(set:tm-month now (+ (tm:month now) 12))
(set:tm-month now (+ (tm:mon now) 12))
(set:tm-year now (- (tm:year now) 1))))
(set:tm-month now (- (tm:month now) 3))
(let ((month-days) (gnc:days-in-month (+ (tm:month now) 1)
(set:tm-month now (- (tm:mon now) 3))
(let ((month-days) (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
@ -572,12 +605,12 @@
(define (gnc:get-six-months-ago)
(let ((now (localtime (current-time))))
(if (< (tm:month now) 6)
(if (< (tm:mon now) 6)
(begin
(set:tm-month now (+ (tm:month now) 12))
(set:tm-month now (+ (tm:mon now) 12))
(set:tm-year now (- (tm:year now) 1))))
(set:tm-month now (- (tm:month now) 6))
(let ((month-days) (gnc:days-in-month (+ (tm:month now) 1)
(set:tm-month now (- (tm:mon now) 6))
(let ((month-days) (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
@ -587,13 +620,24 @@
(define (gnc:get-one-year-ago)
(let ((now (localtime (current-time))))
(set:tm-year now (- (tm:year now) 1))
(let ((month-days) (gnc:days-in-month (+ (tm:month now) 1)
(let ((month-days) (gnc:days-in-month (+ (tm:mon now) 1)
(+ (tm:year now) 1900)))
(if (> (month-days) (tm:mday now))
(set-tm:mday now month-days))
(set-tm:isdst now -1)
(gnc:secs->timepair (car (mktime now))))))
;; There is no GNC:RELATIVE-DATES list like the one mentioned in
;; gnucash-design.info, is there? Here are the currently defined
;; items, loosely grouped.
;;today
;;start-cal-year end-cal-year start-prev-year end-prev-year
;;start-this-month end-this-month start-prev-month end-prev-month
;;start-current-quarter end-current-quarter start-prev-quarter
;;end-prev-quarter
;;one-month-ago three-months-ago six-months-ago one-year-ago
;;start-cur-fin-year start-prev-fin-year end-prev-fin-year
(define (gnc:reldate-initialize)
(begin
(gnc:reldate-string-db
@ -602,97 +646,135 @@
(gnc:reldate-string-db
'store 'start-cal-year-desc
(N_ "Start of the current calendar year"))
(gnc:reldate-string-db
'store 'end-cal-year-string
(N_ "Current Year End"))
(gnc:reldate-string-db
'store 'end-cal-year-desc
(N_ "End of the current calendar year"))
(gnc:reldate-string-db
'store 'start-prev-year-string
(N_ "Previous Year Start"))
(gnc:reldate-string-db
'store 'start-prev-year-desc
(N_ "Beginning of the previous calendar year"))
(gnc:reldate-string-db
'store 'end-prev-year-string
(N_ "Previous Year End"))
(gnc:reldate-string-db
'store 'end-prev-year-desc
(N_ "End of the Previous Year"))
(gnc:reldate-string-db
'store 'start-cur-fin-year-string
(N_ "Current Financial Year Start"))
(gnc:reldate-string-db
'store 'start-cur-fin-year-desc
(N_ "Start of the current financial year/accounting period"))
(gnc:reldate-string-db
'store 'start-prev-fin-year-string
(N_ "Previous Financial Year Start"))
(gnc:reldate-string-db
'store 'start-prev-fin-year-desc
(N_ "The start of the previous financial year/accounting period"))
(gnc:reldate-string-db
'store 'end-prev-fin-year-string
(N_ "End Previous Financial Year"))
(gnc:reldate-string-db
'store 'end-prev-fin-year-desc
(N_ "End of the previous Financial year/Accounting Period"))
(gnc:reldate-string-db
'store 'start-this-month-string
(N_ "Start of this month"))
(gnc:reldate-string-db
'store 'start-this-month-desc
(N_ "Start of the current month"))
(gnc:reldate-string-db
'store 'end-this-month-string
(N_ "End of this month"))
(gnc:reldate-string-db
'store 'end-this-month-desc
(N_ "End of the current month"))
(gnc:reldate-string-db
'store 'start-prev-month-string
(N_ "Start of previous month"))
(gnc:reldate-string-db
'store 'start-prev-month-desc
(N_ "The beginning of the previous month"))
(gnc:reldate-string-db
'store 'end-prev-month-string
(N_ "End of previous month"))
(gnc:reldate-string-db
'store 'end-prev-month-desc
(N_ "Last day of previous month"))
(gnc:reldate-string-db
'store 'start-current-quarter-string
(N_ "Start of current quarter"))
(gnc:reldate-string-db
'store 'start-current-quarter-desc
(N_ "The start of the latest quarterly accounting period"))
(gnc:reldate-string-db
'store 'end-current-quarter-string
(N_ "End of current quarter"))
(gnc:reldate-string-db
'store 'end-current-quarter-desc
(N_ "The end of the latest quarterly accounting period"))
(gnc:reldate-string-db
'store 'start-prev-quarter-string
(N_ "Start of previous quarter"))
(gnc:reldate-string-db
'store 'start-prev-quarter-desc
(N_ "The start of the previous quarterly accounting period"))
(gnc:reldate-string-db
'store 'end-prev-quarter-string
(N_ "End of previous quarter"))
(gnc:reldate-string-db
'store 'end-prev-quarter-desc
(N_ "End of previous quarterly accounting period"))
(gnc:reldate-string-db
'store 'today-string
(N_ "Today"))
(gnc:reldate-string-db
'store 'today-desc (N_ "The current date"))
(gnc:reldate-string-db
'store 'one-month-ago-string
(N_ "One Month Ago"))
(gnc:reldate-string-db
'store 'one-month-ago-desc (N_ "One Month Ago"))
(gnc:reldate-string-db
'store 'one-week-ago-string
(N_ "One Week Ago"))
(gnc:reldate-string-db
'store 'one-week-ago-desc (N_ "One Week Ago"))
(gnc:reldate-string-db
'store 'three-months-ago-string
(N_ "Three Months Ago"))
(gnc:reldate-string-db
'store 'three-months-ago-desc (N_ "Three Months Ago"))
(gnc:reldate-string-db
'store 'six-months-ago-string
(N_ "Six Months Ago"))
(gnc:reldate-string-db
'store 'six-months-ago-desc (N_ "Six Months Ago"))
(gnc:reldate-string-db
'store 'one-year-ago-string (N_ "One Year Ago"))
(gnc:reldate-string-db
@ -704,6 +786,10 @@
(gnc:reldate-string-db 'lookup 'start-cal-year-string)
(gnc:reldate-string-db 'lookup 'start-cal-year-desc)
gnc:get-start-cal-year)
(vector 'end-cal-year
(gnc:reldate-string-db 'lookup 'end-cal-year-string)
(gnc:reldate-string-db 'lookup 'end-cal-year-desc)
gnc:get-end-cal-year)
(vector 'start-prev-year
(gnc:reldate-string-db 'lookup 'start-prev-year-string)
(gnc:reldate-string-db 'lookup 'start-prev-year-desc)
@ -728,6 +814,10 @@
(gnc:reldate-string-db 'lookup 'start-this-month-string)
(gnc:reldate-string-db 'lookup 'start-this-month-desc)
gnc:get-start-this-month)
(vector 'end-this-month
(gnc:reldate-string-db 'lookup 'end-this-month-string)
(gnc:reldate-string-db 'lookup 'end-this-month-desc)
gnc:get-end-this-month)
(vector 'start-prev-month
(gnc:reldate-string-db 'lookup 'start-prev-month-string)
(gnc:reldate-string-db 'lookup 'start-prev-month-desc)
@ -740,6 +830,10 @@
(gnc:reldate-string-db 'lookup 'start-current-quarter-string)
(gnc:reldate-string-db 'lookup 'start-current-quarter-desc)
gnc:get-start-current-quarter)
(vector 'end-current-quarter
(gnc:reldate-string-db 'lookup 'end-current-quarter-string)
(gnc:reldate-string-db 'lookup 'end-current-quarter-desc)
gnc:get-end-current-quarter)
(vector 'start-prev-quarter
(gnc:reldate-string-db 'lookup 'start-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'start-prev-quarter-desc)
@ -749,8 +843,8 @@
(gnc:reldate-string-db 'lookup 'end-prev-quarter-desc)
gnc:get-end-prev-quarter)
(vector 'today
(gnc:reldate-string-db 'lookup 'end-prev-quarter-string)
(gnc:reldate-string-db 'lookup 'end-prev-quarter-desc)
(gnc:reldate-string-db 'lookup 'today-string)
(gnc:reldate-string-db 'lookup 'today-desc)
gnc:get-today)
(vector 'one-month-ago
(gnc:reldate-string-db 'lookup 'one-month-ago-string)

42
src/scm/options-utilities.scm
View File

@ -36,12 +36,17 @@
(gnc:make-date-option
pagename optname
sort-tag (N_ "Select a date to report on")
(lambda ()
(cons 'absolute
(gnc:timepair-end-day-time
(gnc:secs->timepair
(car (mktime (localtime (current-time))))))))
#f 'absolute #f)))
(lambda ()
; (cons 'absolute
; (gnc:secs->timepair
; (car (mktime (localtime (current-time)))))))
(cons 'relative 'today))
#f 'both
'(end-cal-year end-current-quarter end-this-month
today end-prev-month end-prev-quarter
end-prev-year ;;end-prev-fin-year
))))
;; This is a date-interval for a report.
(define (gnc:options-add-date-interval!
@ -52,22 +57,26 @@
pagename name-from
(string-append sort-tag "a")
(N_ "Start of reporting period")
(lambda ()
(cons 'absolute
(gnc:get-start-cal-year)))
#f 'absolute #f))
(lambda () (cons 'relative 'start-cal-year))
#f 'both
'(start-this-month start-prev-month start-current-quarter
start-prev-quarter start-cal-year
;;start-cur-fin-year
start-prev-year
;;start-prev-fin-year
)))
(gnc:register-option
options
(gnc:make-date-option
pagename name-to
(string-append sort-tag "b")
(N_ "End of reporting period")
(lambda ()
(cons 'absolute
(gnc:timepair-end-day-time
(gnc:secs->timepair
(car (mktime (localtime (current-time))))))))
#f 'absolute #f)))
(lambda () (cons 'relative 'today))
#f 'both
'(end-cal-year end-current-quarter end-this-month
today end-prev-month end-prev-quarter end-prev-year
;;end-prev-fin-year
))))
;; A date interval multichoice option.
(define (gnc:options-add-interval-choice!
@ -81,6 +90,7 @@
(vector 'WeekDelta (N_ "Week") (N_ "Week"))
(vector 'TwoWeekDelta (N_ "2Week") (N_ "Two Week"))
(vector 'MonthDelta (N_ "Month") (N_ "Month"))
;; FIXME: how about quarters here?
(vector 'YearDelta (N_ "Year") (N_ "Year"))
))))

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

@ -168,7 +168,7 @@
(gnc:html-document-add-object!
doc ;;(gnc:html-markup-p
(gnc:html-make-exchangerates
report-currency exchange-alist accounts #f)));;)
report-currency exchange-fn accounts)));;)
;; error condition: no accounts specified
(let ((p (gnc:make-html-text)))

23
src/scm/report/portfolio.scm
View File

@ -17,17 +17,14 @@
(lambda (new-option)
(gnc:register-option options new-option))))
(add-option
(gnc:make-date-option
(N_ "General") (N_ "Date")
"a"
(N_ "Date to report on")
(lambda () (cons 'absolute (cons (current-time) 0)))
#f 'absolute #f ))
;; date at which to report balance
(gnc:options-add-report-date!
options gnc:pagename-general
(N_ "Date") "a")
(add-option
(gnc:make-account-list-option
(N_ "General") (N_ "Accounts")
gnc:pagename-accounts (N_ "Accounts")
"b"
(N_ "Stock Accounts to report on")
(lambda () (filter gnc:account-is-stock?
@ -37,9 +34,9 @@
#t))
(gnc:options-add-currency!
options (N_ "General") (N_ "Report Currency") "c")
options gnc:pagename-general (N_ "Report Currency") "c")
(gnc:options-set-default-section options "General")
(gnc:options-set-default-section options gnc:pagename-general)
options))
;; This is the rendering function. It accepts a database of options
@ -106,9 +103,9 @@
;; options in the set of options given to the function. This set will
;; be generated by the options generator above.
(let ((to-date (gnc:date-option-absolute-time
(op-value "General" "Date")))
(accounts (op-value "General" "Accounts"))
(currency (op-value "General" "Report Currency"))
(op-value gnc:pagename-general "Date")))
(accounts (op-value gnc:pagename-accounts "Accounts"))
(currency (op-value gnc:pagename-general "Report Currency"))
(collector (gnc:make-commodity-collector))
;; document will be the HTML document that we return.
(table (gnc:make-html-table))

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

@ -80,41 +80,19 @@
;; This is the year it is effective. THIS IS A Y10K BUG!
(define tax-qtr-real-qtr-year 10000)
(define tax-tab-title (N_ "TAX Report Options"))
(define (tax-options-generator)
(options-generator tax-tab-title))
(define (options-generator tab-title)
(define gnc:*tax-report-options* (gnc:new-options))
(define options (gnc:new-options))
(define (gnc:register-tax-option new-option)
(gnc:register-option gnc:*tax-report-options* new-option))
(gnc:register-option options new-option))
(gnc:register-tax-option
(gnc:make-date-option
tab-title (N_ "From")
"a" (N_ "Start of reporting period")
(lambda ()
(let ((bdtm (gnc:timepair->date (gnc:timepair-canonical-day-time
(cons (current-time) 0)))))
(set-tm:mday bdtm 1) ; 01
(set-tm:mon bdtm 0) ; Jan
(set-tm:isdst bdtm -1)
(cons 'absolute (cons (car (mktime bdtm)) 0))))
#f 'absolute #f))
(gnc:register-tax-option
(gnc:make-date-option
tab-title (N_ "To")
"b" (N_ "End of reporting period")
(lambda ()
(cons 'absolute (gnc:timepair-canonical-day-time
(cons (current-time) 0))))
#f 'absolute #f))
;; date at which to report
(gnc:options-add-date-interval!
options gnc:pagename-general
(N_ "From") (N_ "To") "a")
(gnc:register-tax-option
(gnc:make-multichoice-option
tab-title (N_ "Alternate Period")
gnc:pagename-general (N_ "Alternate Period")
"c" (N_ "Overide or modify From: & To:") 'from-to
(list (list->vector
(list 'from-to (N_ "Use From - To") (N_ "Use From - To period")))
@ -143,22 +121,24 @@
(gnc:register-tax-option
(gnc:make-account-list-option
tab-title (N_ "Select Accounts (none = all)")
gnc:pagename-accounts (N_ "Select Accounts (none = all)")
"d" (N_ "Select accounts")
(lambda () '())
#f #t))
(gnc:register-tax-option
(gnc:make-simple-boolean-option
tab-title (N_ "Suppress $0.00 values")
gnc:pagename-display (N_ "Suppress $0.00 values")
"f" (N_ "$0.00 valued Accounts won't be printed.") #t))
(gnc:register-tax-option
(gnc:make-simple-boolean-option
tab-title (N_ "Print Full account names")
gnc:pagename-display (N_ "Print Full account names")
"g" (N_ "Print all Parent account names") #f))
gnc:*tax-report-options*)
(gnc:options-set-default-section options gnc:pagename-general)
options)
;; Render txf information
(define txf-last-payer #f) ; if same as current, inc txf-l-count
@ -392,17 +372,17 @@
(lambda (x) (num-generations x (+ 1 gen)))
children)))))
(let* ((tab-title tax-tab-title)
(from-value (gnc:date-option-absolute-time
(get-option tab-title "From")))
(let* ((from-value (gnc:date-option-absolute-time
(get-option gnc:pagename-general "From")))
(to-value (gnc:timepair-end-day-time
(gnc:date-option-absolute-time
(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
(get-option gnc:pagename-general "To"))))
(alt-period (get-option gnc:pagename-general "Alternate Period"))
(suppress-0 (get-option gnc:pagename-display
"Suppress $0.00 values"))
(full-names (get-option gnc:pagename-display
"Print Full account names"))
(user-sel-accnts (get-option tab-title
(user-sel-accnts (get-option gnc:pagename-accounts
"Select Accounts (none = all)"))
(valid-user-sel-accnts (validate user-sel-accnts))
;; If no selected accounts, check all.