mirror of
https://github.com/Gnucash/gnucash.git
synced 2024-11-30 20:54:08 -06:00
Merge branch 'christopherlam-maint-bugfixes' into maint
This commit is contained in:
Christopher Lam
commit
817c3f4d6a
@ -647,11 +647,15 @@ gnc_ui_start_event_loop (void)
|
||||
id = g_timeout_add_full (G_PRIORITY_DEFAULT_IDLE, 10000, /* 10 secs */
|
||||
gnc_ui_check_events, NULL, NULL);
|
||||
|
||||
scm_call_1(scm_c_eval_string("gnc:set-ui-status"), SCM_BOOL_T);
|
||||
|
||||
/* Enter gnome event loop */
|
||||
gtk_main ();
|
||||
|
||||
g_source_remove (id);
|
||||
|
||||
scm_call_1(scm_c_eval_string("gnc:set-ui-status"), SCM_BOOL_F);
|
||||
|
||||
gnome_is_running = FALSE;
|
||||
gnome_is_terminating = FALSE;
|
||||
|
||||
|
||||
@ -41,3 +41,27 @@
|
||||
|
||||
(load-from-path "gnc-menu-extensions")
|
||||
|
||||
;; this function will receive 1 boolean argument, and can be used for
|
||||
;; any UI init/shutdown routines. For now it will set the
|
||||
;; gnc:ui-warn/error/msg tracefile routines to display dialog messages
|
||||
;; in addition to tracefile logging.
|
||||
(define-public gnc:set-ui-status
|
||||
(let ((save-warn gnc:gui-warn)
|
||||
(save-error gnc:gui-error)
|
||||
(save-msg gnc:gui-msg))
|
||||
(lambda (status)
|
||||
(cond
|
||||
(status
|
||||
(set! gnc:gui-warn (lambda (constr guistr)
|
||||
(save-warn constr guistr)
|
||||
(gnc-warning-dialog '() guistr)))
|
||||
(set! gnc:gui-error (lambda (constr guistr)
|
||||
(save-error constr guistr)
|
||||
(gnc-error-dialog '() guistr)))
|
||||
(set! gnc:gui-msg (lambda (constr guistr)
|
||||
(save-msg constr guistr)
|
||||
(gnc-info-dialog '() guistr))))
|
||||
(else
|
||||
(set! gnc:gui-warn save-warn)
|
||||
(set! gnc:gui-error save-error)
|
||||
(set! gnc:gui-msg save-msg))))))
|
||||
|
||||
@ -346,7 +346,7 @@ by preventing negative stock balances.<br/>")
|
||||
(not (gnc-numeric-zero-p b-value)))
|
||||
(let* ((current-value (sum-basis b-list GNC-DENOM-AUTO))
|
||||
(value-ratio (if (zero? current-value)
|
||||
(throw 'div/0 (format #f "spinoff of ~0,2f currency units" current-value))
|
||||
(throw 'div/0 (format #f "spinoff of ~,2f currency units" current-value))
|
||||
(gnc-numeric-div (gnc-numeric-add b-value current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE)
|
||||
current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE))))
|
||||
|
||||
@ -955,7 +955,7 @@ by preventing negative stock balances.<br/>")
|
||||
)
|
||||
(if (= 0.0 moneyinvalue)
|
||||
""
|
||||
(format #f "~0,2f%" (* 100 (/ bothgainvalue moneyinvalue)))))
|
||||
(format #f "~,2f%" (* 100 (/ bothgainvalue moneyinvalue)))))
|
||||
)
|
||||
(gnc:make-html-table-header-cell/markup "number-cell" income)))
|
||||
(if (not (eq? handle-brokerage-fees 'ignore-brokerage))
|
||||
@ -969,7 +969,7 @@ by preventing negative stock balances.<br/>")
|
||||
)
|
||||
(if (= 0.0 moneyinvalue)
|
||||
""
|
||||
(format #f "~0,2f%" (* 100 (/ totalreturnvalue moneyinvalue))))))
|
||||
(format #f "~,2f%" (* 100 (/ totalreturnvalue moneyinvalue))))))
|
||||
)
|
||||
)
|
||||
|
||||
@ -1160,7 +1160,7 @@ by preventing negative stock balances.<br/>")
|
||||
)
|
||||
(if (= 0.0 totalinvalue)
|
||||
""
|
||||
(format #f "~0,2f%" (* 100 (/ totalgainvalue totalinvalue))))))
|
||||
(format #f "~,2f%" (* 100 (/ totalgainvalue totalinvalue))))))
|
||||
(gnc:make-html-table-cell/markup
|
||||
"total-number-cell" sum-total-income)))
|
||||
(if (not (eq? handle-brokerage-fees 'ignore-brokerage))
|
||||
@ -1179,7 +1179,7 @@ by preventing negative stock balances.<br/>")
|
||||
)
|
||||
(if (= 0.0 totalinvalue)
|
||||
""
|
||||
(format #f "~0,2f%" (* 100 (/ totalreturnvalue totalinvalue))))))
|
||||
(format #f "~,2f%" (* 100 (/ totalreturnvalue totalinvalue))))))
|
||||
))
|
||||
|
||||
|
||||
|
||||
@ -705,18 +705,22 @@ developing over time"))
|
||||
(gnc:report-percent-done 98)
|
||||
(gnc:html-document-add-object! document chart)
|
||||
(if show-table?
|
||||
(begin
|
||||
(let ((scu (gnc-commodity-get-fraction report-currency)))
|
||||
(gnc:html-table-append-column! table date-string-list)
|
||||
|
||||
(letrec
|
||||
((addcol
|
||||
(lambda (col)
|
||||
(if (not (null? col))
|
||||
(begin
|
||||
(gnc:html-table-append-column!
|
||||
table (car col))
|
||||
(addcol (cdr col)))))))
|
||||
(addcol (map cadr all-data)))
|
||||
(for-each
|
||||
(lambda (col)
|
||||
(gnc:html-table-append-column!
|
||||
table
|
||||
(map
|
||||
(lambda (mon)
|
||||
(gnc:make-gnc-monetary
|
||||
report-currency
|
||||
(gnc-numeric-convert
|
||||
(gnc:gnc-monetary-amount mon)
|
||||
scu GNC-HOW-RND-ROUND)))
|
||||
col)))
|
||||
(map cadr all-data))
|
||||
|
||||
(gnc:html-table-set-col-headers!
|
||||
table
|
||||
|
||||
@ -34,6 +34,7 @@
|
||||
(use-modules (gnucash utilities))
|
||||
(use-modules (gnucash gnc-module))
|
||||
(use-modules (gnucash gettext))
|
||||
(use-modules (gnucash report standard-reports transaction))
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
@ -51,10 +52,8 @@
|
||||
;; options generator
|
||||
|
||||
(define (general-ledger-options-generator)
|
||||
|
||||
(let* ((options (gnc:report-template-new-options/report-guid xactrptguid xactrptname))
|
||||
)
|
||||
|
||||
(let* ((options (trep-options-generator)))
|
||||
|
||||
(define pagename-sorting (N_ "Sorting"))
|
||||
(define (set-option! section name value)
|
||||
(gnc:option-set-default-value
|
||||
|
||||
@ -68,6 +68,7 @@
|
||||
(null-test income-report-uuid)
|
||||
(null-test expense-report-uuid)
|
||||
(single-txn-test income-report-uuid)
|
||||
(single-txn-test-average income-report-uuid)
|
||||
(multi-acct-test expense-report-uuid))
|
||||
|
||||
(define (run-category-asset-liability-test asset-report-uuid liability-report-uuid)
|
||||
@ -76,6 +77,9 @@
|
||||
(asset-test asset-report-uuid)
|
||||
(liability-test liability-report-uuid))
|
||||
|
||||
(define (teardown)
|
||||
(gnc-clear-current-session))
|
||||
|
||||
;; No real test here, just confirm that no exceptions are thrown
|
||||
(define (null-test uuid)
|
||||
(let ((options (gnc:make-report-options uuid)))
|
||||
@ -113,7 +117,101 @@
|
||||
(str->num (cadr (string-split s #\/))))
|
||||
(sxml->table-row-col sxml 1 #f 1))
|
||||
(map str->num (sxml->table-row-col sxml 1 #f 2))))
|
||||
(test-end "single-txn-test"))))
|
||||
(test-end "single-txn-test"))
|
||||
(teardown)))
|
||||
|
||||
(define (single-txn-test-average uuid)
|
||||
(let* ((income-options (gnc:make-report-options uuid))
|
||||
(env (create-test-env))
|
||||
(curr (gnc-default-report-currency))
|
||||
(my-asset-account (env-create-root-account env ACCT-TYPE-ASSET curr))
|
||||
(my-expense-account (env-create-root-account env ACCT-TYPE-EXPENSE curr))
|
||||
(my-income-account (env-create-root-account env ACCT-TYPE-INCOME curr)))
|
||||
;; create 52 weekly txns from 1.1.1980, amount $1.10 increase by $1.10 weekly
|
||||
(let loop ((date (gnc-dmy2time64 1 1 1980))
|
||||
(amt 11/10)
|
||||
(remaining 52))
|
||||
(unless (zero? remaining)
|
||||
(env-create-transaction env date my-asset-account my-income-account amt)
|
||||
(loop (incdate date WeekDelta)
|
||||
(+ amt 11/10)
|
||||
(1- remaining))))
|
||||
;; and a $22.40 txn on 1.7.1980 just to throw the averages off
|
||||
(env-create-transaction env (gnc-dmy2time64 1 7 1980)
|
||||
my-asset-account my-income-account 224/10)
|
||||
(set-option income-options gnc:pagename-display "Show table" #t)
|
||||
(set-option income-options gnc:pagename-general "Start Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 1 1980)))
|
||||
(set-option income-options gnc:pagename-general "End Date"
|
||||
(cons 'absolute (gnc-dmy2time64 31 12 1980)))
|
||||
(set-option income-options gnc:pagename-general "Step Size" 'DayDelta)
|
||||
(set-option income-options gnc:pagename-general "Price Source" 'pricedb-nearest)
|
||||
(set-option income-options gnc:pagename-general "Report's currency" (gnc-default-report-currency))
|
||||
(set-option income-options gnc:pagename-accounts "Accounts" (list my-income-account))
|
||||
(set-option income-options gnc:pagename-accounts "Show Accounts until level" 'all)
|
||||
|
||||
(test-begin "multiplier test")
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'WeekDelta)
|
||||
(set-option income-options gnc:pagename-general "Step Size" 'MonthDelta)
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-average-week"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "monthly chart, weekly average"
|
||||
'("$3.79" "$7.57" "$11.61" "$20.20" "$20.70" "$24.74"
|
||||
"$41.75" "$33.83" "$47.97" "$42.92" "$46.96" "$51.00")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'MonthDelta)
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-average-month"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "monthly chart, monthly average"
|
||||
'("$16.50" "$33.00" "$50.60" "$88.00" "$90.20" "$107.80"
|
||||
"$181.90" "$147.40" "$209.00" "$187.00" "$204.60" "$222.20")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'DayDelta)
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-average-day"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "monthly chart, daily average"
|
||||
'("$0.54" "$1.08" "$1.66" "$2.89" "$2.96" "$3.53"
|
||||
"$5.96" "$4.83" "$6.85" "$6.13" "$6.71" "$7.29")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(set-option income-options gnc:pagename-general "Step Size" 'WeekDelta)
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'DayDelta)
|
||||
(set-option income-options gnc:pagename-general "Start Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 6 1980)))
|
||||
(set-option income-options gnc:pagename-general "End Date"
|
||||
(cons 'absolute (gnc-dmy2time64 1 8 1980)))
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-weekly-average-day"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "weekly chart, daily average"
|
||||
'("$3.61" "$3.77" "$3.93" "$4.09" "$7.44" "$4.40" "$4.56" "$4.71" "$4.87")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'WeekDelta)
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-weekly-average-week"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "weekly chart, weekly average"
|
||||
'("$25.30" "$26.40" "$27.50" "$28.60"
|
||||
"$52.10" "$30.80" "$31.90" "$33.00" "$34.10")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(set-option income-options gnc:pagename-general "Show Average" 'MonthDelta)
|
||||
(let ((sxml (gnc:options->sxml uuid income-options
|
||||
"test-standard-category-report"
|
||||
"single-txn-test-weekly-average-month"
|
||||
#:strip-tag "script")))
|
||||
(test-equal "weekly chart, monthly average"
|
||||
'("$25.30" "$26.40" "$27.50" "$28.60"
|
||||
"$52.10" "$30.80" "$31.90" "$33.00" "$34.10")
|
||||
(sxml->table-row-col sxml 1 #f 2)))
|
||||
(test-end "multiplier test"))
|
||||
(teardown))
|
||||
|
||||
(define (list-leaves list)
|
||||
(if (not (pair? list))
|
||||
|
||||
@ -658,8 +658,10 @@ be excluded from periodic reporting.")
|
||||
(date-subtotal-choice-list (keylist->vectorlist date-subtotal-list))
|
||||
(prime-sortkey 'account-name)
|
||||
(prime-sortkey-subtotal-true #t)
|
||||
(prime-date-subtotal 'monthly)
|
||||
(sec-sortkey 'register-order)
|
||||
(sec-sortkey-subtotal-true #f))
|
||||
(sec-sortkey-subtotal-true #f)
|
||||
(sec-date-subtotal 'monthly))
|
||||
|
||||
(define (apply-selectable-by-name-sorting-options)
|
||||
(let* ((prime-sortkey-enabled (not (eq? prime-sortkey 'none)))
|
||||
@ -703,14 +705,16 @@ be excluded from periodic reporting.")
|
||||
(gnc-option-db-set-option-selectable-by-name
|
||||
options pagename-sorting optname-indenting
|
||||
(or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
|
||||
(and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)))
|
||||
(and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)
|
||||
(and prime-date-sortingtype-enabled (not (eq? 'none prime-date-subtotal)))
|
||||
(and sec-date-sortingtype-enabled (not (eq? 'none sec-date-subtotal)))))
|
||||
|
||||
(gnc-option-db-set-option-selectable-by-name
|
||||
options pagename-sorting optname-show-subtotals-only
|
||||
(or (and prime-sortkey-subtotal-enabled prime-sortkey-subtotal-true)
|
||||
(and sec-sortkey-subtotal-enabled sec-sortkey-subtotal-true)
|
||||
prime-date-sortingtype-enabled
|
||||
sec-date-sortingtype-enabled))
|
||||
(and prime-date-sortingtype-enabled (not (eq? 'none prime-date-subtotal)))
|
||||
(and sec-date-sortingtype-enabled (not (eq? 'none sec-date-subtotal)))))
|
||||
|
||||
(gnc-option-db-set-option-selectable-by-name
|
||||
options pagename-sorting optname-show-informal-headers
|
||||
@ -789,11 +793,14 @@ be excluded from periodic reporting.")
|
||||
(apply-selectable-by-name-sorting-options))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
(gnc:make-multichoice-callback-option
|
||||
pagename-sorting optname-prime-date-subtotal
|
||||
"e2" (_ "Do a date subtotal.")
|
||||
'monthly
|
||||
date-subtotal-choice-list))
|
||||
prime-date-subtotal
|
||||
date-subtotal-choice-list #f
|
||||
(lambda (x)
|
||||
(set! prime-date-subtotal x)
|
||||
(apply-selectable-by-name-sorting-options))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
@ -825,11 +832,14 @@ be excluded from periodic reporting.")
|
||||
(apply-selectable-by-name-sorting-options))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
(gnc:make-multichoice-callback-option
|
||||
pagename-sorting optname-sec-date-subtotal
|
||||
"i2" (_ "Do a date subtotal.")
|
||||
'monthly
|
||||
date-subtotal-choice-list))
|
||||
sec-date-subtotal
|
||||
date-subtotal-choice-list #f
|
||||
(lambda (x)
|
||||
(set! sec-date-subtotal x)
|
||||
(apply-selectable-by-name-sorting-options))))
|
||||
|
||||
(gnc:register-trep-option
|
||||
(gnc:make-multichoice-option
|
||||
@ -1888,6 +1898,11 @@ be excluded from periodic reporting.")
|
||||
(not (eq? secondary-date-subtotal 'none)))
|
||||
(or (CUSTOM-SORTING? primary-key BOOK-SPLIT-ACTION)
|
||||
(CUSTOM-SORTING? secondary-key BOOK-SPLIT-ACTION))))
|
||||
(subtotal-table? (and (opt-val gnc:pagename-display optname-grid)
|
||||
(if (memq primary-key DATE-SORTING-TYPES)
|
||||
(keylist-get-info date-subtotal-list primary-date-subtotal 'renderer-fn)
|
||||
(opt-val pagename-sorting optname-prime-subtotal))
|
||||
(eq? (opt-val gnc:pagename-display (N_ "Amount")) 'single)))
|
||||
(infobox-display (opt-val gnc:pagename-general optname-infobox-display))
|
||||
(query (qof-query-create-for-splits)))
|
||||
|
||||
@ -2049,11 +2064,7 @@ be excluded from periodic reporting.")
|
||||
document
|
||||
(gnc:html-render-options-changed options)))
|
||||
|
||||
(if (and (opt-val gnc:pagename-display optname-grid)
|
||||
(if (memq primary-key DATE-SORTING-TYPES)
|
||||
(keylist-get-info date-subtotal-list primary-date-subtotal 'renderer-fn)
|
||||
(opt-val pagename-sorting optname-prime-subtotal))
|
||||
(eq? (opt-val gnc:pagename-display (N_ "Amount")) 'single))
|
||||
(if subtotal-table?
|
||||
(let* ((generic<? (lambda (a b)
|
||||
(cond ((string? (car a)) (string<? (car a) (car b)))
|
||||
((number? (car a)) (< (car a) (car b)))
|
||||
@ -2063,7 +2074,9 @@ be excluded from periodic reporting.")
|
||||
(gnc:html-document-add-object!
|
||||
document (grid->html-table grid list-of-rows list-of-cols))))
|
||||
|
||||
(gnc:html-document-add-object! document table)))))
|
||||
(unless (and subtotal-table?
|
||||
(opt-val pagename-sorting optname-show-subtotals-only))
|
||||
(gnc:html-document-add-object! document table))))))
|
||||
|
||||
(gnc:report-finished)
|
||||
|
||||
|
||||
@ -215,32 +215,78 @@
|
||||
(define (gnc:time64-ge-date t1 t2)
|
||||
(gnc:time64-le-date t2 t1))
|
||||
|
||||
;; Build a list of time intervals.
|
||||
(define (incdate-months date nmonths)
|
||||
(let* ((new-date (gnc-localtime date))
|
||||
(newmonth (+ (tm:mon new-date) nmonths))
|
||||
(new-month-proper (floor-remainder newmonth 12))
|
||||
(new-year-proper (+ (tm:year new-date) (floor-quotient newmonth 12))))
|
||||
(set-tm:year new-date new-year-proper)
|
||||
(set-tm:mon new-date new-month-proper)
|
||||
(let loop ((new-mday (tm:mday new-date)))
|
||||
(set-tm:mday new-date new-mday)
|
||||
(let ((res (gnc-mktime new-date)))
|
||||
(if (= new-month-proper (tm:mon (gnc-localtime res)))
|
||||
res
|
||||
(loop (1- new-mday)))))))
|
||||
|
||||
;; Build a list of time intervals.
|
||||
;;
|
||||
;; Note that the last interval will be shorter than <incr> if
|
||||
;; (<curd>-<endd>) is not an integer multiple of <incr>. If you don't
|
||||
;; want that you'll have to write another function.
|
||||
(define (gnc:make-date-interval-list current-date end-date increment)
|
||||
(if (< current-date end-date)
|
||||
(let ((next-date (incdate current-date increment)))
|
||||
(if (< next-date end-date)
|
||||
(cons (list current-date (decdate next-date SecDelta) '())
|
||||
(gnc:make-date-interval-list next-date end-date increment))
|
||||
(cons (list current-date end-date '())
|
||||
'())))
|
||||
'()))
|
||||
|
||||
(define (gnc:make-date-interval-list startdate enddate incr)
|
||||
(define month-delta
|
||||
(assv-ref MonthDeltas incr))
|
||||
(let loop ((result '())
|
||||
(date startdate)
|
||||
(idx 0))
|
||||
(cond
|
||||
((>= date enddate)
|
||||
(reverse result))
|
||||
(month-delta
|
||||
(let* ((curr (incdate-months startdate (* month-delta idx)))
|
||||
(next (incdate-months startdate (* month-delta (1+ idx)))))
|
||||
(loop (cons (list curr
|
||||
(if (< next enddate)
|
||||
(decdate next SecDelta)
|
||||
enddate))
|
||||
result)
|
||||
next
|
||||
(1+ idx))))
|
||||
(else
|
||||
(let ((next (incdate date incr)))
|
||||
(loop (cons (list date
|
||||
(if (< next enddate)
|
||||
(decdate next SecDelta)
|
||||
enddate))
|
||||
result)
|
||||
next
|
||||
(1+ idx)))))))
|
||||
|
||||
;; Build a list of times. The dates are evenly spaced with the
|
||||
;; stepsize 'incr'. If the difference of 'startdate' and 'enddate' is
|
||||
;; not an integer multiple of 'incr', 'enddate' will be added as the
|
||||
;; last element of the list, thus making the last interval smaller
|
||||
;; than 'incr'.
|
||||
(define (gnc:make-date-list startdate enddate incr)
|
||||
(if (< startdate enddate)
|
||||
(cons startdate
|
||||
(gnc:make-date-list (incdate startdate incr)
|
||||
enddate incr))
|
||||
(list enddate)))
|
||||
(define month-delta
|
||||
(assv-ref MonthDeltas incr))
|
||||
(let loop ((result '())
|
||||
(date startdate)
|
||||
(idx 0))
|
||||
(cond
|
||||
((>= date enddate)
|
||||
(reverse (cons enddate result)))
|
||||
(month-delta
|
||||
(let* ((curr (incdate-months startdate (* month-delta idx)))
|
||||
(next (incdate-months startdate (* month-delta (1+ idx)))))
|
||||
(loop (cons curr result)
|
||||
next
|
||||
(1+ idx))))
|
||||
(else
|
||||
(loop (cons date result)
|
||||
(incdate date incr)
|
||||
(1+ idx))))))
|
||||
|
||||
; A reference zero date - the Beginning Of The Epoch
|
||||
; Note: use of eval is evil... by making this a generator function,
|
||||
@ -310,6 +356,13 @@
|
||||
(set-tm:mday ddt 90)
|
||||
ddt))
|
||||
|
||||
(define MonthDeltas
|
||||
(list
|
||||
(cons MonthDelta 1)
|
||||
(cons QuarterDelta 3)
|
||||
(cons HalfYearDelta 6)
|
||||
(cons YearDelta 12)))
|
||||
|
||||
;; if you add any more FooDeltas, add to this list!!!
|
||||
|
||||
(define deltalist
|
||||
@ -377,8 +430,14 @@
|
||||
(define (gnc:get-absolute-from-relative-date date-symbol)
|
||||
(let ((rel-date-data (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
(if rel-date-data
|
||||
((gnc:reldate-get-fn rel-date-data))
|
||||
(gnc:error "Tried to look up an undefined date symbol"))))
|
||||
((gnc:reldate-get-fn rel-date-data))
|
||||
(let* ((msg (_ "Tried to look up an undefined date symbol \
|
||||
'~a'. This report was probably saved by a later version of GnuCash. \
|
||||
Defaulting to today."))
|
||||
(conmsg (format #f msg date-symbol))
|
||||
(uimsg (format #f (_ msg) date-symbol)))
|
||||
(gnc:gui-warn conmsg uimsg)
|
||||
(current-time)))))
|
||||
|
||||
(define (gnc:get-relative-date-strings date-symbol)
|
||||
(let ((rel-date-info (hash-ref gnc:relative-date-hash date-symbol)))
|
||||
|
||||
@ -17,6 +17,18 @@
|
||||
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
|
||||
;; Boston, MA 02110-1301, USA gnu@gnu.org
|
||||
(use-modules (ice-9 regex))
|
||||
(use-modules (gnucash gettext))
|
||||
|
||||
(define (rpterror-earlier type newoption fallback)
|
||||
;; Translators: the 3 ~a below refer to (1) option type (2) unknown
|
||||
;; new option name, (3) fallback option name. The order is
|
||||
;; important, and must not be changed.
|
||||
(let* ((template (N_ "This report was saved using a later version of \
|
||||
GnuCash. One of the newer ~a options '~a' is not available, fallback to \
|
||||
the option '~a'."))
|
||||
(console-msg (format #f template type newoption fallback))
|
||||
(ui-msg (format #f (_ template) type newoption fallback)))
|
||||
(gnc:gui-warn console-msg ui-msg)))
|
||||
|
||||
(define (gnc:make-option
|
||||
;; The category of this option
|
||||
@ -580,11 +592,11 @@
|
||||
(if (pair? (cdr date))
|
||||
(cons (car date) (cadr date))
|
||||
date))
|
||||
(define (list-lookup list item)
|
||||
(cond
|
||||
((null? list) #f)
|
||||
((eq? item (car list)) 0)
|
||||
(else (+ 1 (list-lookup (cdr list) item)))))
|
||||
(define (list-lookup full-list item)
|
||||
(or (list-index (lambda (i) (eq? i item)) full-list)
|
||||
(begin
|
||||
(rpterror-earlier "date" item (car full-list))
|
||||
0)))
|
||||
(let* ((value (default-getter))
|
||||
(value->string (lambda ()
|
||||
(string-append "'" (gnc:value->string value)))))
|
||||
@ -862,11 +874,11 @@
|
||||
validator
|
||||
(cons #f acct-type-list) #f #f #f)))
|
||||
|
||||
(define (gnc:multichoice-list-lookup list item )
|
||||
(cond
|
||||
((null? list) #f)
|
||||
((eq? item (vector-ref (car list) 0)) 0)
|
||||
(else (+ 1 (gnc:multichoice-list-lookup (cdr list) item)))))
|
||||
(define (gnc:multichoice-list-lookup full-lst item)
|
||||
(or (list-index (lambda (i) (eq? (vector-ref i 0) item)) full-lst)
|
||||
(begin
|
||||
(rpterror-earlier "multichoice" item (car full-lst))
|
||||
0)))
|
||||
|
||||
;; multichoice options use the option-data as a list of vectors.
|
||||
;; Each vector contains a permissible value (scheme symbol), a
|
||||
@ -930,7 +942,7 @@
|
||||
(set! value x)
|
||||
(if (procedure? setter-function-called-cb)
|
||||
(setter-function-called-cb x)))
|
||||
(gnc:error "Illegal Multichoice option set")))
|
||||
(rpterror-earlier "multichoice" x default-value)))
|
||||
(lambda () default-value)
|
||||
(gnc:restore-form-generator value->string)
|
||||
(lambda (b p) (qof-book-set-option b (symbol->string value) p))
|
||||
@ -1016,7 +1028,7 @@
|
||||
(set! value x)
|
||||
(if (procedure? setter-function-called-cb)
|
||||
(setter-function-called-cb x)))
|
||||
(gnc:error "Illegal Radiobutton option set")))
|
||||
(rpterror-earlier "radiobutton" x default-value)))
|
||||
(lambda () default-value)
|
||||
(gnc:restore-form-generator value->string)
|
||||
(lambda (b p) (qof-book-set-option b (symbol->string value) p))
|
||||
@ -1078,7 +1090,7 @@
|
||||
(lambda (x)
|
||||
(if (list-legal x)
|
||||
(set! value x)
|
||||
(gnc:error "Illegal list option set")))
|
||||
(rpterror-earlier "list" x default-value)))
|
||||
(lambda () default-value)
|
||||
(gnc:restore-form-generator value->string)
|
||||
(lambda (b p)
|
||||
|
||||
@ -57,6 +57,118 @@
|
||||
(not (weeknums-equal? (cons '(1969 12 28 0 0 1)
|
||||
'(1970 1 5 0 0 1))))))
|
||||
|
||||
(define (test-make-date-list)
|
||||
(test-equal "make-date-list"
|
||||
(list (create-time64 '(1969 12 18 0 0 1))
|
||||
(create-time64 '(1969 12 25 0 0 1))
|
||||
(create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 2 0 0 1)))
|
||||
(gnc:make-date-list
|
||||
(create-time64 '(1969 12 18 0 0 1))
|
||||
(create-time64 '(1970 1 2 0 0 1))
|
||||
WeekDelta))
|
||||
|
||||
(test-equal "make-date-list exact"
|
||||
(list (create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 8 0 0 1))
|
||||
(create-time64 '(1970 1 15 0 0 1)))
|
||||
(gnc:make-date-list
|
||||
(create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 15 0 0 1))
|
||||
WeekDelta))
|
||||
|
||||
(test-equal "make-date-list 31-dec-1970 to 15-4-1972 monthly including leapyear"
|
||||
(list (create-time64 '(1970 12 31 0 0 1))
|
||||
(create-time64 '(1971 1 31 0 0 1))
|
||||
(create-time64 '(1971 2 28 0 0 1))
|
||||
(create-time64 '(1971 3 31 0 0 1))
|
||||
(create-time64 '(1971 4 30 0 0 1))
|
||||
(create-time64 '(1971 5 31 0 0 1))
|
||||
(create-time64 '(1971 6 30 0 0 1))
|
||||
(create-time64 '(1971 7 31 0 0 1))
|
||||
(create-time64 '(1971 8 31 0 0 1))
|
||||
(create-time64 '(1971 9 30 0 0 1))
|
||||
(create-time64 '(1971 10 31 0 0 1))
|
||||
(create-time64 '(1971 11 30 0 0 1))
|
||||
(create-time64 '(1971 12 31 0 0 1))
|
||||
(create-time64 '(1972 1 31 0 0 1))
|
||||
(create-time64 '(1972 2 29 0 0 1))
|
||||
(create-time64 '(1972 3 31 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1)))
|
||||
(gnc:make-date-list
|
||||
(create-time64 '(1970 12 31 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1))
|
||||
MonthDelta))
|
||||
|
||||
(test-equal "make-date-list 30-aug-1970 to 15-4-1972 quarterly including leapyear"
|
||||
(list (create-time64 '(1970 8 31 0 0 1))
|
||||
(create-time64 '(1970 11 30 0 0 1))
|
||||
(create-time64 '(1971 2 28 0 0 1))
|
||||
(create-time64 '(1971 5 31 0 0 1))
|
||||
(create-time64 '(1971 8 31 0 0 1))
|
||||
(create-time64 '(1971 11 30 0 0 1))
|
||||
(create-time64 '(1972 2 29 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1)))
|
||||
(gnc:make-date-list
|
||||
(create-time64 '(1970 8 31 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1))
|
||||
QuarterDelta))
|
||||
|
||||
(test-equal "make-date-list 30-aug-1970 to 15-4-1972 half-yearly including leapyear"
|
||||
(list (create-time64 '(1970 8 30 0 0 1))
|
||||
(create-time64 '(1971 2 28 0 0 1))
|
||||
(create-time64 '(1971 8 30 0 0 1))
|
||||
(create-time64 '(1972 2 29 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1)))
|
||||
(gnc:make-date-list
|
||||
(create-time64 '(1970 8 30 0 0 1))
|
||||
(create-time64 '(1972 4 15 0 0 1))
|
||||
HalfYearDelta))
|
||||
|
||||
(test-equal "make-date-interval-list"
|
||||
(list (list (create-time64 '(1969 12 18 0 0 1))
|
||||
(create-time64 '(1969 12 25 0 0 0)))
|
||||
(list (create-time64 '(1969 12 25 0 0 1))
|
||||
(create-time64 '(1970 1 1 0 0 0)))
|
||||
(list (create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 2 0 0 1))))
|
||||
(gnc:make-date-interval-list
|
||||
(create-time64 '(1969 12 18 0 0 1))
|
||||
(create-time64 '(1970 1 2 0 0 1))
|
||||
WeekDelta))
|
||||
|
||||
(test-equal "make-date-interval-list exact"
|
||||
(list (list (create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 8 0 0 0)))
|
||||
(list (create-time64 '(1970 1 8 0 0 1))
|
||||
(create-time64 '(1970 1 15 0 0 1))))
|
||||
(gnc:make-date-interval-list
|
||||
(create-time64 '(1970 1 1 0 0 1))
|
||||
(create-time64 '(1970 1 15 0 0 1))
|
||||
WeekDelta))
|
||||
|
||||
(test-equal "make-date-interval-list 31/12/71 to 15/3/72 monthly incl leapyear"
|
||||
(list (list (create-time64 '(1971 12 31 0 0 1))
|
||||
(create-time64 '(1972 1 31 0 0 0)))
|
||||
(list (create-time64 '(1972 1 31 0 0 1))
|
||||
(create-time64 '(1972 2 29 0 0 0)))
|
||||
(list (create-time64 '(1972 2 29 0 0 1))
|
||||
(create-time64 '(1972 3 15 0 0 1))))
|
||||
(gnc:make-date-interval-list
|
||||
(create-time64 '(1971 12 31 0 0 1))
|
||||
(create-time64 '(1972 03 15 0 0 1))
|
||||
MonthDelta))
|
||||
|
||||
(test-equal "make-date-interval-list exact monthly"
|
||||
(list (list (create-time64 '(1970 1 31 0 0 1))
|
||||
(create-time64 '(1970 2 28 0 0 0)))
|
||||
(list (create-time64 '(1970 2 28 0 0 1))
|
||||
(create-time64 '(1970 3 31 0 0 1))))
|
||||
(gnc:make-date-interval-list
|
||||
(create-time64 '(1970 1 31 0 0 1))
|
||||
(create-time64 '(1970 3 31 0 0 1))
|
||||
MonthDelta)))
|
||||
|
||||
(define (test-date-get-quarter-string)
|
||||
(test-equal "14/02/2001 = Q1"
|
||||
"Q1"
|
||||
|
||||
@ -72,6 +72,13 @@
|
||||
(define (gnc:debug . items)
|
||||
(gnc-scm-log-debug (strify items)))
|
||||
|
||||
;; the following functions are initialized to log message to tracefile
|
||||
;; and will be redefined in UI initialization to display dialog
|
||||
;; messages
|
||||
(define-public (gnc:gui-warn str1 str2) (gnc:warn str1))
|
||||
(define-public (gnc:gui-error str1 str2) (gnc:error str1))
|
||||
(define-public (gnc:gui-msg str1 str2) (gnc:msg str1))
|
||||
|
||||
(define-syntax addto!
|
||||
(syntax-rules ()
|
||||
((addto! alist element)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user