aherman
/
gnucash
mirror of https://github.com/Gnucash/gnucash
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merge branch 'christopherlam-maint-bugfixes' into maint

Browse Source
pull/462/head
Christopher Lam 7 years ago
parent 95aed30320 d4af5244d0
commit 817c3f4d6a
11 changed files with 399 additions and 67 deletions
Show Stats Download Patch File Download Diff File

4
gnucash/gnome-utils/gnc-gnome-utils.c
Unescape View File

@ -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;

24
gnucash/gnome-utils/gnome-utils.scm
Unescape View File

@ -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))))))

10
gnucash/report/standard-reports/advanced-portfolio.scm
Unescape View File

@ -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))))))
))

24
gnucash/report/standard-reports/category-barchart.scm
Unescape View File

@ -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

7
gnucash/report/standard-reports/general-ledger.scm
Unescape View File

@ -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

100
gnucash/report/standard-reports/test/test-standard-category-report.scm
Unescape View File

@ -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))

45
gnucash/report/standard-reports/transaction.scm
Unescape View File

@ -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)

95
libgnucash/app-utils/date-utilities.scm
Unescape View File

@ -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)))

38
libgnucash/app-utils/options.scm
Unescape View File

@ -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)

112
libgnucash/app-utils/test/test-date-utilities.scm
Unescape View File

@ -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"

7
libgnucash/scm/utilities.scm
Unescape View File

@ -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)

Write Preview
Loading…
Cancel
Save