Merge branch 'maint'

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

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

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

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
+    (match pricelist
-     ((null? pricelist) #f)
+      (() #f)
-     ((null? (cdr pricelist)) (cadr (car pricelist)))
+      (((date price)) price)
-     (else
+      (((date1 price1) (date2 price2) . rest)
-      (let ((earlier (car pricelist))
+       (cond
-            (later (cadr pricelist)))
+        ((< date2 date) (lp (cdr pricelist)))
-        (cond
+        ((< (- date date1) (- date2 date)) price1)
-         ((< (car later) date)
+        (else price2))))))
-          (lp (cdr pricelist)))
-         ((< (- date (car earlier)) (- (car later) date))
-          (cadr earlier))
-         (else
-          (cadr later))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Functions to get one price at a given time (i.e. not time-variant).

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.

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 startre (and (defined? 'make-regexp) (make-regexp "<\\?scm(:d)?[[:space:]]")))
-(define endre   (make-regexp "(^|[[: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)

gnucash/report/html-style-info.scm

@@ -21,6 +21,7 @@
 ;; Boston, MA  02110-1301,  USA       gnu@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)
+    (match arglist
-             (not (null? arglist))
+      (('attribute (key . val) . rest)
-             (not (null? (cdr arglist))))
+       (gnc:html-markup-style-info-set-attribute!
-        (let* ((field (car arglist))
+        style key (and (pair? val) (car val)))
-               (value (cadr arglist)))
+       (loop rest))
-          (if (eq? field 'attribute)
+
-              (if (list? value)
+      ((field value . rest)
-                  (gnc:html-markup-style-info-set-attribute!
+       (when (memq field '(font-size font-face font-color))
-                   style (car value) 
+         (gnc:html-markup-style-info-set-closing-font-tag! style (and value #t)))
-		   (if (null? (cdr value))
+       ((record-modifier <html-markup-style-info> field) style value)
-		       #f
+       (loop rest))
-		       (cadr value))))
+
-	      (begin 
+      (else style))))
-		(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)
 
 (define gnc:html-markup-style-info-tag
   (record-accessor <html-markup-style-info> '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)
+    (cond
-        style
+     ((null? antecedents) style)
-        (let ((parent (car antecedents)))
+     ((not (car antecedents)) (fetch-worker style (cdr antecedents)))
-          (if (not parent)
+     ((gnc:html-style-table-compiled? (car antecedents))
-              (fetch-worker style (cdr antecedents))
+      (gnc:html-style-info-merge
-              (if (gnc:html-style-table-compiled? parent)
+       style (hash-ref (gnc:html-style-table-inheritable (car antecedents)) markup)))
-                  (gnc:html-style-info-merge 
+     (else
-                   style 
+      (fetch-worker
-                   (hash-ref (gnc:html-style-table-inheritable parent) markup))
+       (gnc:html-style-info-merge
-                  (fetch-worker 
+        style (get-inheritable-style
-                   (gnc:html-style-info-merge 
+               (gnc:html-style-table-primary (car antecedents))))
-                    style (get-inheritable-style 
+       (cdr antecedents)))))
-                           (gnc:html-style-table-primary parent)))
-                   (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))
-
-
-
-

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
+  ;; segment. Note: if the first element in a html-table-cell data is
-  ;; or gnc:monetary, it fixes the tag eg. "number-cell" becomes
+  ;; a negative number or gnc:monetary, it fixes the tag
-  ;; "number-cell-red". The number and gnc:monetary renderers do not
+  ;; eg. "number-cell" becomes "number-cell-red". The number and
-  ;; have an automatic -neg tag modifier. See bug 759005 and 797357.
+  ;; 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)
-
+  (define width (apply max (cons 0 (map length (gnc:html-table-data table)))))
-  ;; append the elements of newcol to each of the existing rows,
+  (define (add-fn a b) (list-set-safe! b width a))
-  ;; widening to width-to-make if necessary
+  (let lp ((newcol newcol)
-  (define (append-to-element newcol existing-data length-to-append colnum)
+           (olddata (reverse (gnc:html-table-data table)))
-    (if (= length-to-append 0)
+           (res '())
-        (cons '() newcol)
+           (numrows 0))
-        (let ((result (append-to-element
+    (cond
-                       (cdr newcol) (cdr existing-data) (1- length-to-append)
+     ((null? newcol)
-                       colnum)))
+      (gnc:html-table-set-num-rows-internal! table numrows)
-          (cons (cons (list-set-safe! (car existing-data) colnum (car newcol))
+      (gnc:html-table-set-data! table res))
-                      (car result))
+     ((null? olddata)
-                (cdr result)))))
+      (lp (cdr newcol)
-
+          '()
-  (let* ((old-data (reverse (gnc:html-table-data table)))
+          (cons (add-fn (car newcol) '()) res)
-         (old-numrows (length old-data))
+          (1+ numrows)))
-         (old-numcols (apply max (cons 0 (map length old-data))))
+     (else
-         (new-numrows (length newcol)))
+      (lp (cdr newcol)
-    (if (<= new-numrows old-numrows)
+          (cdr olddata)
-        (gnc:html-table-set-data!
+          (cons (add-fn (car newcol) (car olddata)) res)
-         table
+          (1+ numrows))))))
-         (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 (gnc:html-table-render table doc)
   (let* ((retval '())

gnucash/report/html-text.scm

@@ -60,13 +60,9 @@
   (record-modifier <html-text> 'style))
 
 (define (gnc:html-text-set-style! text tag . rest)
-  (let ((newstyle #f))
+  (let ((newstyle (if (and (= (length rest) 2) (procedure? (car rest)))
-    (if (and (= (length rest) 2)
+                      (apply gnc:make-html-data-style-info rest)
-             (procedure? (car rest)))
+                      (apply gnc:make-html-markup-style-info rest))))
-        (set! newstyle 
-              (apply gnc:make-html-data-style-info rest))
-        (set! newstyle 
-              (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)
+       (cond
-              (push (elt doc)))
+        ((procedure? elt) (push (elt doc)))
-             (#t 
+        (else (push (gnc:html-document-render-data doc elt)))))
-              (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))
+    (if end-tag? (push (gnc:html-document-markup-end doc markup)))
-    (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)))
     retval))
-
-

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
+         (account-matcher-regexp
-                                               optname-account-matcher-regex)
+          (and (opt-val pagename-filter optname-account-matcher-regex)
-                                      (catch 'regular-expression-syntax
+               (if (defined? 'make-regexp)
-                                        (lambda () (make-regexp account-matcher))
+                   (catch 'regular-expression-syntax
-                                        (const 'invalid-regex))))
+                     (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
+               (if (defined? 'make-regexp)
-                 (lambda () (make-regexp transaction-matcher))
+                   (catch 'regular-expression-syntax
-                 (const 'invalid-regex))))
+                     (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)
+          (symbol? account-matcher-regexp)
-          (eq? transaction-matcher-regexp 'invalid-regex))
+          (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
+       (cond
-        report-title (gnc:report-id report-obj)))
+        ((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.