gnucash master: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Wed Oct 9 09:18:52 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/84034044 (commit)
via https://github.com/Gnucash/gnucash/commit/662d29d6 (commit)
via https://github.com/Gnucash/gnucash/commit/ef3bc616 (commit)
via https://github.com/Gnucash/gnucash/commit/8a46daeb (commit)
via https://github.com/Gnucash/gnucash/commit/6370b0f7 (commit)
via https://github.com/Gnucash/gnucash/commit/ca5f5871 (commit)
via https://github.com/Gnucash/gnucash/commit/1abda45c (commit)
via https://github.com/Gnucash/gnucash/commit/d45f0621 (commit)
via https://github.com/Gnucash/gnucash/commit/49e65130 (commit)
via https://github.com/Gnucash/gnucash/commit/3a2c85f5 (commit)
via https://github.com/Gnucash/gnucash/commit/f4794d51 (commit)
via https://github.com/Gnucash/gnucash/commit/7bb7d3cd (commit)
via https://github.com/Gnucash/gnucash/commit/f4379bbd (commit)
via https://github.com/Gnucash/gnucash/commit/93a24b62 (commit)
via https://github.com/Gnucash/gnucash/commit/a90b8749 (commit)
via https://github.com/Gnucash/gnucash/commit/2d996926 (commit)
via https://github.com/Gnucash/gnucash/commit/9d0d3fd3 (commit)
via https://github.com/Gnucash/gnucash/commit/b00a95c0 (commit)
via https://github.com/Gnucash/gnucash/commit/3e8c9ad8 (commit)
from https://github.com/Gnucash/gnucash/commit/58cfb58b (commit)
commit 84034044cec4ff67f409cfcbf9c6af1f19786d20
Merge: 58cfb58b9 662d29d66
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 21:16:14 2019 +0800
Merge branch 'maint'
diff --cc gnucash/report/html-table.scm
index bd942d748,755fa0151..adc56ba53
--- a/gnucash/report/html-table.scm
+++ b/gnucash/report/html-table.scm
@@@ -390,186 -360,123 +360,83 @@@
(gnc:html-table-set-row-styles! table new-rowstyles))
(let ((new-rowmarkup (make-hash-table 21)))
- (hash-fold
- (lambda (row markup prev)
- (hash-set! new-rowmarkup (+ 1 row) markup)
- #f)
- #f (gnc:html-table-row-markup-table table))
+ (hash-for-each
+ (lambda (row markup)
+ (hash-set! new-rowmarkup (+ 1 row) markup))
+ (gnc:html-table-row-markup-table table))
(gnc:html-table-set-row-markup-table! table new-rowmarkup))
-
new-num-rows))
- ;; list-set! is 0-based...
- ;; (let ((a '(0 1 2))) (list-set! a 1 "x") a)
- ;; => (0 "x" 2)
(define (gnc:html-table-get-cell table row col)
- (let* ((row (gnc:html-table-get-row table row)))
- (and row (list-ref-safe row col)))
- )
+ (and-let* ((row (gnc:html-table-get-row table row)))
+ (list-ref-safe row col)))
(define (gnc:html-table-get-row table row)
- (let* ((dd (gnc:html-table-data table))
- (len (and dd (length dd)))
- )
- (and len
- (list-ref-safe dd (- (- len 1) row))
- )
- ))
-
- ;; if the 4th arg is a cell, overwrite the existing cell,
- ;; otherwise, append all remaining objects to the existing cell
+ (and-let* ((dd (gnc:html-table-data table))
+ (len (length dd)))
+ (list-ref-safe dd (- len row 1))))
+
+ ;; this function is not exported
+ (define (gnc:html-table-set-cell-datum! table row col datum)
+ (let lp ((len (length (gnc:html-table-data table))))
+ (cond
+ ((< row len)
+ (let* ((row-loc (- len row 1))
+ (old-tbldata (gnc:html-table-data table))
+ (old-rowdata (list-ref old-tbldata row-loc))
+ (new-rowdata (list-set-safe! old-rowdata col datum))
+ (new-tbldata (list-set-safe! old-tbldata row-loc new-rowdata)))
+ ;; add the row-data back to the table
+ (gnc:html-table-set-data! table new-tbldata)))
+ (else
+ (gnc:html-table-append-row! table '())
+ (lp (1+ len))))))
+
(define (gnc:html-table-set-cell! table row col . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
-
- ;; if the 4th arg is a cell, overwrite the existing cell,
- ;; otherwise, append all remaining objects to the existing cell
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-set-cell-datum! table row col tc)))
+
(define (gnc:html-table-set-cell/tag! table row col tag . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (num-objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? num-objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (gnc:html-table-cell-set-tag! tc tag)
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-cell-set-tag! tc tag)
+ (gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
- (define (maxwidth table-data)
- (if (null? table-data) 0
- (max (length (car table-data)) (maxwidth (cdr table-data)))))
-
- ;; widen an individual row to the required width and append element
- (define (widen-and-append row element width)
- (let ((current-width (length row))
- (new-suffix (list element)))
- (do
- ((i current-width (+ i 1)))
- ((>= 1 (- width i)))
- (set! new-suffix (cons #f new-suffix)))
- (append row new-suffix)))
-
- ;; 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
- width-to-make)
- (if (= length-to-append 0)
+
+ ;; 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*
- ((current-new (car newcol))
- (current-existing (car existing-data))
- (rest-new (cdr newcol))
- (rest-existing (cdr existing-data))
- (rest-result (append-to-element rest-new rest-existing
- (- length-to-append 1)
- width-to-make)))
- (cons (cons (widen-and-append
- current-existing
- current-new
- width-to-make )
- (car rest-result))
- (cdr rest-result)))))
-
- (let* ((existing-data (reverse (gnc:html-table-data table)))
- (existing-length (length existing-data))
- (width-to-make (+ (maxwidth existing-data) 1))
- (newcol-length (length newcol)))
- (if (<= newcol-length existing-length)
- (gnc:html-table-set-data!
+ (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
- existing-data
- newcol-length
- width-to-make))))
- (let* ((temp-result (append-to-element
- newcol
- existing-data
- existing-length
- width-to-make))
- (joined-table-data (car temp-result))
- (remaining-elements (cdr temp-result)))
+ (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 joined-table-data))
-
- (for-each
- (lambda (element)
- (gnc:html-table-append-row! table
- (widen-and-append
- '()
- element
- width-to-make)))
- remaining-elements)
- #f))))
+ (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))))))
- ;;
- ;; It would be nice to have table row/col/cell accessor functions in here.
- ;; It would also be nice to have table juxtaposition functions, too.
- ;; i.e., (gnc:html-table-nth-row table n)
- ;; [ CAS: how is that different from gnc:html-table-get-row ? ]
-
- ;; (gnc:html-table-append-table-horizontal table add-table)
- ;; (An old merge-table used to exist inside balance-sheet.scm/GnuCash 1.8.9.)
- ;; Feel free to contribute! :-)
- ;;
-(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))))
(define (gnc:html-table-render table doc)
(let* ((retval '())
commit 662d29d664d6834b66caf7c9a24a9543d8571d13
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:42:26 2019 +0800
[average-balance] show monetaries instead of numbers in data table
instead of numbers, show monetary amounts, rounded to SCU
diff --git a/gnucash/report/standard-reports/average-balance.scm b/gnucash/report/standard-reports/average-balance.scm
index 07d239065..8da8063ed 100644
--- a/gnucash/report/standard-reports/average-balance.scm
+++ b/gnucash/report/standard-reports/average-balance.scm
@@ -486,7 +486,8 @@
;; make a table (optionally)
(gnc:report-percent-done 80)
(if show-table?
- (let ((table (gnc:make-html-table)))
+ (let ((table (gnc:make-html-table))
+ (scu (gnc-commodity-get-fraction report-currency)))
(gnc:html-table-set-col-headers!
table columns)
(for-each
@@ -498,7 +499,14 @@
(list "date-cell" "date-cell"
"number-cell" "number-cell" "number-cell"
"number-cell" "number-cell" "number-cell")
- row)))
+ (cons* (car row)
+ (cadr row)
+ (map
+ (lambda (amt)
+ (gnc:make-gnc-monetary
+ report-currency
+ (gnc-numeric-convert amt scu GNC-RND-ROUND)))
+ (cddr row))))))
data)
(gnc:html-document-add-object! document table))))
diff --git a/gnucash/report/standard-reports/test/test-average-balance.scm b/gnucash/report/standard-reports/test/test-average-balance.scm
index c40ca3d22..0f96a01fa 100644
--- a/gnucash/report/standard-reports/test/test-average-balance.scm
+++ b/gnucash/report/standard-reports/test/test-average-balance.scm
@@ -67,35 +67,35 @@
(let* ((options (default-testing-options))
(sxml (options->sxml options "default")))
(test-equal "averages"
- '("0.00" "50.00" "100.00" "150.00" "200.00" "200.00")
+ '("$0.00" "$50.00" "$100.00" "$150.00" "$200.00" "$200.00")
(get-row-col sxml #f 3))
(test-equal "maximums"
- '("0.00" "100.00" "100.00" "200.00" "200.00" "200.00")
+ '("$0.00" "$100.00" "$100.00" "$200.00" "$200.00" "$200.00")
(get-row-col sxml #f 4))
(test-equal "minimums"
- '("0.00" "0.00" "100.00" "100.00" "200.00" "200.00")
+ '("$0.00" "$0.00" "$100.00" "$100.00" "$200.00" "$200.00")
(get-row-col sxml #f 5))
(test-equal "net"
- '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 8)))
(env-transfer env 15 03 1979 bank bank2 25)
(let* ((options (default-testing-options))
(sxml (options->sxml options "include-internal")))
(test-equal "gains-include-internal"
- '("0.00" "100.00" "25.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$25.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 6))
(test-equal "loss-include-internal"
- '("0.00" "0.00" "25.00" "0.00" "0.00" "0.00")
+ '("$0.00" "$0.00" "$25.00" "$0.00" "$0.00" "$0.00")
(get-row-col sxml #f 7)))
(let* ((options (default-testing-options)))
(set-option! options "Accounts" "Exclude transactions between selected accounts" #t)
(let ((sxml (options->sxml options "exclude-internal")))
(test-equal "gain-exclude-internal"
- '("0.00" "100.00" "0.00" "100.00" "0.00" "0.00")
+ '("$0.00" "$100.00" "$0.00" "$100.00" "$0.00" "$0.00")
(get-row-col sxml #f 6))
(test-equal "loss-exclude-internal"
- '("0.00" "0.00" "0.00" "0.00" "0.00" "0.00")
+ '("$0.00" "$0.00" "$0.00" "$0.00" "$0.00" "$0.00")
(get-row-col sxml #f 7))))
(teardown)))
commit ef3bc616b2dafbd2ef9886b12e603e9e37bee565
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Oct 8 22:01:45 2019 +0800
[html-table] refactor and dedupe row/col modifiers
* dedupe gnc:html-table-set-cell/tag!
* dedupe gnc:html-table-set-cell!
* create internal fn gnc:html-table-set-cell-datum! for above fns
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index eb4cea990..755fa0151 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -376,80 +376,34 @@
(len (length dd)))
(list-ref-safe dd (- len row 1))))
-;; if the 4th arg is a cell, overwrite the existing cell,
-;; otherwise, append all remaining objects to the existing cell
+;; this function is not exported
+(define (gnc:html-table-set-cell-datum! table row col datum)
+ (let lp ((len (length (gnc:html-table-data table))))
+ (cond
+ ((< row len)
+ (let* ((row-loc (- len row 1))
+ (old-tbldata (gnc:html-table-data table))
+ (old-rowdata (list-ref old-tbldata row-loc))
+ (new-rowdata (list-set-safe! old-rowdata col datum))
+ (new-tbldata (list-set-safe! old-tbldata row-loc new-rowdata)))
+ ;; add the row-data back to the table
+ (gnc:html-table-set-data! table new-tbldata)))
+ (else
+ (gnc:html-table-append-row! table '())
+ (lp (1+ len))))))
+
(define (gnc:html-table-set-cell! table row col . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
-
-;; if the 4th arg is a cell, overwrite the existing cell,
-;; otherwise, append all remaining objects to the existing cell
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-set-cell-datum! table row col tc)))
+
(define (gnc:html-table-set-cell/tag! table row col tag . objects)
- (let ((rowdata #f)
- (row-loc #f)
- (l (length (gnc:html-table-data table)))
- (num-objs (length objects))
- )
- ;; ensure the row-data is there
- (if (>= row l)
- (begin
- (let loop ((i l))
- (gnc:html-table-append-row! table (list))
- (if (< i row)
- (loop (+ i 1))))
- (set! l (gnc:html-table-num-rows table))
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list)))
- (begin
- (set! row-loc (- (- l 1) row))
- (set! rowdata (list-ref (gnc:html-table-data table) row-loc))))
-
- ;; make a table-cell and set the data
- (let* ((tc (gnc:make-html-table-cell))
- (first (car objects)))
- (if (and (equal? num-objs 1) (gnc:html-table-cell? first))
- (set! tc first)
- (apply gnc:html-table-cell-append-objects! tc objects)
- )
- (gnc:html-table-cell-set-tag! tc tag)
- (set! rowdata (list-set-safe! rowdata col tc))
-
- ;; add the row-data back to the table
- (gnc:html-table-set-data!
- table (list-set-safe!
- (gnc:html-table-data table)
- row-loc rowdata)))))
+ (let ((tc (if (and (= (length objects) 1) (gnc:html-table-cell? (car objects)))
+ (car objects)
+ (apply gnc:make-html-table-cell objects))))
+ (gnc:html-table-cell-set-tag! tc tag)
+ (gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
commit 8a46daeb8c67ed4a6900d15dc8c916665f698d61
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 05:49:53 2019 +0800
[html-table] convert to srfi-2 and-let*
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 69f3b7b3f..eb4cea990 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -23,6 +23,8 @@
;; Boston, MA 02110-1301, USA gnu at gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(use-modules (srfi srfi-2))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; NB: In this code, "markup" and "/markup" *do not* refer to
@@ -365,22 +367,14 @@
(gnc:html-table-set-row-markup-table! table new-rowmarkup))
new-num-rows))
-;; list-set! is 0-based...
-;; (let ((a '(0 1 2))) (list-set! a 1 "x") a)
-;; => (0 "x" 2)
(define (gnc:html-table-get-cell table row col)
- (let* ((row (gnc:html-table-get-row table row)))
- (and row (list-ref-safe row col)))
- )
+ (and-let* ((row (gnc:html-table-get-row table row)))
+ (list-ref-safe row col)))
(define (gnc:html-table-get-row table row)
- (let* ((dd (gnc:html-table-data table))
- (len (and dd (length dd)))
- )
- (and len
- (list-ref-safe dd (- (- len 1) row))
- )
- ))
+ (and-let* ((dd (gnc:html-table-data table))
+ (len (length dd)))
+ (list-ref-safe dd (- len row 1))))
;; if the 4th arg is a cell, overwrite the existing cell,
;; otherwise, append all remaining objects to the existing cell
commit 6370b0f7ee4399fe223a269e95bf4283a9f7d773
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:27:18 2019 +0800
[html-table] html-table-cell negative amount does not apply to <td>
Only number-cell and total-number-cell have negative-amount styles.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index c2a28efc6..69f3b7b3f 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -146,6 +146,7 @@
(cell-tag (gnc:html-table-cell-tag cell))
(cell-data (gnc:html-table-cell-data cell))
(tag (if (and (= 1 (length cell-data))
+ (not (string=? cell-tag "td"))
(or (and (gnc:gnc-monetary? (car cell-data))
(negative? (gnc:gnc-monetary-amount (car cell-data))))
(and (number? (car cell-data))
diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm
index 6c5a3e637..5c672690c 100644
--- a/gnucash/report/report-system/test/test-report-html.scm
+++ b/gnucash/report/report-system/test/test-report-html.scm
@@ -849,9 +849,10 @@ HTML Document Title</title></head><body></body>\n\
(let* ((doc (gnc:make-html-document))
(comm-table (gnc-commodity-table-get-table (gnc-get-current-book)))
(USD (gnc-commodity-table-lookup comm-table "CURRENCY" "USD"))
- (cell (gnc:make-html-table-cell (gnc:make-gnc-monetary USD -10))))
+ (USD-neg10 (gnc:make-gnc-monetary USD -10))
+ (cell (gnc:make-html-table-cell/markup "number-cell" USD-neg10)))
(test-equal "html-table-cell negative-monetary -> tag gets -neg appended"
- "td-neg"
+ "number-cell-neg"
(cadr
(gnc:html-document-tree-collapse
(gnc:html-table-cell-render cell doc)))))
commit ca5f587156ed28aa40f76d81aefc325c89be1974
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:14:08 2019 +0800
[html-table] compact gnc:html-table-render
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 6703da501..c2a28efc6 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -529,144 +529,120 @@
remaining-elements)
#f))))
-;;
-;; It would be nice to have table row/col/cell accessor functions in here.
-;; It would also be nice to have table juxtaposition functions, too.
-;; i.e., (gnc:html-table-nth-row table n)
-;; [ CAS: how is that different from gnc:html-table-get-row ? ]
-
-;; (gnc:html-table-append-table-horizontal table add-table)
-;; (An old merge-table used to exist inside balance-sheet.scm/GnuCash 1.8.9.)
-;; Feel free to contribute! :-)
-;;
-
(define (gnc:html-table-render table doc)
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))))
-
- ;; compile the table style to make other compiles faster
- (gnc:html-style-table-compile
- (gnc:html-table-style table) (gnc:html-document-style-stack doc))
-
+
+ ;; compile the table style to make other compiles faster
+ (gnc:html-style-table-compile (gnc:html-table-style table)
+ (gnc:html-document-style-stack doc))
+
(gnc:html-document-push-style doc (gnc:html-table-style table))
(push (gnc:html-document-markup-start doc "table" #t))
-
- ;; render the caption
+
+ ;; render the caption
(let ((c (gnc:html-table-caption table)))
- (if c
- (begin
- (push (gnc:html-document-markup-start doc "caption" #t))
- (push (gnc:html-object-render c doc))
- (push (gnc:html-document-markup-end doc "caption")))))
-
+ (when c
+ (push (gnc:html-document-markup-start doc "caption" #t))
+ (push (gnc:html-object-render c doc))
+ (push (gnc:html-document-markup-end doc "caption"))))
+
;; the first row is the column headers. Columns styles apply.
;; compile the col styles with the header style pushed; we'll
;; recompile them later, but this will have the benefit of
;; compiling in the col-header-style.
- (let ((ch (gnc:html-table-col-headers table))
- (colnum 0))
- (if ch
- (begin
- (gnc:html-document-push-style
- doc (gnc:html-table-col-headers-style table))
-
- ;; compile the column styles just in case there's
- ;; something interesting in the table header cells.
- (hash-fold
- (lambda (col style init)
- (if style
- (gnc:html-style-table-compile
- style (gnc:html-document-style-stack doc)))
- #f)
- #f (gnc:html-table-col-styles table))
-
- ;; render the headers
- (push (gnc:html-document-markup-start doc "thead" #t))
- (push (gnc:html-document-markup-start doc "tr" #t))
- (for-each
- (lambda (hdr)
- (gnc:html-document-push-style
- doc (gnc:html-table-col-style table colnum))
- (if (not (gnc:html-table-cell? hdr))
- (push (gnc:html-document-markup-start doc "th" #t)))
- (push (gnc:html-object-render hdr doc))
- (if (not (gnc:html-table-cell? hdr))
- (push (gnc:html-document-markup-end doc "th")))
- (gnc:html-document-pop-style doc)
- (if (not (gnc:html-table-cell? hdr))
- (set! colnum (+ 1 colnum))
- (set! colnum (+ (gnc:html-table-cell-colspan hdr)
- colnum))))
- ch)
- (push (gnc:html-document-markup-end doc "tr"))
- (push (gnc:html-document-markup-end doc "thead"))
-
- ;; pop the col header style
- (gnc:html-document-pop-style doc))))
-
+ (let ((ch (gnc:html-table-col-headers table)))
+ (when ch
+ (gnc:html-document-push-style doc (gnc:html-table-col-headers-style table))
+
+ ;; compile the column styles just in case there's something
+ ;; interesting in the table header cells.
+ (hash-for-each
+ (lambda (col style)
+ (when style
+ (gnc:html-style-table-compile
+ style (gnc:html-document-style-stack doc))))
+ (gnc:html-table-col-styles table))
+
+ ;; render the headers
+ (push (gnc:html-document-markup-start doc "thead" #t))
+ (push (gnc:html-document-markup-start doc "tr" #t))
+ (let lp ((ch ch)
+ (colnum 0))
+ (unless (null? ch)
+ (let ((hdr (car ch)))
+ (gnc:html-document-push-style
+ doc (gnc:html-table-col-style table colnum))
+ (unless (gnc:html-table-cell? hdr)
+ (push (gnc:html-document-markup-start doc "th" #t)))
+ (push (gnc:html-object-render hdr doc))
+ (unless (gnc:html-table-cell? hdr)
+ (push (gnc:html-document-markup-end doc "th")))
+ (gnc:html-document-pop-style doc)
+ (lp (cdr ch)
+ (+ colnum
+ (if (gnc:html-table-cell? hdr)
+ (gnc:html-table-cell-colspan hdr)
+ 1))))))
+ (push (gnc:html-document-markup-end doc "tr"))
+ (push (gnc:html-document-markup-end doc "thead"))
+
+ ;; pop the col header style
+ (gnc:html-document-pop-style doc)))
+
;; recompile the column styles. We won't worry about the row
;; styles; if they're there, we may lose, but not much, and they
;; will be pretty rare (I think).
- (hash-fold
- (lambda (col style init)
- (if style
- (gnc:html-style-table-compile
- style (gnc:html-document-style-stack doc)))
- #f)
- #f (gnc:html-table-col-styles table))
-
+ (hash-for-each
+ (lambda (col style)
+ (when style
+ (gnc:html-style-table-compile style (gnc:html-document-style-stack doc))))
+ (gnc:html-table-col-styles table))
+
(push (gnc:html-document-markup-start doc "tbody" #t))
- ;; now iterate over the rows
- (let ((rownum 0) (colnum 0))
- (for-each
- (lambda (row)
- (let ((rowstyle
- (gnc:html-table-row-style table rownum))
- (rowmarkup
- (gnc:html-table-row-markup table rownum)))
- ;; set default row markup
- (if (not rowmarkup)
- (set! rowmarkup "tr"))
-
- ;; push the style for this row and write the start tag, then
- ;; pop it again.
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
- (push (gnc:html-document-markup-start doc rowmarkup #t))
- (if rowstyle (gnc:html-document-pop-style doc))
-
- ;; write the column data, pushing the right column style
- ;; each time, then the row style.
- (for-each
- (lambda (datum)
- (let ((colstyle
- (gnc:html-table-col-style table colnum)))
- ;; push col and row styles
- (if colstyle (gnc:html-document-push-style doc colstyle))
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
-
- ;; render the cell contents
- (if (not (gnc:html-table-cell? datum))
- (push (gnc:html-document-markup-start doc "td" #t)))
+ ;; now iterate over the rows
+ (let rowloop ((rows (reverse (gnc:html-table-data table))) (rownum 0))
+ (unless (null? rows)
+ (let* ((row (car rows))
+ (rowstyle (gnc:html-table-row-style table rownum))
+ (rowmarkup (or (gnc:html-table-row-markup table rownum) "tr")))
+
+ ;; push the style for this row and write the start tag, then
+ ;; pop it again.
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+ (push (gnc:html-document-markup-start doc rowmarkup #t))
+ (when rowstyle (gnc:html-document-pop-style doc))
+
+ ;; write the column data, pushing the right column style
+ ;; each time, then the row style.
+ (let colloop ((cols row) (colnum 0))
+ (unless (null? cols)
+ (let* ((datum (car cols))
+ (colstyle (gnc:html-table-col-style table colnum)))
+ ;; push col and row styles
+ (when colstyle (gnc:html-document-push-style doc colstyle))
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+
+ ;; render the cell contents
+ (unless (gnc:html-table-cell? datum)
+ (push (gnc:html-document-markup-start doc "td" #t)))
(push (gnc:html-object-render datum doc))
- (if (not (gnc:html-table-cell? datum))
- (push (gnc:html-document-markup-end doc "td")))
-
- ;; pop styles
- (if rowstyle (gnc:html-document-pop-style doc))
- (if colstyle (gnc:html-document-pop-style doc))
- (set! colnum (+ 1 colnum))))
- row)
-
- ;; write the row end tag and pop the row style
- (if rowstyle (gnc:html-document-push-style doc rowstyle))
- (push (gnc:html-document-markup-end doc rowmarkup))
- (if rowstyle (gnc:html-document-pop-style doc))
-
- (set! colnum 0)
- (set! rownum (+ 1 rownum))))
- (reverse (gnc:html-table-data table))))
+ (unless (gnc:html-table-cell? datum)
+ (push (gnc:html-document-markup-end doc "td")))
+
+ ;; pop styles
+ (when rowstyle (gnc:html-document-pop-style doc))
+ (when colstyle (gnc:html-document-pop-style doc))
+ (colloop (cdr cols) (1+ colnum)))))
+
+ ;; write the row end tag and pop the row style
+ (when rowstyle (gnc:html-document-push-style doc rowstyle))
+ (push (gnc:html-document-markup-end doc rowmarkup))
+ (when rowstyle (gnc:html-document-pop-style doc))
+
+ (rowloop (cdr rows) (1+ rownum)))))
(push (gnc:html-document-markup-end doc "tbody"))
-
+
;; write the table end tag and pop the table style
(push (gnc:html-document-markup-end doc "table"))
(gnc:html-document-pop-style doc)
commit 1abda45cf62d4fea18aefa1877749f78b673e9f9
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:13:17 2019 +0800
[html-table] compact gnc:html-table-append-column!
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index d7f20c5a6..6703da501 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -457,72 +457,36 @@
row-loc rowdata)))))
(define (gnc:html-table-append-column! table newcol)
- (define (maxwidth table-data)
- (if (null? table-data) 0
- (max (length (car table-data)) (maxwidth (cdr table-data)))))
-
- ;; widen an individual row to the required width and append element
- (define (widen-and-append row element width)
- (let ((current-width (length row))
- (new-suffix (list element)))
- (do
- ((i current-width (+ i 1)))
- ((>= 1 (- width i)))
- (set! new-suffix (cons #f new-suffix)))
- (append row new-suffix)))
-
- ;; 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
- width-to-make)
- (if (= length-to-append 0)
+
+ ;; 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*
- ((current-new (car newcol))
- (current-existing (car existing-data))
- (rest-new (cdr newcol))
- (rest-existing (cdr existing-data))
- (rest-result (append-to-element rest-new rest-existing
- (- length-to-append 1)
- width-to-make)))
- (cons (cons (widen-and-append
- current-existing
- current-new
- width-to-make )
- (car rest-result))
- (cdr rest-result)))))
-
- (let* ((existing-data (reverse (gnc:html-table-data table)))
- (existing-length (length existing-data))
- (width-to-make (+ (maxwidth existing-data) 1))
- (newcol-length (length newcol)))
- (if (<= newcol-length existing-length)
- (gnc:html-table-set-data!
+ (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
- existing-data
- newcol-length
- width-to-make))))
- (let* ((temp-result (append-to-element
- newcol
- existing-data
- existing-length
- width-to-make))
- (joined-table-data (car temp-result))
- (remaining-elements (cdr temp-result)))
+ (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 joined-table-data))
-
- (for-each
+ (gnc:html-table-set-data! table (reverse (car res)))
+
+ (for-each
(lambda (element)
- (gnc:html-table-append-row! table
- (widen-and-append
- '()
- element
- width-to-make)))
- remaining-elements)
- #f))))
+ (gnc:html-table-append-row!
+ table (list-set-safe! '() old-numcols element)))
+ (cdr res))))))
(define (gnc:html-table-prepend-column! table newcol)
;; returns a pair, the car of which is the prepending of newcol
commit d45f06215f1f1d10cb360148f74f0385d76cb62e
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:12:59 2019 +0800
[html-table] compact gnc:html-table-prepend-row!
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 9654225a7..d7f20c5a6 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -340,35 +340,28 @@
'()))
(define (gnc:html-table-prepend-row! table newrow)
- (let* ((dd (gnc:html-table-data table))
- (current-num-rows (gnc:html-table-num-rows table))
- (new-num-rows (+ current-num-rows 1))
- (newrow-list (if (list? newrow) newrow (list newrow))))
- (set! dd (append dd (list newrow-list)))
- (gnc:html-table-set-num-rows-internal!
- table
- new-num-rows)
+ (let* ((new-num-rows (1+ (gnc:html-table-num-rows table)))
+ (newrow-list (if (list? newrow) newrow (list newrow)))
+ (dd (append (gnc:html-table-data table) (list newrow-list))))
+ (gnc:html-table-set-num-rows-internal! table new-num-rows)
(gnc:html-table-set-data! table dd)
-
+
;; have to bump up the row index of the row styles and row markup
;; table on a prepend. just another reason you probably don't
;; want to prepend.
(let ((new-rowstyles (make-hash-table 21)))
- (hash-fold
- (lambda (row style prev)
- (hash-set! new-rowstyles (+ 1 row) style)
- #f)
- #f (gnc:html-table-row-styles table))
+ (hash-for-each
+ (lambda (row style)
+ (hash-set! new-rowstyles (+ 1 row) style))
+ (gnc:html-table-row-styles table))
(gnc:html-table-set-row-styles! table new-rowstyles))
(let ((new-rowmarkup (make-hash-table 21)))
- (hash-fold
- (lambda (row markup prev)
- (hash-set! new-rowmarkup (+ 1 row) markup)
- #f)
- #f (gnc:html-table-row-markup-table table))
+ (hash-for-each
+ (lambda (row markup)
+ (hash-set! new-rowmarkup (+ 1 row) markup))
+ (gnc:html-table-row-markup-table table))
(gnc:html-table-set-row-markup-table! table new-rowmarkup))
-
new-num-rows))
;; list-set! is 0-based...
commit 49e651304261b04e79401487e97cd8d124baedd3
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 20:12:28 2019 +0800
[html-table] compact functions, define vars in formals
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index edf96071d..9654225a7 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -125,14 +125,10 @@
(record-modifier <html-table-cell> 'style))
(define (gnc:html-table-cell-set-style! cell tag . rest)
- (let ((newstyle #f)
+ (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)))
(styletable (gnc:html-table-cell-style cell)))
- (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)))
(gnc:html-style-table-set! styletable tag newstyle)))
(define (gnc:html-table-cell-append-objects! cell . objects)
@@ -250,81 +246,50 @@
(record-accessor <html-table> 'col-headers-style))
(define (gnc:html-table-set-col-headers-style! table tag . rest)
- (let ((newstyle #f)
+ (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)))
(style (gnc:html-table-col-headers-style table)))
- (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)))
(gnc:html-style-table-set! style tag newstyle)))
(define gnc:html-table-row-headers-style
(record-accessor <html-table> 'row-headers-style))
(define (gnc:html-table-set-row-headers-style! table tag . rest)
- (let ((newstyle #f)
- (style (gnc:html-table-row-headers-style table)))
- (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)))
+ (style (gnc:html-table-row-headers-style table)))
(gnc:html-style-table-set! style tag newstyle)))
(define (gnc:html-table-set-style! table tag . rest)
- (let ((newstyle #f)
- (style (gnc:html-table-style table)))
- (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)))
+ (style (gnc:html-table-style table)))
(gnc:html-style-table-set! style tag newstyle)))
(define (gnc:html-table-set-col-style! table col tag . rest)
- (let ((newstyle #f)
- (style #f)
- (newhash #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)))
- (set! style
- (gnc:html-table-col-style table col))
- (if (not style)
- (begin
- (set! style (gnc:make-html-style-table))
- (set! newhash #t)))
+ (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)))
+ (newhash #f)
+ (style (or (gnc:html-table-col-style table col)
+ (begin (set! newhash #t)
+ (gnc:make-html-style-table)))))
(gnc:html-style-table-set! style tag newstyle)
- (if newhash
- (hash-set! (gnc:html-table-col-styles table) col style))))
+ (if newhash (hash-set! (gnc:html-table-col-styles table) col style))))
(define (gnc:html-table-set-row-style! table row tag . rest)
- (let ((newstyle #f)
- (style #f)
- (newhash #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)))
- (set! style
- (gnc:html-table-row-style table row))
- (if (not style)
- (begin
- (set! style (gnc:make-html-style-table))
- (set! newhash #t)))
+ (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)))
+ (newhash #f)
+ (style (or (gnc:html-table-row-style table row)
+ (begin (set! newhash #t)
+ (gnc:make-html-style-table)))))
(gnc:html-style-table-set! style tag newstyle)
- (if newhash
- (hash-set!
- (gnc:html-table-row-styles table) row style))))
+ (when newhash (hash-set! (gnc:html-table-row-styles table) row style))))
(define (gnc:html-table-row-style table row)
(hash-ref (gnc:html-table-row-styles table) row))
@@ -346,9 +311,8 @@
(gnc:html-table-set-row-markup! table (- rownum 1) markup)))
(define (gnc:html-table-prepend-row/markup! table markup newrow)
- (begin
- (gnc:html-table-prepend-row! table newrow)
- (gnc:html-table-set-row-markup! table 0 markup)))
+ (gnc:html-table-prepend-row! table newrow)
+ (gnc:html-table-set-row-markup! table 0 markup))
(define (gnc:html-table-append-row! table newrow)
commit 3a2c85f577ed580d39a51abbbf043fe7155001c6
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Oct 8 22:59:31 2019 +0800
[html-table] deprecate gnc:html-table-remove-last-row!
this function is unused in code.
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index a54206897..edf96071d 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -361,6 +361,7 @@
new-num-rows))
(define (gnc:html-table-remove-last-row! table)
+ (issue-deprecation-warning "gnc:html-table-remove-last-row! is unused.")
(if (> (gnc:html-table-num-rows table) 0)
(begin
(gnc:html-table-set-num-rows-internal!
commit f4794d516ffa194dcf2fe4af9e4cd2ace2c30f65
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Wed Oct 9 05:40:00 2019 +0800
[test-report-html] add tests for html-table-cell row/col modifiers
diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm
index e4178e316..6c5a3e637 100644
--- a/gnucash/report/report-system/test/test-report-html.scm
+++ b/gnucash/report/report-system/test/test-report-html.scm
@@ -798,6 +798,40 @@ HTML Document Title</title></head><body></body>\n\
)
(test-end "HTML Table - Table Rendering")
+ (test-begin "html-table arbitrary row/col modification")
+ (let ((doc (gnc:make-html-document))
+ (table (gnc:make-html-table)))
+ (gnc:html-table-set-cell! table 0 0 "x")
+ (test-equal "html-table-set-cell! 0 0"
+ "<table><tbody><tr><td rowspan=\"1\" colspan=\"1\"><string> x</td>\n</tr>\n</tbody>\n</table>\n"
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-render table doc))))
+
+ (gnc:html-table-set-cell! table 2 2 "y" "z")
+ (test-equal "html-table-set-cell! 2 2"
+ "<table><tbody><tr><td rowspan=\"1\" colspan=\"1\"><string> x</td>\n</tr>\n<tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td rowspan=\"1\" colspan=\"1\"><string> y<string> z</td>\n</tr>\n</tbody>\n</table>\n"
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-render table doc))))
+
+ (let* ((table1 (gnc:make-html-table))
+ (cell (gnc:make-html-table-cell "ab")))
+ (gnc:html-table-set-cell! table1 1 4 cell)
+ (test-equal "html-table-set-cell! 1 4"
+ "<table><tbody><tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td rowspan=\"1\" colspan=\"1\"><string> ab</td>\n</tr>\n</tbody>\n</table>\n"
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-render table1 doc))))
+
+ (gnc:html-table-set-cell/tag! table1 1 4 "tag" cell)
+ (test-equal "html-table-set-cell/tag! 1 4"
+ "<table><tbody><tr></tr>\n<tr><td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<td><string> </td>\n<tag rowspan=\"1\" colspan=\"1\"><string> ab</tag>\n</tr>\n</tbody>\n</table>\n"
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-render table1 doc))))))
+ (test-end "html-table arbitrary row/col modification")
+
(test-begin "html-table-cell renderers")
(let ((doc (gnc:make-html-document))
(cell (gnc:make-html-table-cell 4)))
commit 7bb7d3cdd655d23c7af902e57aa6326df59933c1
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Oct 7 23:18:34 2019 +0800
[html-document] schemify gnc:html-document-tree-collapse
this function is technically a flattening function, converted to
classic scheme form. very efficient in time and space. it is used
extensively in reports which are still running well, therefore no
additional testing is required.
diff --git a/gnucash/report/report-system/html-document.scm b/gnucash/report/report-system/html-document.scm
index ecb045e2c..906ab30b8 100644
--- a/gnucash/report/report-system/html-document.scm
+++ b/gnucash/report/report-system/html-document.scm
@@ -105,20 +105,11 @@
(apply gnc:make-html-data-style-info rest)
(apply gnc:make-html-markup-style-info rest))))
-(define (gnc:html-document-tree-collapse tree)
- (let ((retval '()))
- (let loop ((lst tree))
- (for-each
- (lambda (elt)
- (cond
- ((string? elt)
- (set! retval (cons elt retval)))
- ((not (list? elt))
- (set! retval (cons (object->string elt) retval)))
- (else
- (loop elt))))
- lst))
- retval))
+(define (gnc:html-document-tree-collapse . tree)
+ (let lp ((e tree) (accum '()))
+ (cond ((list? e) (fold lp accum e))
+ ((string? e) (cons e accum))
+ (else (cons (object->string e) accum)))))
;; first optional argument is "headers?"
;; returns the html document as a string, I think.
commit f4379bbd8c33c2208aeadb5a5bdb7888a329db87
Author: Frank H. Ellenberger <frank.h.ellenberger at gmail.com>
Date: Tue Oct 8 22:48:42 2019 +0200
UK VAT template: replace obsolete EEC and EC by EU
diff --git a/data/accounts/en_GB/uk-vat.gnucash-xea b/data/accounts/en_GB/uk-vat.gnucash-xea
index 31bdb59eb..8222baa89 100644
--- a/data/accounts/en_GB/uk-vat.gnucash-xea
+++ b/data/accounts/en_GB/uk-vat.gnucash-xea
@@ -137,7 +137,7 @@
<act:parent type="new">9c566ece97799eda4e900b003ce48e48</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
- <act:name>EC Reverse VAT Purchase</act:name>
+ <act:name>EU Reverse VAT Purchase</act:name>
<act:id type="new">6708e3ff1292c2b5defd07da9f858b60</act:id>
<act:type>ASSET</act:type>
<act:commodity>
@@ -273,7 +273,7 @@
<act:parent type="new">3352145930e40b21fee20532ad07501b</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
- <act:name>EC</act:name>
+ <act:name>EU</act:name>
<act:id type="new">37d726ec68d451d098496b7f5513f6f8</act:id>
<act:type>LIABILITY</act:type>
<act:commodity>
@@ -293,7 +293,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
- <act:description>All, including zero rate UK/EC and World (Box 1)</act:description>
+ <act:description>All, including zero rate UK/EU and World (Box 1)</act:description>
<act:parent type="new">a46d9e9624070fcd2427973a4c725ed6</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -483,7 +483,7 @@
<act:parent type="new">86ef7451027dcb6223bb01204ac09a5e</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
- <act:name>EEC</act:name>
+ <act:name>EU</act:name>
<act:id type="new">af74692df15b1de7665d5dd7a197cdfb</act:id>
<act:type>INCOME</act:type>
<act:commodity>
@@ -491,7 +491,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
- <act:description>Sales in EEC</act:description>
+ <act:description>Sales in EU</act:description>
<act:slots>
<slot>
<slot:key>placeholder</slot:key>
@@ -509,7 +509,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
- <act:description>Sale of goods within EEC</act:description>
+ <act:description>Sale of goods within EU</act:description>
<act:parent type="new">af74692df15b1de7665d5dd7a197cdfb</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
@@ -521,7 +521,7 @@
<cmdty:id>GBP</cmdty:id>
</act:commodity>
<act:commodity-scu>100</act:commodity-scu>
- <act:description>Sale of services within EEC</act:description>
+ <act:description>Sale of services within EU</act:description>
<act:slots>
<slot>
<slot:key>notes</slot:key>
@@ -726,7 +726,7 @@
<act:parent type="new">d77071fafc0de8455dd566b805bfcc40</act:parent>
</gnc:account>
<gnc:account version="2.0.0">
- <act:name>EEC Reverse VAT</act:name>
+ <act:name>EU Reverse VAT</act:name>
<act:id type="new">af9b5ef4814015a83053a4c991ca0c1a</act:id>
<act:type>EXPENSE</act:type>
<act:commodity>
commit 93a24b62ce54dfc0d42f8409f2a7aaefac2830b1
Merge: a90b87499 3e8c9ad80
Author: John Ralls <jralls at ceridwen.us>
Date: Mon Oct 7 10:17:51 2019 -0700
Merge Ingo Haschler's 'opticalTAN' into maint.
commit a90b874995e2234da9e2d360e693fe48b8e11ece
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Oct 7 21:54:38 2019 +0800
Bug 759005 - Print negatives in red, bis
addendum to 9d0d3fd3b; addition to negative monetaries, also print
negative numbers in red
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index 636c04129..a54206897 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -141,17 +141,19 @@
(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
- ;; gnc:monetary, it fixes the tag eg. "number-cell" becomes
- ;; "number-cell-red". The gnc:monetary renderer does not have an
- ;; automatic -neg tag modifier. See bug 759005 and bug 797357.
+ ;; 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.
(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))
- (gnc:gnc-monetary? (car cell-data))
- (negative? (gnc:gnc-monetary-amount (car cell-data))))
+ (or (and (gnc:gnc-monetary? (car cell-data))
+ (negative? (gnc:gnc-monetary-amount (car cell-data))))
+ (and (number? (car cell-data))
+ (negative? (car cell-data)))))
(string-append cell-tag "-neg")
cell-tag)))
(gnc:html-document-push-style doc (gnc:html-table-cell-style cell))
commit 2d9969262112efa35a14f3fb3ed9627985a57579
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Oct 7 21:03:37 2019 +0800
[budget] bug 759005 we don't need style-tag "-neg" anymore
diff --git a/gnucash/report/standard-reports/budget.scm b/gnucash/report/standard-reports/budget.scm
index b5c1c6443..80b98dd6a 100644
--- a/gnucash/report/standard-reports/budget.scm
+++ b/gnucash/report/standard-reports/budget.scm
@@ -350,25 +350,24 @@
;; col - next column
(define (disp-cols style-tag col0
bgt-val act-val dif-val)
- (let* ((style-tag-neg (string-append style-tag "-neg"))
- (col1 (+ col0 (if show-budget? 1 0)))
+ (let* ((col1 (+ col0 (if show-budget? 1 0)))
(col2 (+ col1 (if show-actual? 1 0)))
(col3 (+ col2 (if show-diff? 1 0))))
(if show-budget?
(gnc:html-table-set-cell/tag!
html-table rownum col0
- (if (negative? bgt-val) style-tag-neg style-tag)
+ style-tag
(if (zero? bgt-val) "."
(gnc:make-gnc-monetary comm bgt-val))))
(if show-actual?
(gnc:html-table-set-cell/tag!
html-table rownum col1
- (if (negative? act-val) style-tag-neg style-tag)
+ style-tag
(gnc:make-gnc-monetary comm act-val)))
(if show-diff?
(gnc:html-table-set-cell/tag!
html-table rownum col2
- (if (negative? dif-val) style-tag-neg style-tag)
+ style-tag
(if (and (zero? bgt-val) (zero? act-val)) "."
(gnc:make-gnc-monetary comm dif-val))))
col3))
commit 9d0d3fd3be45015a1dbf2800a049eb40361fd09f
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Mon Oct 7 20:16:06 2019 +0800
Bug 759005 - Print negatives in red
Fixes display of negative monetary-amounts so that they are rendered
according to style-sheet option.
Note this commit fixes via <td> renderer -- if it has a single datum, and
has a negative monetary amount, then its tag gets "-neg" appended.
If a gnc:monetary is renderer *outside* html-table-cell, it will not
be rendered as red (in default stylesheet).
diff --git a/gnucash/report/report-system/html-table.scm b/gnucash/report/report-system/html-table.scm
index ceedb8ece..636c04129 100644
--- a/gnucash/report/report-system/html-table.scm
+++ b/gnucash/report/report-system/html-table.scm
@@ -140,25 +140,30 @@
cell (append (gnc:html-table-cell-data cell) objects)))
(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
+ ;; gnc:monetary, it fixes the tag eg. "number-cell" becomes
+ ;; "number-cell-red". The gnc:monetary renderer does not have an
+ ;; automatic -neg tag modifier. See bug 759005 and bug 797357.
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval))))
- (style (gnc:html-table-cell-style cell)))
-
-; ;; why dont colspans export??!
-; (gnc:html-table-cell-set-style! cell "td"
-; 'attribute (list "colspan"
-; (or (gnc:html-table-cell-colspan cell) 1)))
- (gnc:html-document-push-style doc style)
- (push (gnc:html-document-markup-start
- doc (gnc:html-table-cell-tag cell) #t
+ (cell-tag (gnc:html-table-cell-tag cell))
+ (cell-data (gnc:html-table-cell-data cell))
+ (tag (if (and (= 1 (length cell-data))
+ (gnc:gnc-monetary? (car cell-data))
+ (negative? (gnc:gnc-monetary-amount (car cell-data))))
+ (string-append cell-tag "-neg")
+ cell-tag)))
+ (gnc:html-document-push-style doc (gnc:html-table-cell-style cell))
+ (push (gnc:html-document-markup-start
+ doc tag #t
(format #f "rowspan=\"~a\"" (gnc:html-table-cell-rowspan cell))
(format #f "colspan=\"~a\"" (gnc:html-table-cell-colspan cell))))
- (for-each
- (lambda (child)
+ (for-each
+ (lambda (child)
(push (gnc:html-object-render child doc)))
- (gnc:html-table-cell-data cell))
- (push (gnc:html-document-markup-end
- doc (gnc:html-table-cell-tag cell)))
+ cell-data)
+ (push (gnc:html-document-markup-end doc cell-tag))
(gnc:html-document-pop-style doc)
retval))
diff --git a/gnucash/report/report-system/test/test-report-html.scm b/gnucash/report/report-system/test/test-report-html.scm
index e4a854d48..e4178e316 100644
--- a/gnucash/report/report-system/test/test-report-html.scm
+++ b/gnucash/report/report-system/test/test-report-html.scm
@@ -798,6 +798,31 @@ HTML Document Title</title></head><body></body>\n\
)
(test-end "HTML Table - Table Rendering")
+ (test-begin "html-table-cell renderers")
+ (let ((doc (gnc:make-html-document))
+ (cell (gnc:make-html-table-cell 4)))
+ (test-equal "html-table-cell renders correctly"
+ "<td rowspan=\"1\" colspan=\"1\"><number> 4</td>\n"
+ (string-concatenate
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-cell-render cell doc)))))
+
+ ;; the following is tailor-made to test bug 797357. if the report
+ ;; system is refactored, this test will probably need fixing. it
+ ;; aims to ensure the table-cell class eg 'number-cell'
+ ;; 'total-number-cell' is augmented with a '-neg', and the
+ ;; resulting renderer renders as <td class='number-cell neg' ...>
+ (let* ((doc (gnc:make-html-document))
+ (comm-table (gnc-commodity-table-get-table (gnc-get-current-book)))
+ (USD (gnc-commodity-table-lookup comm-table "CURRENCY" "USD"))
+ (cell (gnc:make-html-table-cell (gnc:make-gnc-monetary USD -10))))
+ (test-equal "html-table-cell negative-monetary -> tag gets -neg appended"
+ "td-neg"
+ (cadr
+ (gnc:html-document-tree-collapse
+ (gnc:html-table-cell-render cell doc)))))
+ (test-end "html-table-cell renderers")
+
(test-end "HTML Tables - without style sheets")
)
commit b00a95c0b39e2666eac09bf13304782492d886b8
Author: Geert Janssens <geert at kobaltwit.be>
Date: Sun Oct 6 21:27:10 2019 +0200
Tweak install rule to be able to compile glib's schema's on Windows as well
(Cherry picked from master)
It's a bit of a hack based on the assumption DESTDIR is never set on Windows.
A install time guard is added to assert this.
It needed a few changes to make this working:
- Have cmake expand DESTDIR instead of delaying this to bash
If not, bash would see "$DESTDIRC:/gcdev64/..." and we'd loose
the drive letter in bash' expansion of $DESTDIRC.
So work with $ENV{DESTDIR} instead
- To prevent cmake from already expanding this in the
build system generation step add the appropriate escapes to
that variable.
- Add guard code in the install command that asserts
DESTDIR is not set on Windows. Use similar escapes as
necessary to ensure the evaluation happens at install time
rather than in the generation step.
diff --git a/CMakeLists.txt b/CMakeLists.txt
index 1d1c327b1..20ec5ce10 100644
--- a/CMakeLists.txt
+++ b/CMakeLists.txt
@@ -86,6 +86,8 @@ foreach(install_dir ${CMAKE_INSTALL_FULL_BINDIR}
break()
endif()
endforeach()
+message(STATUS "CMAKE_INSTALL_FULL_DATADIR: ${CMAKE_INSTALL_FULL_DATADIR}")
+message(STATUS "DESTDIR: ${DESTDIR}")
# GnuCash installs two files in ${CMAKE_INSTALL_SYSCONFDIR}
set(BINDIR ${CMAKE_INSTALL_BINDIR} CACHE STRING "user executables")
diff --git a/gnucash/gschemas/CMakeLists.txt b/gnucash/gschemas/CMakeLists.txt
index 0b1fcb91b..735e5c11d 100644
--- a/gnucash/gschemas/CMakeLists.txt
+++ b/gnucash/gschemas/CMakeLists.txt
@@ -32,10 +32,20 @@ if (COMPILE_GSCHEMAS)
add_custom_target(compiled-schemas ALL DEPENDS ${SCHEMADIR_BUILD}/gschemas.compiled)
-
- install(CODE "execute_process(
- COMMAND ${SHELL} -c \"echo Compiling gschema files in $DESTDIR${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas ;
- ${GLIB_COMPILE_SCHEMAS} $DESTDIR${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas\")")
+ # On Windows concatenating two absolute paths results in an invalid path (having two drive letters)
+ # If DESTDIR is not set on the other hand, the below install command works just fine
+ # So verify DESTDIR is not set on Windows
+ # Note we have to do this at build time, not configure time so the guard is part of the custom install command
+ install(CODE "
+ if (WIN32)
+ set (DESTDIR \$ENV\{DESTDIR\})
+ if (DESTDIR)
+ message(SEND_ERROR \"GnuCash can't be built with the DESTDIR environment variable set on Windows (due to bad interference with glib-compile-schemas).\")
+ endif()
+ endif()
+ execute_process(
+ COMMAND ${SHELL} -c \"echo Compiling gschema files in \$ENV\{DESTDIR\}${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas ;
+ ${GLIB_COMPILE_SCHEMAS} \$ENV\{DESTDIR\}${CMAKE_INSTALL_FULL_DATADIR}/glib-2.0/schemas\")")
endif ()
set(gschemas_DIST_local "")
commit 3e8c9ad807d8ce9b6bef5fefc1b34cd9ab762329
Author: Ingo Haschler <ih at ingohaschler.de>
Date: Thu Sep 26 22:03:05 2019 +0200
Partly fixes bug 667490. It implements the presentation of static optical TAN challenges (photoTAN and QR) inside the enter TAN dialogue.
diff --git a/gnucash/import-export/aqb/dialog-ab.glade b/gnucash/import-export/aqb/dialog-ab.glade
index 829f19ddf..03632c5dc 100644
--- a/gnucash/import-export/aqb/dialog-ab.glade
+++ b/gnucash/import-export/aqb/dialog-ab.glade
@@ -664,6 +664,22 @@
<property name="position">0</property>
</packing>
</child>
+ <child>
+ <object class="GtkImage" id="optical_challenge">
+ <property name="name">optical_challenge</property>
+ <property name="visible">True</property>
+ <property name="can_focus">False</property>
+ <property name="hexpand">True</property>
+ <property name="vexpand">True</property>
+ <property name="stock">gtk-missing-image</property>
+ <property name="icon_size">6</property>
+ </object>
+ <packing>
+ <property name="expand">False</property>
+ <property name="fill">True</property>
+ <property name="position">2</property>
+ </packing>
+ </child>
<child>
<object class="GtkGrid" id="grid1">
<property name="visible">True</property>
@@ -751,7 +767,7 @@
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
- <property name="position">1</property>
+ <property name="position">3</property>
</packing>
</child>
</object>
diff --git a/gnucash/import-export/aqb/gnc-gwen-gui.c b/gnucash/import-export/aqb/gnc-gwen-gui.c
index d3c9fe012..9fda5adf8 100644
--- a/gnucash/import-export/aqb/gnc-gwen-gui.c
+++ b/gnucash/import-export/aqb/gnc-gwen-gui.c
@@ -170,9 +170,16 @@ static gboolean keep_alive(GncGWENGui *gui);
static void cm_close_handler(gpointer user_data);
static void erase_password(gchar *password);
static gchar *strip_html(gchar *text);
+#ifndef AQBANKING6
static void get_input(GncGWENGui *gui, guint32 flags, const gchar *title,
const gchar *text, gchar **input, gint min_len,
gint max_len);
+#else
+static void get_input(GncGWENGui *gui, guint32 flags, const gchar *title,
+ const gchar *text, const char *mimeType,
+ const char *pChallenge, uint32_t lChallenge,
+ gchar **input, gint min_len, gint max_len);
+#endif
static gint messagebox_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *title,
const gchar *text, const gchar *b1, const gchar *b2,
const gchar *b3, guint32 guiid);
@@ -190,7 +197,7 @@ static gint progress_advance_cb(GWEN_GUI *gwen_gui, uint32_t id,
static gint progress_log_cb(GWEN_GUI *gwen_gui, guint32 id,
GWEN_LOGGER_LEVEL level, const gchar *text);
static gint progress_end_cb(GWEN_GUI *gwen_gui, guint32 id);
-#ifndef GWENHYWFAR5
+#ifndef AQBANKING6
static gint GNC_GWENHYWFAR_CB getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags,
const gchar *token,
const gchar *title,
@@ -977,8 +984,15 @@ strip_html(gchar *text)
}
static void
+#ifndef AQBANKING6
get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text,
gchar **input, gint min_len, gint max_len)
+#else
+get_input(GncGWENGui *gui, guint32 flags, const gchar *title,
+ const gchar *text, const char *mimeType,
+ const char *pChallenge, uint32_t lChallenge,
+ gchar **input, gint min_len, gint max_len)
+#endif
{
GtkBuilder *builder;
GtkWidget *dialog;
@@ -987,6 +1001,7 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text,
GtkWidget *confirm_entry;
GtkWidget *confirm_label;
GtkWidget *remember_pin_checkbutton;
+ GtkImage *optical_challenge;
const gchar *internal_input, *internal_confirmed;
gboolean confirm = (flags & GWEN_GUI_INPUT_FLAGS_CONFIRM) != 0;
gboolean is_tan = (flags & GWEN_GUI_INPUT_FLAGS_TAN) != 0;
@@ -1006,6 +1021,14 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text,
confirm_entry = GTK_WIDGET(gtk_builder_get_object (builder, "confirm_entry"));
confirm_label = GTK_WIDGET(gtk_builder_get_object (builder, "confirm_label"));
remember_pin_checkbutton = GTK_WIDGET(gtk_builder_get_object (builder, "remember_pin"));
+ optical_challenge = GTK_IMAGE(gtk_builder_get_object (builder, "optical_challenge"));
+ gtk_widget_set_visible(GTK_WIDGET(optical_challenge), FALSE);
+ #ifdef AQBANKING6
+ if(mimeType != NULL && pChallenge != NULL && lChallenge > 0)
+ {
+ gtk_widget_set_visible(GTK_WIDGET(optical_challenge), TRUE);
+ }
+ #endif
if (is_tan)
{
gtk_widget_hide(remember_pin_checkbutton);
@@ -1035,6 +1058,35 @@ get_input(GncGWENGui *gui, guint32 flags, const gchar *title, const gchar *text,
g_free(raw_text);
}
+ #ifdef AQBANKING6
+ //if (optical_challenge)
+ if(mimeType != NULL && pChallenge != NULL && lChallenge > 0)
+ {
+ // convert PNG and load into widget
+ // TBD: check mimeType?
+ guchar *gudata = (guchar*)pChallenge;
+
+ GError *error = NULL;
+ GdkPixbufLoader *loader = gdk_pixbuf_loader_new_with_mime_type(mimeType, &error);
+ GdkPixbuf *pixbuf;
+
+ if(error != NULL)
+ {
+ PERR("Pixbuf loader not loaded: %s, perhaps MIME type %s isn't supported.", error->message, mimeType);
+ }
+
+ gdk_pixbuf_loader_write(loader, gudata, lChallenge, NULL);
+ gdk_pixbuf_loader_close(loader, NULL);
+
+ pixbuf = gdk_pixbuf_loader_get_pixbuf(loader);
+
+ g_object_ref(pixbuf);
+ g_object_unref(loader);
+
+ gtk_image_set_from_pixbuf(optical_challenge, pixbuf);
+ }
+ #endif
+
if (*input)
{
gtk_entry_set_text(GTK_ENTRY(input_entry), *input);
@@ -1170,7 +1222,11 @@ inputbox_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *title,
ENTER("gui=%p, flags=%d", gui, flags);
+ #ifndef AQBANKING6
get_input(gui, flags, title, text, &input, min_len, max_len);
+ #else
+ get_input(gui, flags, title, text, NULL, NULL, 0, &input, min_len, max_len);
+ #endif
if (input)
{
@@ -1406,7 +1462,7 @@ progress_end_cb(GWEN_GUI *gwen_gui, guint32 id)
}
static gint GNC_GWENHYWFAR_CB
-#ifndef GWENHYWFAR5
+#ifndef AQBANKING6
getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token,
const gchar *title, const gchar *text, gchar *buffer,
gint min_len, gint max_len, guint32 guiid)
@@ -1421,8 +1477,46 @@ getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token,
gchar *password = NULL;
gboolean is_tan = (flags & GWEN_GUI_INPUT_FLAGS_TAN) != 0;
+ #ifdef AQBANKING6
+ int opticalMethodId;
+ const char *mimeType = NULL;
+ const char *pChallenge = NULL;
+ uint32_t lChallenge = 0;
+ #endif
+
g_return_val_if_fail(gui, -1);
+ #ifdef AQBANKING6
+ // cf. https://www.aquamaniac.de/rdm/projects/aqbanking/wiki/ImplementTanMethods
+ if(is_tan && methodId == GWEN_Gui_PasswordMethod_OpticalHHD)
+ {
+ /**
+ * TODO: How to handle Flicker code (use WebView and JS???)
+ *
+ * use GWEN_Gui_PasswordMethod_Mask to get the basic method id
+ * cf. gui/gui.h of gwenhywfar
+ */
+ opticalMethodId=GWEN_DB_GetIntValue(methodParams, "tanMethodId", 0, AB_BANKING_TANMETHOD_TEXT);
+ switch(opticalMethodId)
+ {
+ case AB_BANKING_TANMETHOD_PHOTOTAN:
+ case AB_BANKING_TANMETHOD_CHIPTAN_QR:
+ /**
+ * image data is in methodParams
+ */
+ mimeType=GWEN_DB_GetCharValue(methodParams, "mimeType", 0, NULL);
+ pChallenge=(const char*) GWEN_DB_GetBinValue(methodParams, "imageData", 0, NULL, 0, &lChallenge);
+ if (!(pChallenge && lChallenge)) {
+ /* empty optical data */
+ return GWEN_ERROR_NO_DATA;
+ }
+ break;
+ default:
+ break;
+ }
+ }
+ #endif
+
ENTER("gui=%p, flags=%d, token=%s", gui, flags, token ? token : "(null");
/* Check remembered passwords, excluding TANs */
@@ -1450,7 +1544,11 @@ getpassword_cb(GWEN_GUI *gwen_gui, guint32 flags, const gchar *token,
}
}
+ #ifndef AQBANKING6
get_input(gui, flags, title, text, &password, min_len, max_len);
+ #else
+ get_input(gui, flags, title, text, mimeType, pChallenge, lChallenge, &password, min_len, max_len);
+ #endif
if (password)
{
Summary of changes:
data/accounts/en_GB/uk-vat.gnucash-xea | 16 +-
gnucash/import-export/aqb/dialog-ab.glade | 18 +-
gnucash/import-export/aqb/gnc-gwen-gui.c | 102 +++-
gnucash/report/html-document.scm | 19 +-
gnucash/report/html-table.scm | 598 ++++++++-------------
gnucash/report/reports/example/average-balance.scm | 12 +-
gnucash/report/reports/standard/budget.scm | 9 +-
.../reports/standard/test/test-average-balance.scm | 16 +-
gnucash/report/test/test-report-html.scm | 60 +++
9 files changed, 438 insertions(+), 412 deletions(-)
More information about the gnucash-changes
mailing list