gnucash maint: Multiple changes pushed

Christopher Lam clam at code.gnucash.org
Wed Feb 5 03:50:55 EST 2020


Updated	 via  https://github.com/Gnucash/gnucash/commit/8365283f (commit)
	 via  https://github.com/Gnucash/gnucash/commit/bb986e47 (commit)
	 via  https://github.com/Gnucash/gnucash/commit/c94b4331 (commit)
	 via  https://github.com/Gnucash/gnucash/commit/ad094f43 (commit)
	 via  https://github.com/Gnucash/gnucash/commit/dafff689 (commit)
	from  https://github.com/Gnucash/gnucash/commit/f1667e7b (commit)



commit 8365283f1834b341883f71eb20bff6a1cf6cab6d
Author: Christopher Lam <christopher.lck at gmail.com>
Date:   Wed Feb 5 16:31:44 2020 +0800

    Bug 797609 - Backtraces for eguile report errors strips wrong part of stack
    
    Previous code used invalid algorithm to capture the desired error
    stack. Use simpler capture code, which does not require capturing the
    good stack.

diff --git a/gnucash/report/report-system/eguile-gnc.scm b/gnucash/report/report-system/eguile-gnc.scm
index f37b95dd3..76a48b04c 100644
--- a/gnucash/report/report-system/eguile-gnc.scm
+++ b/gnucash/report/report-system/eguile-gnc.scm
@@ -183,65 +183,38 @@
 ;;   env  - environment in which to do the evaluation;
 ;;          if #f, (the-environment) will be used
 (define (script->output env)
-  ; Placeholder for the normal stack and error stack in case of an error
-  (define good-stack #f)
+
+  ;; Placeholder for the error stack in case of an error
   (define error-stack #f)
-  ; Actual evaluation function. This is where the work happens.
+  (define local-env (or env (the-environment)))
+
+  ;; Actual evaluation function. This is where the work happens.
   (define (eval-input)
-    (let ((s-expression (read)))
-      (while (not (eof-object? s-expression))
-	     ; Capture the current stack, so we can detect from where we
-	     ; need to display the stack trace
-	     (set! good-stack (make-stack #t))
-             (local-eval s-expression (or env (the-environment)))
-             (set! s-expression (read)))))
+    (let lp ((next (read)))
+      (cond
+       ((eof-object? next) #f)
+       (else
+        (local-eval next local-env)
+        (lp (read))))))
 
-  ; Error handler to display any errors while evaluating the template
+  ;; Error handler to display any errors while evaluating the template
   (define (error-handler key subr message args . rest)
     (display "<p>")
     (display (_ "An error occurred when processing the template:"))
-    (display "<br><pre>")
+    (display "<br/><pre>")
     (display
-      (escape-html
-        (with-output-to-string
-          (lambda ()
-            (display-error #f (current-output-port) subr message args rest)))))
-	    ; Find out how many frames are interesting. From the
-	    ; good-stack, all but the bottom two frames are in
-	    ; error-stack as well, so we can remove the top #good - 2
-	    ; right away. Below that, there is still one frame in error
-	    ; stack, the call to local-eval, which we'll remove as well.
-	    ; So (#good - 2) + 1 == #good - 1 to remove from the top.
-	    ; We remove the bottom three frames as well: the pre-unwind
-	    ; handler, make-trace and one frame inside make-trace.
-	    (let* ((remove-top (- (stack-length good-stack) 1))
-		   (remove-bottom 3)
-		   (error-length (stack-length error-stack)))
-	      ; Show the backtrace. Remove one extra from the "first"
-	      ; argument, since that is an index, not a count.
-	      (display-backtrace error-stack
-                                 (current-output-port)
-                                 (- (- error-length remove-top) 1)
-                                 (- (- error-length remove-top) remove-bottom)))
-    (display "</pre><br>"))
+     (escape-html
+      (with-output-to-string
+        (lambda ()
+          (display-error #f (current-output-port) subr message args rest)
+          (display-backtrace error-stack (current-output-port))))))
+    (display "</pre><br/>"))
 
-  ; This handler will be called by catch before unwinding the
-  ; stack, so we can capture it. The above handler will then be called
-  ; to actually handle the exception. This technique is based on the
-  ; example in the guile manual. See:
-  ; https://www.gnu.org/software/guile/manual/html_node/Debug-on-Error.html
   (define (pre-unwind-handler key . rest)
-    ; Save the current stack. Note that this will include a couple of
-    ; extra entries (this error handler, the call to make-stack and
-    ; another one to gsubr-apply) which we'll cutt off at the display
-    ; above.
-    (set! error-stack (make-stack #t))
-    ; And throw the error again
-    (apply throw key rest))
+    ;; Capture the stack here, cut the last 3 frames which are
+    ;; make-stack, this one, and the throw handler.
+    (set! error-stack (make-stack #t 3)))
 
-  ; Use two nested catches. The inner one is lazy and does not unwind,
-  ; so it can catch th stack. The outer one does the real error
-  ; handling.
   (catch #t eval-input error-handler pre-unwind-handler))
 
 ; end of (script->output)

commit bb986e474cf927335ce730c5709802e127297c4f
Author: Christopher Lam <christopher.lck at gmail.com>
Date:   Wed Feb 5 16:31:20 2020 +0800

    [eguile-utilities] compact code, use (ice-9 match)

diff --git a/gnucash/report/report-system/eguile-utilities.scm b/gnucash/report/report-system/eguile-utilities.scm
index 0e536212f..f3e3e4923 100644
--- a/gnucash/report/report-system/eguile-utilities.scm
+++ b/gnucash/report/report-system/eguile-utilities.scm
@@ -23,6 +23,7 @@
 ;; 02111-1307 USA
 
 (define-module (gnucash report eguile-utilities))
+(use-modules (ice-9 match))
 
 ; using all of these seems like overkill -- 
 ; not sure which are really required
@@ -35,13 +36,10 @@
 
 (define-public (fmtnumber n)
   ;; Format a number (integer or real) into something printable
-  (number->string (if (integer? n) 
-                    (inexact->exact n) 
-                    n)))
+  (number->string (if (integer? n) (inexact->exact n) n)))
 
-(define-public (fmtnumeric n)
-  ;; Format gnc-numeric n with as many decimal places as required
-  (fmtnumber (gnc-numeric-to-double n)))
+;; Format gnc-numeric n with as many decimal places as required
+(define-public fmtnumeric fmtnumber)
 
 (define-public (gnc-monetary-neg? monetary)
   ; return true if the monetary value is negative
@@ -49,14 +47,15 @@
 
 ;; 'Safe' versions of cdr and cadr that don't crash
 ;; if the list is empty  (is there a better way?)
-(define-public (safe-cdr l)
-  (if (null? l) '()
-      (cdr l)))
-(define-public (safe-cadr l)
-  (cond
-   ((null? l) '())
-   ((null? (cdr l)) '())
-   (else (cadr l))))
+(define-public safe-cdr
+  (match-lambda
+    ((_ . x) x)
+    (_ '())))
+
+(define-public safe-cadr
+  (match-lambda
+    ((_ x . _) x)
+    (_ '())))
 
 (define-public (find-file fname)
   ;; Find the file 'fname', and return its full path.

commit c94b433187e2e67f56f454bbc7ec58601757fe8a
Author: Christopher Lam <christopher.lck at gmail.com>
Date:   Wed Feb 5 15:35:18 2020 +0800

    [commodity-utilities] compact code, use (ice-9 match)

diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index c6e1f29bb..1463ef081 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -618,10 +618,9 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
   ;; total balances from get-exchange-totals are divided by each
   ;; other.
   (map
-   (lambda (e)
-     (list (car e)
-           (abs (/ ((cdadr e) 'total #f)
-                   ((caadr e) 'total #f)))))
+   (match-lambda
+     ((comm (domestic . foreign))
+      (list comm (abs (/ (foreign 'total #f) (domestic 'total #f))))))
    (gnc:get-exchange-totals report-commodity end-date)))
 
 (define (gnc:make-exchange-cost-alist report-commodity end-date)
@@ -629,12 +628,10 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
   ;; total balances from get-exchange-totals are divided by each
   ;; other.
   (map
-   (lambda (e)
-     (list (car e)
-           (if (zero? ((caadr e) 'total #f))
-               0
-               (abs (/ ((cdadr e) 'total #f)
-                       ((caadr e) 'total #f))))))
+   (match-lambda
+     ((comm (domestic . foreign))
+      (let ((denom (domestic 'total #f)))
+        (list comm (if (zero? denom) 0 (abs (/ (foreign 'total #f) denom)))))))
    (gnc:get-exchange-cost-totals report-commodity end-date)))
 
 
@@ -973,7 +970,7 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
 (define (gnc:uniform-commodity? amt report-commodity)
   ;; function to see if the commodity-collector amt
   ;; contains any foreign commodities
-  (let ((list-of-commodities (amt 'format (lambda (comm amt) comm) #f)))
-    (or (null? list-of-commodities)
-        (and (null? (cdr list-of-commodities))
-             (gnc-commodity-equiv report-commodity (car list-of-commodities))))))
+  (match (amt 'format (lambda (comm amt) comm) #f)
+    (() #t)
+    ((comm) (gnc-commodity-equiv report-commodity comm))
+    (_ #f)))

commit ad094f4345f590fb9258258f3292e11a05b7f44f
Author: Christopher Lam <christopher.lck at gmail.com>
Date:   Wed Feb 5 15:35:01 2020 +0800

    [report-utilities] compact code, use (ice-9 match)

diff --git a/gnucash/report/report-system/report-utilities.scm b/gnucash/report/report-system/report-utilities.scm
index 0383bc969..20cff240c 100644
--- a/gnucash/report/report-system/report-utilities.scm
+++ b/gnucash/report/report-system/report-utilities.scm
@@ -423,11 +423,10 @@ construct gnc:make-gnc-monetary and use gnc:monetary->string instead.")
 ;; usage: (gnc:monetaries-add monetary1 monetary2 ...)
 ;; output: a monetary object
 (define (gnc:monetary+ . monetaries)
-  (let* ((coll (apply gnc:monetaries-add monetaries))
-         (list-of-monetaries (coll 'format gnc:make-gnc-monetary #f)))
-    (if (null? (cdr list-of-monetaries))
-        (car list-of-monetaries)
-        (throw "gnc:monetary+ expects 1 currency " (gnc:strify monetaries)))))
+  (let ((coll (apply gnc:monetaries-add monetaries)))
+    (match (coll 'format gnc:make-gnc-monetary #f)
+      ((mon) mon)
+      (_ (throw "gnc:monetary+ expects 1 currency " (gnc:strify monetaries))))))
 
 ;; get the account balance at the specified date. if include-children?
 ;; is true, the balances of all children (not just direct children)

commit dafff68914b085cc6520fd12dbcbadf849e7bebc
Author: Christopher Lam <christopher.lck at gmail.com>
Date:   Sun Feb 2 23:30:11 2020 +0800

    [lot-viewer] show lot guid in headers
    
    * also compact code, use partition
    * also don't need to localise option string for debugging tool

diff --git a/gnucash/report/standard-reports/lot-viewer.scm b/gnucash/report/standard-reports/lot-viewer.scm
index 01a061007..815fe9566 100644
--- a/gnucash/report/standard-reports/lot-viewer.scm
+++ b/gnucash/report/standard-reports/lot-viewer.scm
@@ -22,6 +22,7 @@
 (define-module (gnucash report standard-reports lot-viewer))
 
 (use-modules (srfi srfi-1))
+(use-modules (srfi srfi-11))            ;for let-values
 (use-modules (ice-9 match))
 (use-modules (gnucash utilities))
 (use-modules (gnucash gnc-module))
@@ -35,7 +36,7 @@
 (define optname-from-date (N_ "Start Date"))
 (define optname-to-date (N_ "End Date"))
 (define optname-account (N_ "Account"))
-(define optname-desc-filter (N_ "Desc Filter"))
+(define optname-desc-filter "Description Filter")
 
 (define txn-type-alist
   (list (cons TXN-TYPE-NONE "None")
@@ -133,6 +134,9 @@
       (let ((title (gnc-lot-get-title lot)))
         (if (string-null? title) "None" title)))
 
+    (define (lot->guid lot)
+      (string-take (gncLotReturnGUID lot) 8))
+
     (define (to-cell elt)
       (gnc:make-html-table-cell/markup "number-cell" elt))
 
@@ -158,8 +162,9 @@
 
      (else
       (let ((table (gnc:make-html-table)))
-        (gnc:html-table-set-col-headers!
-         table `("Date" "Desc" "Type" ,@(map lot->title lots) "Non-APAR"))
+        (gnc:html-table-set-multirow-col-headers!
+         table `(("Date" "Desc" "Type" ,@(map lot->title lots) "Other Account")
+                 (#f #f #f ,@(map lot->guid lots) #f)))
 
         (gnc:html-table-append-row!
          table `(#f "Document" #f ,@(map lot->document lots)))
@@ -180,11 +185,8 @@
                  (() (map (compose to-cell list->text) (reverse (cons splits accum))))
                  ((this-lot . rest-lots)
                   (define (in-lot? s) (member s (car lots-splits)))
-                  (let lp1 ((splits splits) (next '()) (this '()))
-                    (match splits
-                      (() (lp rest-lots (cdr lots-splits) next (cons this accum)))
-                      (((? in-lot? head) . tail) (lp1 tail next (cons head this)))
-                      ((head . tail) (lp1 tail (cons head next) this))))))))))
+                  (let-values (((this next) (partition in-lot? splits)))
+                    (lp rest-lots (cdr lots-splits) next (cons this accum)))))))))
          (sort transactions (lambda (a b) (< (xaccTransOrder a b) 0))))
 
         (gnc:html-table-append-row!



Summary of changes:
 .../report/report-system/commodity-utilities.scm   | 25 ++++----
 gnucash/report/report-system/eguile-gnc.scm        | 71 +++++++---------------
 gnucash/report/report-system/eguile-utilities.scm  | 27 ++++----
 gnucash/report/report-system/report-utilities.scm  |  9 ++-
 gnucash/report/standard-reports/lot-viewer.scm     | 18 +++---
 5 files changed, 60 insertions(+), 90 deletions(-)



More information about the gnucash-changes mailing list