gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Sat Oct 12 01:38:01 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/4c790b20 (commit)
via https://github.com/Gnucash/gnucash/commit/530f778d (commit)
via https://github.com/Gnucash/gnucash/commit/8e64fa7f (commit)
via https://github.com/Gnucash/gnucash/commit/66e5bc8a (commit)
via https://github.com/Gnucash/gnucash/commit/e4bb516b (commit)
via https://github.com/Gnucash/gnucash/commit/c5f23275 (commit)
via https://github.com/Gnucash/gnucash/commit/39a7584e (commit)
via https://github.com/Gnucash/gnucash/commit/cbd86491 (commit)
via https://github.com/Gnucash/gnucash/commit/fc3a740c (commit)
from https://github.com/Gnucash/gnucash/commit/cd2a2083 (commit)
commit 4c790b2084f904a5b8db10e4d8d5a23449a10005
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Oct 11 21:26:49 2019 +0800
Bug 412151 - Not handling exception when guile is compiled w/o regexp support
disable qif-import and make-regexp if guile is compiled without regex
diff --git a/gnucash/import-export/qif-imp/assistant-qif-import.c b/gnucash/import-export/qif-imp/assistant-qif-import.c
index 282400f07..ada03f855 100644
--- a/gnucash/import-export/qif-imp/assistant-qif-import.c
+++ b/gnucash/import-export/qif-imp/assistant-qif-import.c
@@ -3877,6 +3877,13 @@ gnc_file_qif_import (void)
{
QIFImportWindow *qif_win;
gint component_id;
+ SCM has_regex = scm_c_eval_string ("(defined? 'make-regexp)");
+
+ if (scm_is_false(has_regex) == 1)
+ {
+ gnc_warning_dialog(NULL, _("QIF import requires guile with regex support."));
+ return;
+ }
qif_win = g_new0 (QIFImportWindow, 1);
diff --git a/gnucash/import-export/qif-imp/qif-parse.scm b/gnucash/import-export/qif-imp/qif-parse.scm
index c79959f91..0350a31a4 100644
--- a/gnucash/import-export/qif-imp/qif-parse.scm
+++ b/gnucash/import-export/qif-imp/qif-parse.scm
@@ -26,6 +26,8 @@
(use-modules (gnucash import-export string))
(use-modules (srfi srfi-13))
+(define regexp-enabled?
+ (defined? 'make-regexp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-split:parse-category
;; this one just gets nastier and nastier.
@@ -40,7 +42,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define qif-category-compiled-rexp
- (make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$"))
+ (and regexp-enabled?
+ (make-regexp "^ *(\\[)?([^]/|]*)(]?)(/?)([^|]*)(\\|(\\[)?([^]/]*)(]?)(/?)(.*))? *$")))
+
(define (qif-split:parse-category self value)
;; example category regex matches (excluding initial 'L'):
;; field1
@@ -267,13 +271,16 @@
;; of possibilities.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define qif-date-compiled-rexp
- (make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]).*$"))
+ (and regexp-enabled?
+ (make-regexp "^ *([0-9]+) *[-/.'] *([0-9]+) *[-/.'] *([0-9]+).*$|^ *([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]).*$")))
(define qif-date-mdy-compiled-rexp
- (make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])"))
+ (and regexp-enabled?
+ (make-regexp "([0-9][0-9])([0-9][0-9])([0-9][0-9][0-9][0-9])")))
(define qif-date-ymd-compiled-rexp
- (make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])"))
+ (and regexp-enabled?
+ (make-regexp "([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])")))
(define (qif-parse:check-date-format date-string possible-formats)
(and (string? date-string)
@@ -358,15 +365,18 @@
;; eg 1000.00 or 1,500.00 or 2'000.00
(define decimal-radix-regexp
- (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *$"))
+ (and regexp-enabled?
+ (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([,'][0-9][0-9][0-9])*(\\.[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+\\.[0-9]*[+-]? *$")))
;; eg 5.000,00 or 4'500,00
(define comma-radix-regexp
- (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$"))
+ (and regexp-enabled?
+ (make-regexp "^ *[$]?[+-]?[$]?[0-9]+[+-]?$|^ *[$]?[+-]?[$]?[0-9]?[0-9]?[0-9]?([\\.'][0-9][0-9][0-9])*(,[0-9]*)?[+-]? *$|^ *[$]?[+-]?[$]?[0-9]+,[0-9]*[+-]? *$")))
;; eg 456 or 123
(define integer-regexp
- (make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$"))
+ (and regexp-enabled?
+ (make-regexp "^[$]?[+-]?[$]?[0-9]+[+-]? *$")))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; qif-parse:check-number-format
diff --git a/gnucash/report/report-system/eguile-gnc.scm b/gnucash/report/report-system/eguile-gnc.scm
index 1731ca6ae..f37b95dd3 100644
--- a/gnucash/report/report-system/eguile-gnc.scm
+++ b/gnucash/report/report-system/eguile-gnc.scm
@@ -108,8 +108,8 @@
(#\& . "&"))))
;; regexps used to find start and end of code segments
-(define startre (make-regexp "<\\?scm(:d)?[[:space:]]"))
-(define endre (make-regexp "(^|[[:space:]])\\?>"))
+(define startre (and (defined? 'make-regexp) (make-regexp "<\\?scm(:d)?[[:space:]]")))
+(define endre (and (defined? 'make-regexp) (make-regexp "(^|[[:space:]])\\?>")))
;; Guile code to mark starting and stopping text or code modes
(define textstart "(display \"")
@@ -170,7 +170,9 @@
(loop inp needle other code? "")))))
(display textstart)
- (loop (current-input-port) startre endre #f "")
+ (if (defined? 'make-regexp)
+ (loop (current-input-port) startre endre #f "")
+ (display "eguile requires guile with regex."))
(display stop))
;end of (template->script)
diff --git a/gnucash/report/report-system/eguile-html-utilities.scm b/gnucash/report/report-system/eguile-html-utilities.scm
index d123f6109..7ff8a94d6 100644
--- a/gnucash/report/report-system/eguile-html-utilities.scm
+++ b/gnucash/report/report-system/eguile-html-utilities.scm
@@ -88,7 +88,8 @@
;; (thanks to Peter Brett for this regexp and the use of match:prefix)
(define fontre
- (make-regexp "([[:space:]]+(bold|semi-bold|book|regular|medium|light))?([[:space:]]+(normal|roman|italic|oblique))?([[:space:]]+(condensed))?[[:space:]]+([[:digit:]]+)" regexp/icase))
+ (and (defined? 'make-regexp)
+ (make-regexp "([[:space:]]+(bold|semi-bold|book|regular|medium|light))?([[:space:]]+(normal|roman|italic|oblique))?([[:space:]]+(condensed))?[[:space:]]+([[:digit:]]+)" regexp/icase)))
(define-public (font-name-to-style-info font-name)
;;; Convert a font name as return by a font option to CSS format.
commit 530f778dbb90f6e24d8285212f46b6e598b711e3
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Oct 11 07:48:37 2019 +0800
[trep-engine] disable regex if no regex in guile
diff --git a/gnucash/report/report-system/trep-engine.scm b/gnucash/report/report-system/trep-engine.scm
index eb1098ba3..fbcce9f05 100644
--- a/gnucash/report/report-system/trep-engine.scm
+++ b/gnucash/report/report-system/trep-engine.scm
@@ -1936,11 +1936,13 @@ be excluded from periodic reporting.")
(let* ((document (gnc:make-html-document))
(account-matcher (opt-val pagename-filter optname-account-matcher))
- (account-matcher-regexp (and (opt-val pagename-filter
- optname-account-matcher-regex)
- (catch 'regular-expression-syntax
- (lambda () (make-regexp account-matcher))
- (const 'invalid-regex))))
+ (account-matcher-regexp
+ (and (opt-val pagename-filter optname-account-matcher-regex)
+ (if (defined? 'make-regexp)
+ (catch 'regular-expression-syntax
+ (lambda () (make-regexp account-matcher))
+ (const 'invalid-account-regex))
+ 'no-guile-regex-support)))
(c_account_0 (or custom-source-accounts
(opt-val gnc:pagename-accounts optname-accounts)))
(c_account_1 (filter
@@ -1962,9 +1964,11 @@ be excluded from periodic reporting.")
(transaction-matcher (opt-val pagename-filter optname-transaction-matcher))
(transaction-matcher-regexp
(and (opt-val pagename-filter optname-transaction-matcher-regex)
- (catch 'regular-expression-syntax
- (lambda () (make-regexp transaction-matcher))
- (const 'invalid-regex))))
+ (if (defined? 'make-regexp)
+ (catch 'regular-expression-syntax
+ (lambda () (make-regexp transaction-matcher))
+ (const 'invalid-transaction-regex))
+ 'no-guile-regex-support)))
(reconcile-status-filter
(keylist-get-info reconcile-status-list
(opt-val pagename-filter optname-reconcile-status)
@@ -2042,14 +2046,26 @@ be excluded from periodic reporting.")
(cond
((or (null? c_account_1)
- (eq? account-matcher-regexp 'invalid-regex)
- (eq? transaction-matcher-regexp 'invalid-regex))
+ (symbol? account-matcher-regexp)
+ (symbol? transaction-matcher-regexp))
- ;; error condition: no accounts specified or obtained after filtering
(gnc:html-document-add-object!
document
- (gnc:html-make-no-account-warning
- report-title (gnc:report-id report-obj)))
+ (cond
+ ((null? c_account_1)
+ (gnc:html-make-no-account-warning report-title (gnc:report-id report-obj)))
+
+ ((symbol? account-matcher-regexp)
+ (gnc:html-make-generic-warning
+ report-title (gnc:report-id report-obj)
+ (string-append (_ "Error") " " (symbol->string account-matcher-regexp))
+ ""))
+
+ ((symbol? transaction-matcher-regexp)
+ (gnc:html-make-generic-warning
+ report-title (gnc:report-id report-obj)
+ (string-append (_ "Error") " " (symbol->string transaction-matcher-regexp))
+ ""))))
;; if an empty-report-message is passed by a derived report to
;; the renderer, display it here.
commit 8e64fa7f6595599c985f68d91f3d7195bae2f569
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Oct 12 13:18:02 2019 +0800
[html-style-info] compact gnc:html-style-table-fetch
diff --git a/gnucash/report/report-system/html-style-info.scm b/gnucash/report/report-system/html-style-info.scm
index ab8cd07fc..38c166da8 100644
--- a/gnucash/report/report-system/html-style-info.scm
+++ b/gnucash/report/report-system/html-style-info.scm
@@ -353,32 +353,26 @@
(and (gnc:html-data-style-info? s)
(gnc:html-data-style-info-inheritable? s)))
s #f)))
-
+
(define (fetch-worker style antecedents)
- (if (null? antecedents)
- style
- (let ((parent (car antecedents)))
- (if (not parent)
- (fetch-worker style (cdr antecedents))
- (if (gnc:html-style-table-compiled? parent)
- (gnc:html-style-info-merge
- style
- (hash-ref (gnc:html-style-table-inheritable parent) markup))
- (fetch-worker
- (gnc:html-style-info-merge
- style (get-inheritable-style
- (gnc:html-style-table-primary parent)))
- (cdr antecedents)))))))
+ (cond
+ ((null? antecedents) style)
+ ((not (car antecedents)) (fetch-worker style (cdr antecedents)))
+ ((gnc:html-style-table-compiled? (car antecedents))
+ (gnc:html-style-info-merge
+ style (hash-ref (gnc:html-style-table-inheritable (car antecedents)) markup)))
+ (else
+ (fetch-worker
+ (gnc:html-style-info-merge
+ style (get-inheritable-style
+ (gnc:html-style-table-primary (car antecedents))))
+ (cdr antecedents)))))
(if (and table (gnc:html-style-table-compiled? table))
(hash-ref (gnc:html-style-table-compiled table) markup)
- (fetch-worker
+ (fetch-worker
(and table (hash-ref (gnc:html-style-table-primary table) markup))
antecedents)))
(define (gnc:html-style-table-set! table markup style-info)
(hash-set! (gnc:html-style-table-primary table) markup style-info))
-
-
-
-
commit 66e5bc8a58bdbae6fb0eae33395d41ec6b40c29d
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Oct 10 21:47:26 2019 +0800
[html-style-info] compact gnc:html-markup-style-info-set!
diff --git a/gnucash/report/report-system/html-style-info.scm b/gnucash/report/report-system/html-style-info.scm
index 50b0a7b76..ab8cd07fc 100644
--- a/gnucash/report/report-system/html-style-info.scm
+++ b/gnucash/report/report-system/html-style-info.scm
@@ -21,6 +21,7 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(use-modules (ice-9 match))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-markup-style-info> class
@@ -68,28 +69,19 @@
(define (gnc:html-markup-style-info-set! style . rest)
(let loop ((arglist rest))
- (if (and (list? arglist)
- (not (null? arglist))
- (not (null? (cdr arglist))))
- (let* ((field (car arglist))
- (value (cadr arglist)))
- (if (eq? field 'attribute)
- (if (list? value)
- (gnc:html-markup-style-info-set-attribute!
- style (car value)
- (if (null? (cdr value))
- #f
- (cadr value))))
- (begin
- (if (memq field '(font-size font-face font-color))
- (gnc:html-markup-style-info-set-closing-font-tag!
- style
- (not (eq? value #f))))
- (let ((modifier
- (record-modifier <html-markup-style-info> field)))
- (modifier style value))))
- (loop (cddr arglist)))))
- style)
+ (match arglist
+ (('attribute (key . val) . rest)
+ (gnc:html-markup-style-info-set-attribute!
+ style key (and (pair? val) (car val)))
+ (loop rest))
+
+ ((field value . rest)
+ (when (memq field '(font-size font-face font-color))
+ (gnc:html-markup-style-info-set-closing-font-tag! style (and value #t)))
+ ((record-modifier <html-markup-style-info> field) style value)
+ (loop rest))
+
+ (else style))))
(define gnc:html-markup-style-info-tag
(record-accessor <html-markup-style-info> 'tag))
commit e4bb516b944f944613e4cfcead96fd480a9b9a79
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Oct 12 13:11:11 2019 +0800
[html-text] compact gnc:html-text-set-style!
diff --git a/gnucash/report/report-system/html-text.scm b/gnucash/report/report-system/html-text.scm
index 3b308b505..fd1f29ade 100644
--- a/gnucash/report/report-system/html-text.scm
+++ b/gnucash/report/report-system/html-text.scm
@@ -60,13 +60,9 @@
(record-modifier <html-text> 'style))
(define (gnc:html-text-set-style! text tag . rest)
- (let ((newstyle #f))
- (if (and (= (length rest) 2)
- (procedure? (car rest)))
- (set! newstyle
- (apply gnc:make-html-data-style-info rest))
- (set! newstyle
- (apply gnc:make-html-markup-style-info rest)))
+ (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
+ (apply gnc:make-html-data-style-info rest)
+ (apply gnc:make-html-markup-style-info rest))))
(gnc:html-style-table-set! (gnc:html-text-style text) tag newstyle)))
(define (gnc:html-text-append! text . body)
commit c5f232755b66cefd318401127ce92c4ad44d703c
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Oct 10 21:25:44 2019 +0800
[html-text] dedupe gnc:html-text-render-markup-noclose
dedupe the following fns
* gnc:html-text-render-markup-noclose
* gnc:html-text-render-markup
diff --git a/gnucash/report/report-system/html-text.scm b/gnucash/report/report-system/html-text.scm
index bd586be81..3b308b505 100644
--- a/gnucash/report/report-system/html-text.scm
+++ b/gnucash/report/report-system/html-text.scm
@@ -221,34 +221,21 @@
(gnc:html-style-table-uncompile (gnc:html-text-style p))
retval))
-;; XXX It would be better to merge this with the original html-text-render-markup below it,
-;; but that would require a fair amount of work to refactor so that it works correctly.
(define (gnc:html-text-render-markup-noclose doc markup attrib end-tag? . entities)
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))))
(push (gnc:html-document-markup-start doc markup end-tag? attrib))
- (for-each
+ (for-each
(lambda (elt)
- (cond ((procedure? elt)
- (push (elt doc)))
- (#t
- (push (gnc:html-document-render-data doc elt)))))
+ (cond
+ ((procedure? elt) (push (elt doc)))
+ (else (push (gnc:html-document-render-data doc elt)))))
entities)
retval))
(define (gnc:html-text-render-markup doc markup attrib end-tag? . entities)
- (let* ((retval '())
+ (let* ((retval (apply gnc:html-text-render-markup-noclose doc markup
+ attrib end-tag? entities))
(push (lambda (l) (set! retval (cons l retval)))))
- (push (gnc:html-document-markup-start doc markup end-tag? attrib))
- (for-each
- (lambda (elt)
- (cond ((procedure? elt)
- (push (elt doc)))
- (#t
- (push (gnc:html-document-render-data doc elt)))))
- entities)
- (if end-tag?
- (push (gnc:html-document-markup-end doc markup)))
+ (if end-tag? (push (gnc:html-document-markup-end doc markup)))
retval))
-
-
commit 39a7584e79ecec590ca30ad767ecb721e80e72b0
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Oct 11 23:55:16 2019 +0800
[html-table] renderer detects neg amounts for first cell-data
previous would only negate whereby table-cell has single
monetary/amount. change to detect whereby table-cell has multiple
items, and the first one is a negative monetary/amount.
this is useful for the budget spreadsheet whereby a negative monetary
may be followed by a <sup> footnote.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index e1f9187bb..771b2dab3 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -139,15 +139,16 @@
(define (gnc:html-table-cell-render cell doc)
;; This function renders a html-table-cell to a document tree
- ;; segment. Note: if the html-table-cell datum is a negative number
- ;; or gnc:monetary, it fixes the tag eg. "number-cell" becomes
- ;; "number-cell-red". The number and gnc:monetary renderers do not
- ;; have an automatic -neg tag modifier. See bug 759005 and 797357.
+ ;; segment. Note: if the first element in a html-table-cell data is
+ ;; a negative number or gnc:monetary, it fixes the tag
+ ;; eg. "number-cell" becomes "number-cell-red". The number and
+ ;; gnc:monetary renderers do not have an automatic -neg tag
+ ;; modifier. See bug 759005 and bug 797357.
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval))))
(cell-tag (gnc:html-table-cell-tag cell))
(cell-data (gnc:html-table-cell-data cell))
- (tag (if (and (= 1 (length cell-data))
+ (tag (if (and (not (null? cell-data))
(not (string=? cell-tag "td"))
(or (and (gnc:gnc-monetary? (car cell-data))
(negative? (gnc:gnc-monetary-amount (car cell-data))))
commit cbd864918325ae35653c6a78736c8dc557f2a004
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Oct 10 20:30:51 2019 +0800
[html-table] dedupe & compact html-table column prepend/append
* dedupe gnc:html-table-append-column! and gnc:html-table-prepend-column!
* create internal fn to drive modifiers
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 755fa0151..e1f9187bb 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -406,77 +406,34 @@
(gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
-
- ;; append the elements of newcol to each of the existing rows,
- ;; widening to width-to-make if necessary
- (define (append-to-element newcol existing-data length-to-append colnum)
- (if (= length-to-append 0)
- (cons '() newcol)
- (let ((result (append-to-element
- (cdr newcol) (cdr existing-data) (1- length-to-append)
- colnum)))
- (cons (cons (list-set-safe! (car existing-data) colnum (car newcol))
- (car result))
- (cdr result)))))
-
- (let* ((old-data (reverse (gnc:html-table-data table)))
- (old-numrows (length old-data))
- (old-numcols (apply max (cons 0 (map length old-data))))
- (new-numrows (length newcol)))
- (if (<= new-numrows old-numrows)
- (gnc:html-table-set-data!
- table
- (reverse (car (append-to-element newcol old-data new-numrows old-numcols))))
- (let ((res (append-to-element newcol old-data old-numrows old-numcols)))
- ;; Invariant maintained - table data in reverse order
- (gnc:html-table-set-data! table (reverse (car res)))
-
- (for-each
- (lambda (element)
- (gnc:html-table-append-row!
- table (list-set-safe! '() old-numcols element)))
- (cdr res))))))
+ (define width (apply max (cons 0 (map length (gnc:html-table-data table)))))
+ (table-column-driver table newcol (lambda (a b) (list-set-safe! b width a))))
(define (gnc:html-table-prepend-column! table newcol)
- ;; returns a pair, the car of which is the prepending of newcol
- ;; and existing-data, and the cdr is the remaining elements of newcol
- (define (prepend-to-element newcol existing-data length-to-append)
- (if (= length-to-append 0)
- (cons '() newcol)
- (let*
- ((current-new (car newcol))
- (current-existing (car existing-data))
- (rest-new (cdr newcol))
- (rest-existing (cdr existing-data))
- (rest-result (prepend-to-element rest-new rest-existing
- (- length-to-append 1))))
- (cons
- (cons (cons current-new current-existing) (car rest-result))
- (cdr rest-result)))))
- (issue-deprecation-warning "gnc:html-table-prepend-column! is unused.")
- (let* ((existing-data (reverse (gnc:html-table-data table)))
- (existing-length (length existing-data))
- (newcol-length (length newcol)))
- (if (<= newcol-length existing-length)
- (gnc:html-table-set-data!
- table
- (reverse (car (prepend-to-element
- newcol
- existing-data
- newcol-length))))
- (let* ((temp-result (prepend-to-element
- newcol
- existing-data
- existing-length))
- (joined-table-data (car temp-result))
- (remaining-elements (cdr temp-result)))
- ;; Invariant maintained - table data in reverse order
- (gnc:html-table-set-data! table (reverse joined-table-data))
- (for-each
- (lambda (element)
- (gnc:html-table-append-row! table (list element)))
- remaining-elements)
- #f))))
+ (table-column-driver table newcol cons))
+
+;; this is a helper function for gnc:html-table-append-column! and
+;; gnc:html-table-prepend-column! use only
+(define (table-column-driver table newcol add-fn)
+ (let lp ((newcol newcol)
+ (olddata (reverse (gnc:html-table-data table)))
+ (res '())
+ (numrows 0))
+ (cond
+ ((null? newcol)
+ (gnc:html-table-set-num-rows-internal! table numrows)
+ (gnc:html-table-set-data! table res))
+ ((null? olddata)
+ (lp (cdr newcol)
+ '()
+ (cons (add-fn (car newcol) '()) res)
+ (1+ numrows)))
+ (else
+ (lp (cdr newcol)
+ (cdr olddata)
+ (cons (add-fn (car newcol) (car olddata)) res)
+ (1+ numrows))))))
+
(define (gnc:html-table-render table doc)
(let* ((retval '())
commit fc3a740c84f2e3433dacd4c96ec390f720f27f61
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Oct 10 20:17:11 2019 +0800
[commodity-utilities] compact gnc:pricelist-price-find-nearest
using (ice-9 match)
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 989c2d6a5..c6e1f29bb 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -20,6 +20,8 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(use-modules (ice-9 match))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to get splits with interesting data from accounts.
@@ -297,19 +299,14 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; if pricelist was empty, #f.
(define (gnc:pricelist-price-find-nearest pricelist date)
(let lp ((pricelist pricelist))
- (cond
- ((null? pricelist) #f)
- ((null? (cdr pricelist)) (cadr (car pricelist)))
- (else
- (let ((earlier (car pricelist))
- (later (cadr pricelist)))
- (cond
- ((< (car later) date)
- (lp (cdr pricelist)))
- ((< (- date (car earlier)) (- (car later) date))
- (cadr earlier))
- (else
- (cadr later))))))))
+ (match pricelist
+ (() #f)
+ (((date price)) price)
+ (((date1 price1) (date2 price2) . rest)
+ (cond
+ ((< date2 date) (lp (cdr pricelist)))
+ ((< (- date date1) (- date2 date)) price1)
+ (else price2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Functions to get one price at a given time (i.e. not time-variant).
Summary of changes:
.../import-export/qif-imp/assistant-qif-import.c | 7 ++
gnucash/import-export/qif-imp/qif-parse.scm | 24 +++--
.../report/report-system/commodity-utilities.scm | 23 ++---
gnucash/report/report-system/eguile-gnc.scm | 8 +-
.../report/report-system/eguile-html-utilities.scm | 3 +-
gnucash/report/report-system/html-style-info.scm | 70 ++++++--------
gnucash/report/report-system/html-table.scm | 106 +++++++--------------
gnucash/report/report-system/html-text.scm | 37 ++-----
gnucash/report/report-system/trep-engine.scm | 42 +++++---
9 files changed, 140 insertions(+), 180 deletions(-)
More information about the gnucash-changes
mailing list