diff --git a/README.dependencies b/README.dependencies index 94ceb234a1..d4eba60b9e 100644 --- a/README.dependencies +++ b/README.dependencies @@ -54,17 +54,14 @@ required versions packaged, it was exceedingly painful for end users to upgrade to the anticipated release, leading to a reputation that gnucash still has.) -This document serves to keep track of the major distributions, the date of -their major release[s], and the relevant library versions as part of that -release (or an official package-upgrade path) - Libraries/Deps -------------- required Version -------- _______ glib2 2.40.0 gtk+3 3.14.0 - guile 2.2.0 or 2.0.0 + guile 2.2.0 or 2.0.0 Must be built with regex + support enabled libxml2 2.5.10 gettext 0.19.6 libxslt, including xsltproc diff --git a/gnucash/import-export/qif-imp/assistant-qif-import.c b/gnucash/import-export/qif-imp/assistant-qif-import.c index 282400f075..ada03f855c 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 7ba367d2ca..8e646b5503 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 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/commodity-utilities.scm b/gnucash/report/commodity-utilities.scm index c4313a44c9..97ded4e3fb 100644 --- a/gnucash/report/commodity-utilities.scm +++ b/gnucash/report/commodity-utilities.scm @@ -20,6 +20,8 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(use-modules (ice-9 match)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Functions to get splits with interesting data from accounts. @@ -265,19 +267,14 @@ ;; 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). diff --git a/gnucash/report/eguile-html-utilities.scm b/gnucash/report/eguile-html-utilities.scm index 2c8692acb3..d20dfbd5f3 100644 --- a/gnucash/report/eguile-html-utilities.scm +++ b/gnucash/report/eguile-html-utilities.scm @@ -85,7 +85,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. diff --git a/gnucash/report/eguile.scm b/gnucash/report/eguile.scm index 5cc2c18561..55d11c85e7 100644 --- a/gnucash/report/eguile.scm +++ b/gnucash/report/eguile.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/html-style-info.scm b/gnucash/report/html-style-info.scm index 50b0a7b760..38c166da8f 100644 --- a/gnucash/report/html-style-info.scm +++ b/gnucash/report/html-style-info.scm @@ -21,6 +21,7 @@ ;; Boston, MA 02110-1301, USA gnu@gnu.org ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(use-modules (ice-9 match)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 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 field) style value) + (loop rest)) + + (else style)))) (define gnc:html-markup-style-info-tag (record-accessor 'tag)) @@ -361,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)) - - - - diff --git a/gnucash/report/html-table.scm b/gnucash/report/html-table.scm index adc56ba53a..e7ea542880 100644 --- a/gnucash/report/html-table.scm +++ b/gnucash/report/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)))) @@ -406,37 +407,26 @@ (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))))) + (define (add-fn a b) (list-set-safe! b width a)) + (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 '()) diff --git a/gnucash/report/html-text.scm b/gnucash/report/html-text.scm index bd586be815..fd1f29ade6 100644 --- a/gnucash/report/html-text.scm +++ b/gnucash/report/html-text.scm @@ -60,13 +60,9 @@ (record-modifier '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) @@ -221,34 +217,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)) - - diff --git a/gnucash/report/trep-engine.scm b/gnucash/report/trep-engine.scm index eb1098ba34..fbcce9f052 100644 --- a/gnucash/report/trep-engine.scm +++ b/gnucash/report/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.