diff --git a/gnucash/gnome-utils/gnc-gnome-utils.c b/gnucash/gnome-utils/gnc-gnome-utils.c
index f3b7ed82fe..71ea21a09f 100644
--- a/gnucash/gnome-utils/gnc-gnome-utils.c
+++ b/gnucash/gnome-utils/gnc-gnome-utils.c
@@ -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;
diff --git a/gnucash/gnome-utils/gnome-utils.scm b/gnucash/gnome-utils/gnome-utils.scm
index 32f5b89776..b903e45962 100644
--- a/gnucash/gnome-utils/gnome-utils.scm
+++ b/gnucash/gnome-utils/gnome-utils.scm
@@ -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))))))
diff --git a/gnucash/report/standard-reports/advanced-portfolio.scm b/gnucash/report/standard-reports/advanced-portfolio.scm
index 3b3953feb3..44bd6293b9 100644
--- a/gnucash/report/standard-reports/advanced-portfolio.scm
+++ b/gnucash/report/standard-reports/advanced-portfolio.scm
@@ -346,7 +346,7 @@ by preventing negative stock balances.
")
(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.
")
)
(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.
")
)
(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.
")
)
(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.
")
)
(if (= 0.0 totalinvalue)
""
- (format #f "~0,2f%" (* 100 (/ totalreturnvalue totalinvalue))))))
+ (format #f "~,2f%" (* 100 (/ totalreturnvalue totalinvalue))))))
))
diff --git a/gnucash/report/standard-reports/category-barchart.scm b/gnucash/report/standard-reports/category-barchart.scm
index 9365ae5681..35c9d2b26d 100644
--- a/gnucash/report/standard-reports/category-barchart.scm
+++ b/gnucash/report/standard-reports/category-barchart.scm
@@ -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
diff --git a/gnucash/report/standard-reports/general-ledger.scm b/gnucash/report/standard-reports/general-ledger.scm
index 75088bb3b7..94a73d3cf9 100644
--- a/gnucash/report/standard-reports/general-ledger.scm
+++ b/gnucash/report/standard-reports/general-ledger.scm
@@ -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
diff --git a/gnucash/report/standard-reports/test/test-standard-category-report.scm b/gnucash/report/standard-reports/test/test-standard-category-report.scm
index fc2e63e248..6ed306f3d7 100644
--- a/gnucash/report/standard-reports/test/test-standard-category-report.scm
+++ b/gnucash/report/standard-reports/test/test-standard-category-report.scm
@@ -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))
diff --git a/gnucash/report/standard-reports/transaction.scm b/gnucash/report/standard-reports/transaction.scm
index f6e949270d..04918ece89 100644
--- a/gnucash/report/standard-reports/transaction.scm
+++ b/gnucash/report/standard-reports/transaction.scm
@@ -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* ((generichtml-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)
diff --git a/libgnucash/app-utils/date-utilities.scm b/libgnucash/app-utils/date-utilities.scm
index 1e6b2f6a8d..e918c0177d 100644
--- a/libgnucash/app-utils/date-utilities.scm
+++ b/libgnucash/app-utils/date-utilities.scm
@@ -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 if
;; (-) is not an integer multiple of . 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)))
diff --git a/libgnucash/app-utils/options.scm b/libgnucash/app-utils/options.scm
index e8a676b43d..c87dbf165a 100644
--- a/libgnucash/app-utils/options.scm
+++ b/libgnucash/app-utils/options.scm
@@ -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)
diff --git a/libgnucash/app-utils/test/test-date-utilities.scm b/libgnucash/app-utils/test/test-date-utilities.scm
index 51eb9814ff..2f548e7939 100644
--- a/libgnucash/app-utils/test/test-date-utilities.scm
+++ b/libgnucash/app-utils/test/test-date-utilities.scm
@@ -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"
diff --git a/libgnucash/scm/utilities.scm b/libgnucash/scm/utilities.scm
index f34fbd99ce..8035c8a47a 100644
--- a/libgnucash/scm/utilities.scm
+++ b/libgnucash/scm/utilities.scm
@@ -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)