gnucash maint: Multiple changes pushed
Christopher Lam
clam at code.gnucash.org
Fri May 3 18:20:11 EDT 2019
Updated via https://github.com/Gnucash/gnucash/commit/6e246ef8 (commit)
via https://github.com/Gnucash/gnucash/commit/6dd04cfa (commit)
via https://github.com/Gnucash/gnucash/commit/1338162d (commit)
via https://github.com/Gnucash/gnucash/commit/375013f9 (commit)
via https://github.com/Gnucash/gnucash/commit/e111c5bb (commit)
via https://github.com/Gnucash/gnucash/commit/f2aacf94 (commit)
via https://github.com/Gnucash/gnucash/commit/fbcf4882 (commit)
via https://github.com/Gnucash/gnucash/commit/ce675eaa (commit)
via https://github.com/Gnucash/gnucash/commit/b2dc906b (commit)
via https://github.com/Gnucash/gnucash/commit/9ef2a2f3 (commit)
via https://github.com/Gnucash/gnucash/commit/91f3e9fe (commit)
from https://github.com/Gnucash/gnucash/commit/76936bc6 (commit)
commit 6e246ef8ad818b3c04e62939f686f478afbe8877
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Thu Apr 11 23:18:46 2019 +0800
[options] compact option-setter in generator
slightly more compact, avoids confusing structure whereby 'option' is
both the lambda's argument and the definition of argument.
diff --git a/libgnucash/app-utils/options.scm b/libgnucash/app-utils/options.scm
index 9f9bf62e9..48b84e525 100644
--- a/libgnucash/app-utils/options.scm
+++ b/libgnucash/app-utils/options.scm
@@ -202,11 +202,9 @@ the option '~a'."))
(define (gnc:restore-form-generator value->string)
- (lambda () (string-append
- "(lambda (option) "
- "(if option ((gnc:option-setter option) "
- (value->string)
- ")))")))
+ (lambda ()
+ (string-append "(lambda (o) (if o (gnc:option-set-value o "
+ (value->string) ")))")))
(define (gnc:value->string value)
(format #f "~s" value))
commit 6dd04cfa58d46d855ab510d4926e43ce4605082e
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Apr 9 06:59:44 2019 +0800
[stylesheet-plain] compact functions
diff --git a/gnucash/report/stylesheets/stylesheet-plain.scm b/gnucash/report/stylesheets/stylesheet-plain.scm
index 97983a4b1..6cb790942 100644
--- a/gnucash/report/stylesheets/stylesheet-plain.scm
+++ b/gnucash/report/stylesheets/stylesheet-plain.scm
@@ -84,35 +84,28 @@
options))
(define (plain-renderer options doc)
- (let*
- ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (bgcolor
- (gnc:color-option->html
- (gnc:lookup-option options
- "General"
- "Background Color")))
- (bgpixmap (opt-val "General" "Background Pixmap"))
- (links? (opt-val "General" "Enable Links"))
- (alternate-row-color
- (gnc:color-option->html
- (gnc:lookup-option options
- "Colors"
- "Alternate Table Cell Color")))
- (spacing (opt-val "Tables" "Table cell spacing"))
- (padding (opt-val "Tables" "Table cell padding"))
- (border (opt-val "Tables" "Table border width"))
- )
+ (define (opt-val section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name)))
+ (let* ((ssdoc (gnc:make-html-document))
+ (bgcolor
+ (gnc:color-option->html
+ (gnc:lookup-option options "General" "Background Color")))
+ (bgpixmap (opt-val "General" "Background Pixmap"))
+ (links? (opt-val "General" "Enable Links"))
+ (alternate-row-color
+ (gnc:color-option->html
+ (gnc:lookup-option options "Colors" "Alternate Table Cell Color")))
+ (spacing (opt-val "Tables" "Table cell spacing"))
+ (padding (opt-val "Tables" "Table cell padding"))
+ (border (opt-val "Tables" "Table border width")))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "bgcolor" bgcolor))
(if (and bgpixmap
- (not (string=? bgpixmap "")))
+ (not (string-null? bgpixmap)))
(gnc:html-document-set-style!
ssdoc "body"
'attribute (list "background" (make-file-url bgpixmap))))
@@ -218,18 +211,15 @@
(add-css-information-to-doc options ssdoc doc)
- (let* ((title (gnc:html-document-title doc))
- (doc-headline (gnc:html-document-headline doc))
- (headline (if (eq? doc-headline #f)
- title doc-headline)))
+ (let ((headline (or (gnc:html-document-headline doc)
+ (gnc:html-document-title doc))))
(if headline
(gnc:html-document-add-object!
ssdoc
(gnc:make-html-text
(gnc:html-markup-h3 headline)))))
- (gnc:html-document-append-objects! ssdoc
- (gnc:html-document-objects doc))
+ (gnc:html-document-append-objects! ssdoc (gnc:html-document-objects doc))
ssdoc))
commit 1338162d144fcf0e7dc896d28cf245083dc43045
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Apr 9 06:57:45 2019 +0800
[stylesheets] *reindent/delete-trailing-whitespace/untabify*
diff --git a/gnucash/report/stylesheets/stylesheet-easy.scm b/gnucash/report/stylesheets/stylesheet-easy.scm
index 3f5cff55d..b1eed52f5 100644
--- a/gnucash/report/stylesheets/stylesheet-easy.scm
+++ b/gnucash/report/stylesheets/stylesheet-easy.scm
@@ -4,23 +4,23 @@
;;
;; Copyright 2004 James Strandboge <jstrand1 at rochester.rr.com>
;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2 of
-;; the License, or (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu at gnu.org
-;;
+;;
;; Based on work from:
;; stylesheet-header.scm
;; Copyright 2000 Bill Gribble <grib at gnumatic.com>
@@ -29,7 +29,7 @@
(define-module (gnucash report stylesheet-easy))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
@@ -38,34 +38,34 @@
(define (easy-options)
(let* ((options (gnc:new-options))
- (opt-register
- (lambda (opt)
- (gnc:register-option options opt))))
- (opt-register
+ (opt-register
+ (lambda (opt)
+ (gnc:register-option options opt))))
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Preparer") "a"
- (N_ "Name of person preparing the report.")
+ (N_ "Name of person preparing the report.")
""))
- (opt-register
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Prepared for") "b"
- (N_ "Name of organization or company prepared for.")
+ (N_ "Name of organization or company prepared for.")
""))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Show preparer info") "c"
- (N_ "Name of organization or company.")
+ (N_ "Name of organization or company.")
#f))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Enable Links") "d"
- (N_ "Enable hyperlinks in reports.")
+ (N_ "Enable hyperlinks in reports.")
#t))
-
+
(opt-register
(gnc:make-pixmap-option
(N_ "Images")
@@ -82,14 +82,14 @@
(N_ "Heading Alignment") "c" (N_ "Banner for top of report.")
'left
(list (vector 'left
- (N_ "Left")
- (N_ "Align the banner to the left."))
+ (N_ "Left")
+ (N_ "Align the banner to the left."))
(vector 'center
- (N_ "Center")
- (N_ "Align the banner in the center."))
+ (N_ "Center")
+ (N_ "Align the banner in the center."))
(vector 'right
- (N_ "Right")
- (N_ "Align the banner to the right."))
+ (N_ "Right")
+ (N_ "Align the banner to the right."))
)))
(opt-register
(gnc:make-pixmap-option
@@ -102,14 +102,14 @@
(N_ "Colors")
(N_ "Background Color") "a" (N_ "General background color for report.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
(N_ "Colors")
(N_ "Text Color") "b" (N_ "Normal body text color.")
(list #x00 #x00 #x00 #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -123,7 +123,7 @@
(N_ "Colors")
(N_ "Table Cell Color") "c" (N_ "Default background for table cells.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -157,20 +157,20 @@
(list #xff #xff #x00 #xff)
255 #f))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell spacing") "a" (N_ "Space between table cells.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell padding") "b" (N_ "Space between table cell edge and content.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table border width") "c" (N_ "Bevel depth on tables.")
1 0 20 0 1))
@@ -180,47 +180,47 @@
(define (easy-renderer options doc)
(let* ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (color-val
- (lambda (section name)
- (gnc:color-option->html
- (gnc:lookup-option options section name))))
- (preparer (opt-val (N_ "General") (N_ "Preparer")))
- (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
- (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
- (links? (opt-val (N_ "General") (N_ "Enable Links")))
- (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
- (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
- (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
- (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
- (alternate-row-color (color-val (N_ "Colors")
- (N_ "Alternate Table Cell Color")))
- (primary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Subheading/Subtotal Cell Color")))
- (secondary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Sub-subheading/total Cell Color")))
- (grand-total-color (color-val (N_ "Colors")
- (N_ "Grand Total Cell Color")))
- (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
- (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
- (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
+ (opt-val
+ (lambda (section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name))))
+ (color-val
+ (lambda (section name)
+ (gnc:color-option->html
+ (gnc:lookup-option options section name))))
+ (preparer (opt-val (N_ "General") (N_ "Preparer")))
+ (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
+ (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
+ (links? (opt-val (N_ "General") (N_ "Enable Links")))
+ (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
+ (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
+ (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
+ (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
+ (alternate-row-color (color-val (N_ "Colors")
+ (N_ "Alternate Table Cell Color")))
+ (primary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Subheading/Subtotal Cell Color")))
+ (secondary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Sub-subheading/total Cell Color")))
+ (grand-total-color (color-val (N_ "Colors")
+ (N_ "Grand Total Cell Color")))
+ (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
+ (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
+ (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
- (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
- (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
- (border (opt-val (N_ "Tables") (N_ "Table border width")))
+ (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
+ (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
+ (border (opt-val (N_ "Tables") (N_ "Table border width")))
(headcolumn 0))
- ; center the document without elements inheriting anything
+ ; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
- (gnc:make-html-text "<center>"))
+ (gnc:make-html-text "<center>"))
- (gnc:html-document-set-style!
- ssdoc "body"
+ (gnc:html-document-set-style!
+ ssdoc "body"
'attribute (list "bgcolor" bgcolor)
'attribute (list "text" textcolor)
'attribute (list "link" linkcolor))
@@ -293,13 +293,13 @@
'attribute (list "class" "centered-label-cell"))
(if (and bgpixmap
- (not (string=? bgpixmap "")))
- (gnc:html-document-set-style!
- ssdoc "body"
- 'attribute (list "background" (make-file-url bgpixmap))))
-
+ (not (string=? bgpixmap "")))
+ (gnc:html-document-set-style!
+ ssdoc "body"
+ 'attribute (list "background" (make-file-url bgpixmap))))
+
(gnc:html-document-set-style!
- ssdoc "table"
+ ssdoc "table"
'attribute (list "border" border)
'attribute (list "cellspacing" spacing)
'attribute (list "cellpadding" padding))
@@ -311,38 +311,38 @@
(gnc:html-document-set-style!
ssdoc "alternate-row"
'attribute (list "bgcolor" alternate-row-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "primary-subheading"
'attribute (list "bgcolor" primary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "secondary-subheading"
'attribute (list "bgcolor" secondary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "grand-total"
'attribute (list "bgcolor" grand-total-color)
- 'tag "tr")
+ 'tag "tr")
;; don't surround marked-up links with <a> </a>
(if (not links?)
- (gnc:html-document-set-style!
- ssdoc "a" 'tag ""))
-
+ (gnc:html-document-set-style!
+ ssdoc "a" 'tag ""))
+
(let ((t (gnc:make-html-table)))
- ;; we don't want a bevel for this table, but we don't want
- ;; that to propagate
+ ;; we don't want a bevel for this table, but we don't want
+ ;; that to propagate
(gnc:html-table-set-style!
- t "table"
+ t "table"
'attribute (list "border" 0)
'inheritable? #f)
- ; set the header column to be the 2nd when we have a logo
- ; do this so that when logo is not present, the document
- ; is perfectly centered
+ ; set the header column to be the 2nd when we have a logo
+ ; do this so that when logo is not present, the document
+ ; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
- (set! headcolumn 1))
+ (set! headcolumn 1))
(add-css-information-to-doc options ssdoc doc)
@@ -350,10 +350,10 @@
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
- (gnc:html-table-set-cell!
+ (gnc:html-table-set-cell!
t 1 headcolumn
- (if show-preparer?
- ;; title plus preparer info
+ (if show-preparer?
+ ;; title plus preparer info
(gnc:make-html-text
(gnc:html-markup-h3 headline)
(gnc:html-markup-br)
@@ -367,42 +367,42 @@
(qof-print-date
(current-time)))
- ;; title only
+ ;; title only
(gnc:make-html-text
(gnc:html-markup-h3 headline))))
)
-
- ; only setup an image if we specified one
+
+ ; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
- (begin
- (gnc:html-table-set-cell!
- t 0 0
- (gnc:make-html-text
- (gnc:html-markup-img (make-file-url logopixmap))))))
-
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 0
+ (gnc:make-html-text
+ (gnc:html-markup-img (make-file-url logopixmap))))))
+
(if (and headpixmap (> (string-length headpixmap) 0))
- (begin
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 headcolumn
+ (gnc:make-html-text
+ (string-append
+ "<div align=\"" align "\">"
+ "<img src=\"" (make-file-url headpixmap) "\">"
+ "</div>")))
+ )
(gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text
- (string-append
- "<div align=\"" align "\">"
- "<img src=\"" (make-file-url headpixmap) "\">"
- "</div>")))
- )
- (gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text " ")))
-
- (apply
- gnc:html-table-set-cell!
+ t 0 headcolumn
+ (gnc:make-html-text " ")))
+
+ (apply
+ gnc:html-table-set-cell!
t 2 headcolumn
(gnc:html-document-objects doc))
(gnc:html-document-add-object! ssdoc t))
(gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
-(gnc:define-html-style-sheet
+(gnc:define-html-style-sheet
'version 1
'name (N_ "Easy")
'renderer easy-renderer
diff --git a/gnucash/report/stylesheets/stylesheet-fancy.scm b/gnucash/report/stylesheets/stylesheet-fancy.scm
index 46f2bc124..26dae6e55 100644
--- a/gnucash/report/stylesheets/stylesheet-fancy.scm
+++ b/gnucash/report/stylesheets/stylesheet-fancy.scm
@@ -1,17 +1,17 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; stylesheet-header.scm : stylesheet with nicer layout
;; Copyright 2000 Bill Gribble <grib at gnumatic.com>
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2 of
-;; the License, or (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
@@ -23,7 +23,7 @@
(define-module (gnucash report stylesheet-fancy))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
@@ -32,34 +32,34 @@
(define (fancy-options)
(let* ((options (gnc:new-options))
- (opt-register
- (lambda (opt)
- (gnc:register-option options opt))))
- (opt-register
+ (opt-register
+ (lambda (opt)
+ (gnc:register-option options opt))))
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Preparer") "a"
- (N_ "Name of person preparing the report.")
+ (N_ "Name of person preparing the report.")
""))
- (opt-register
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Prepared for") "b"
- (N_ "Name of organization or company prepared for.")
+ (N_ "Name of organization or company prepared for.")
""))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Show preparer info") "c"
- (N_ "Name of organization or company.")
+ (N_ "Name of organization or company.")
#f))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Enable Links") "d"
- (N_ "Enable hyperlinks in reports.")
+ (N_ "Enable hyperlinks in reports.")
#t))
-
+
(opt-register
(gnc:make-pixmap-option
(N_ "Images")
@@ -76,14 +76,14 @@
(N_ "Heading Alignment") "c" (N_ "Banner for top of report.")
'left
(list (vector 'left
- (N_ "Left")
- (N_ "Align the banner to the left."))
+ (N_ "Left")
+ (N_ "Align the banner to the left."))
(vector 'center
- (N_ "Center")
- (N_ "Align the banner in the center."))
+ (N_ "Center")
+ (N_ "Align the banner in the center."))
(vector 'right
- (N_ "Right")
- (N_ "Align the banner to the right."))
+ (N_ "Right")
+ (N_ "Align the banner to the right."))
)))
(opt-register
(gnc:make-pixmap-option
@@ -96,14 +96,14 @@
(N_ "Colors")
(N_ "Background Color") "a" (N_ "General background color for report.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
(N_ "Colors")
(N_ "Text Color") "b" (N_ "Normal body text color.")
(list #x00 #x00 #x00 #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -117,7 +117,7 @@
(N_ "Colors")
(N_ "Table Cell Color") "c" (N_ "Default background for table cells.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -151,20 +151,20 @@
(list #xff #xff #x00 #xff)
255 #f))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell spacing") "a" (N_ "Space between table cells.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell padding") "b" (N_ "Space between table cell edge and content.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table border width") "c" (N_ "Bevel depth on tables.")
1 0 20 0 1))
@@ -174,47 +174,47 @@
(define (fancy-renderer options doc)
(let* ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (color-val
- (lambda (section name)
- (gnc:color-option->html
- (gnc:lookup-option options section name))))
- (preparer (opt-val (N_ "General") (N_ "Preparer")))
- (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
- (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
- (links? (opt-val (N_ "General") (N_ "Enable Links")))
- (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
- (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
- (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
- (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
- (alternate-row-color (color-val (N_ "Colors")
- (N_ "Alternate Table Cell Color")))
- (primary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Subheading/Subtotal Cell Color")))
- (secondary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Sub-subheading/total Cell Color")))
- (grand-total-color (color-val (N_ "Colors")
- (N_ "Grand Total Cell Color")))
- (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
- (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
- (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
+ (opt-val
+ (lambda (section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name))))
+ (color-val
+ (lambda (section name)
+ (gnc:color-option->html
+ (gnc:lookup-option options section name))))
+ (preparer (opt-val (N_ "General") (N_ "Preparer")))
+ (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
+ (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
+ (links? (opt-val (N_ "General") (N_ "Enable Links")))
+ (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
+ (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
+ (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
+ (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
+ (alternate-row-color (color-val (N_ "Colors")
+ (N_ "Alternate Table Cell Color")))
+ (primary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Subheading/Subtotal Cell Color")))
+ (secondary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Sub-subheading/total Cell Color")))
+ (grand-total-color (color-val (N_ "Colors")
+ (N_ "Grand Total Cell Color")))
+ (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
+ (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
+ (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
- (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
- (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
- (border (opt-val (N_ "Tables") (N_ "Table border width")))
+ (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
+ (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
+ (border (opt-val (N_ "Tables") (N_ "Table border width")))
(headcolumn 0))
- ; center the document without elements inheriting anything
+ ; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
- (gnc:make-html-text "<center>"))
+ (gnc:make-html-text "<center>"))
- (gnc:html-document-set-style!
- ssdoc "body"
+ (gnc:html-document-set-style!
+ ssdoc "body"
'attribute (list "bgcolor" bgcolor)
'attribute (list "text" textcolor)
'attribute (list "link" linkcolor))
@@ -288,13 +288,13 @@
'attribute (list "class" "centered-label-cell"))
(if (and bgpixmap
- (not (string=? bgpixmap "")))
- (gnc:html-document-set-style!
- ssdoc "body"
- 'attribute (list "background" (make-file-url bgpixmap))))
-
+ (not (string=? bgpixmap "")))
+ (gnc:html-document-set-style!
+ ssdoc "body"
+ 'attribute (list "background" (make-file-url bgpixmap))))
+
(gnc:html-document-set-style!
- ssdoc "table"
+ ssdoc "table"
'attribute (list "border" border)
'attribute (list "cellspacing" spacing)
'attribute (list "cellpadding" padding))
@@ -306,32 +306,32 @@
(gnc:html-document-set-style!
ssdoc "alternate-row"
'attribute (list "bgcolor" alternate-row-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "primary-subheading"
'attribute (list "bgcolor" primary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "secondary-subheading"
'attribute (list "bgcolor" secondary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "grand-total"
'attribute (list "bgcolor" grand-total-color)
- 'tag "tr")
+ 'tag "tr")
;; don't surround marked-up links with <a> </a>
(if (not links?)
- (gnc:html-document-set-style!
- ssdoc "a" 'tag ""))
-
+ (gnc:html-document-set-style!
+ ssdoc "a" 'tag ""))
+
(add-css-information-to-doc options ssdoc doc)
(let ((t (gnc:make-html-table)))
- ;; we don't want a bevel for this table, but we don't want
- ;; that to propagate
+ ;; we don't want a bevel for this table, but we don't want
+ ;; that to propagate
(gnc:html-table-set-style!
- t "table"
+ t "table"
'attribute (list "border" 0)
'inheritable? #f)
@@ -339,18 +339,18 @@
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
- ; set the header column to be the 2nd when we have a logo
- ; do this so that when logo is not present, the document
- ; is perfectly centered
- (if (and logopixmap (> (string-length logopixmap) 0))
- (set! headcolumn 1))
+ ; set the header column to be the 2nd when we have a logo
+ ; do this so that when logo is not present, the document
+ ; is perfectly centered
+ (if (and logopixmap (> (string-length logopixmap) 0))
+ (set! headcolumn 1))
- (gnc:html-table-set-cell!
+ (gnc:html-table-set-cell!
t 1 headcolumn
- (if show-preparer?
- ;; title plus preparer info
+ (if show-preparer?
+ ;; title plus preparer info
(gnc:make-html-text
- (gnc:html-markup-h3 headline)
+ (gnc:html-markup-h3 headline)
(gnc:html-markup-br)
(_ "Prepared by: ")
(gnc:html-markup-b preparer)
@@ -362,48 +362,48 @@
(qof-print-date
(current-time)))
- ;; title only
+ ;; title only
(gnc:make-html-text
(gnc:html-markup-h3 headline))))
)
-
+
(if (and logopixmap
- (not (string=? logopixmap "")))
- ;; check for logo image file name non blank
- (gnc:html-table-set-cell!
- t 0 0
+ (not (string=? logopixmap "")))
+ ;; check for logo image file name non blank
+ (gnc:html-table-set-cell!
+ t 0 0
(gnc:make-html-text
- (gnc:html-markup-img (make-file-url logopixmap)))) )
+ (gnc:html-markup-img (make-file-url logopixmap)))) )
(if (and headpixmap
- (not (string=? headpixmap "")))
- ;; check for header image file name nonblank
- (begin
- (gnc:html-table-set-cell!
+ (not (string=? headpixmap "")))
+ ;; check for header image file name nonblank
+ (begin
+ (gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text
- ;; XX: isn't there some way to apply the alignment to
- ;; (gnc:html-markup-img headpixmap)?
- (string-append
- "<div align=\"" align "\">"
- "<img src=\"" (make-file-url headpixmap) "\">"
- "</div>")))
- )
- (gnc:html-table-set-cell!
+ ;; XX: isn't there some way to apply the alignment to
+ ;; (gnc:html-markup-img headpixmap)?
+ (string-append
+ "<div align=\"" align "\">"
+ "<img src=\"" (make-file-url headpixmap) "\">"
+ "</div>")))
+ )
+ (gnc:html-table-set-cell!
t 0 headcolumn
(gnc:make-html-text " ")))
- (apply
- gnc:html-table-set-cell!
+ (apply
+ gnc:html-table-set-cell!
t 2 headcolumn
(gnc:html-document-objects doc))
-
+
(gnc:html-document-add-object! ssdoc t))
(gnc:html-document-add-object! ssdoc
- (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
+ (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
-(gnc:define-html-style-sheet
+(gnc:define-html-style-sheet
'version 1.01
'name (N_ "Fancy")
'renderer fancy-renderer
diff --git a/gnucash/report/stylesheets/stylesheet-footer.scm b/gnucash/report/stylesheets/stylesheet-footer.scm
index 3464d582b..5f22cbcc1 100644
--- a/gnucash/report/stylesheets/stylesheet-footer.scm
+++ b/gnucash/report/stylesheets/stylesheet-footer.scm
@@ -4,23 +4,23 @@
;;
;; Copyright 2004 James Strandboge <jstrand1 at rochester.rr.com>
;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2 of
-;; the License, or (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu at gnu.org
-;;
+;;
;; Based on work from:
;; stylesheet-header.scm
;; Copyright 2000 Bill Gribble <grib at gnumatic.com>
@@ -34,7 +34,7 @@
(define-module (gnucash report stylesheet-footer))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash gettext))
@@ -43,34 +43,34 @@
(define (footer-options)
(let* ((options (gnc:new-options))
- (opt-register
- (lambda (opt)
- (gnc:register-option options opt))))
- (opt-register
+ (opt-register
+ (lambda (opt)
+ (gnc:register-option options opt))))
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Preparer") "a"
- (N_ "Name of person preparing the report.")
+ (N_ "Name of person preparing the report.")
""))
- (opt-register
+ (opt-register
(gnc:make-string-option
(N_ "General")
(N_ "Prepared for") "b"
- (N_ "Name of organization or company prepared for.")
+ (N_ "Name of organization or company prepared for.")
""))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Show preparer info") "c"
- (N_ "Name of organization or company.")
+ (N_ "Name of organization or company.")
#f))
- (opt-register
+ (opt-register
(gnc:make-simple-boolean-option
(N_ "General")
(N_ "Enable Links") "d"
- (N_ "Enable hyperlinks in reports.")
+ (N_ "Enable hyperlinks in reports.")
#t))
- ; FIXME: put this in a more sensible tab like Text or Header/Footer
+ ;; FIXME: put this in a more sensible tab like Text or Header/Footer
(opt-register
(gnc:make-text-option
(N_ "General")
@@ -95,14 +95,14 @@
(N_ "Heading Alignment") "c" (N_ "Banner for top of report.")
'left
(list (vector 'left
- (N_ "Left")
- (N_ "Align the banner to the left."))
+ (N_ "Left")
+ (N_ "Align the banner to the left."))
(vector 'center
- (N_ "Center")
- (N_ "Align the banner in the center."))
+ (N_ "Center")
+ (N_ "Align the banner in the center."))
(vector 'right
- (N_ "Right")
- (N_ "Align the banner to the right."))
+ (N_ "Right")
+ (N_ "Align the banner to the right."))
)))
(opt-register
(gnc:make-pixmap-option
@@ -115,14 +115,14 @@
(N_ "Colors")
(N_ "Background Color") "a" (N_ "General background color for report.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
(N_ "Colors")
(N_ "Text Color") "b" (N_ "Normal body text color.")
(list #x00 #x00 #x00 #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -136,7 +136,7 @@
(N_ "Colors")
(N_ "Table Cell Color") "c" (N_ "Default background for table cells.")
(list #xff #xff #xff #xff)
- 255 #f))
+ 255 #f))
(opt-register
(gnc:make-color-option
@@ -170,20 +170,20 @@
(list #xff #xff #x00 #xff)
255 #f))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell spacing") "a" (N_ "Space between table cells.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table cell padding") "b" (N_ "Space between table cell edge and content.")
1 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
+ (opt-register
+ (gnc:make-number-range-option
(N_ "Tables")
(N_ "Table border width") "c" (N_ "Bevel depth on tables.")
1 0 20 0 1))
@@ -193,48 +193,48 @@
(define (footer-renderer options doc)
(let* ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (color-val
- (lambda (section name)
- (gnc:color-option->html
- (gnc:lookup-option options section name))))
- (preparer (opt-val (N_ "General") (N_ "Preparer")))
- (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
- (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
- (links? (opt-val (N_ "General") (N_ "Enable Links")))
- (footer-text (opt-val (N_ "General") (N_ "Footer")))
- (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
- (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
- (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
- (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
- (alternate-row-color (color-val (N_ "Colors")
- (N_ "Alternate Table Cell Color")))
- (primary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Subheading/Subtotal Cell Color")))
- (secondary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Sub-subheading/total Cell Color")))
- (grand-total-color (color-val (N_ "Colors")
- (N_ "Grand Total Cell Color")))
- (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
- (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
- (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
+ (opt-val
+ (lambda (section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name))))
+ (color-val
+ (lambda (section name)
+ (gnc:color-option->html
+ (gnc:lookup-option options section name))))
+ (preparer (opt-val (N_ "General") (N_ "Preparer")))
+ (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
+ (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
+ (links? (opt-val (N_ "General") (N_ "Enable Links")))
+ (footer-text (opt-val (N_ "General") (N_ "Footer")))
+ (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
+ (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
+ (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
+ (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
+ (alternate-row-color (color-val (N_ "Colors")
+ (N_ "Alternate Table Cell Color")))
+ (primary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Subheading/Subtotal Cell Color")))
+ (secondary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Sub-subheading/total Cell Color")))
+ (grand-total-color (color-val (N_ "Colors")
+ (N_ "Grand Total Cell Color")))
+ (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
+ (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
+ (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
- (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
- (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
- (border (opt-val (N_ "Tables") (N_ "Table border width")))
+ (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
+ (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
+ (border (opt-val (N_ "Tables") (N_ "Table border width")))
(headcolumn 0))
- ; center the document without elements inheriting anything
+ ;; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
- (gnc:make-html-text "<center>"))
+ (gnc:make-html-text "<center>"))
- (gnc:html-document-set-style!
- ssdoc "body"
+ (gnc:html-document-set-style!
+ ssdoc "body"
'attribute (list "bgcolor" bgcolor)
'attribute (list "text" textcolor)
'attribute (list "link" linkcolor))
@@ -307,13 +307,13 @@
'attribute (list "class" "centered-label-cell"))
(if (and bgpixmap
- (not (string=? bgpixmap "")))
- (gnc:html-document-set-style!
- ssdoc "body"
- 'attribute (list "background" (make-file-url bgpixmap))))
-
+ (not (string=? bgpixmap "")))
+ (gnc:html-document-set-style!
+ ssdoc "body"
+ 'attribute (list "background" (make-file-url bgpixmap))))
+
(gnc:html-document-set-style!
- ssdoc "table"
+ ssdoc "table"
'attribute (list "border" border)
'attribute (list "cellspacing" spacing)
'attribute (list "cellpadding" padding))
@@ -325,48 +325,48 @@
(gnc:html-document-set-style!
ssdoc "alternate-row"
'attribute (list "bgcolor" alternate-row-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "primary-subheading"
'attribute (list "bgcolor" primary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "secondary-subheading"
'attribute (list "bgcolor" secondary-subheading-color)
- 'tag "tr")
+ 'tag "tr")
(gnc:html-document-set-style!
ssdoc "grand-total"
'attribute (list "bgcolor" grand-total-color)
- 'tag "tr")
+ 'tag "tr")
;; don't surround marked-up links with <a> </a>
(if (not links?)
- (gnc:html-document-set-style! ssdoc "a" 'tag ""))
-
+ (gnc:html-document-set-style! ssdoc "a" 'tag ""))
+
(add-css-information-to-doc options ssdoc doc)
(let ((t (gnc:make-html-table)))
- ;; we don't want a bevel for this table, but we don't want
- ;; that to propagate
+ ;; we don't want a bevel for this table, but we don't want
+ ;; that to propagate
(gnc:html-table-set-style!
- t "table"
+ t "table"
'attribute (list "border" 0)
'inheritable? #f)
- ; set the header column to be the 2nd when we have a logo
- ; do this so that when logo is not present, the document
- ; is perfectly centered
+ ;; set the header column to be the 2nd when we have a logo
+ ;; do this so that when logo is not present, the document
+ ;; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
- (set! headcolumn 1))
+ (set! headcolumn 1))
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
- (gnc:html-table-set-cell!
+ (gnc:html-table-set-cell!
t 1 headcolumn
- (if show-preparer?
- ;; title plus preparer info
+ (if show-preparer?
+ ;; title plus preparer info
(gnc:make-html-text
(gnc:html-markup-h3 headline)
(gnc:html-markup-br)
@@ -380,47 +380,48 @@
(qof-print-date
(current-time)))
- ;; title only
+ ;; title only
(gnc:make-html-text
(gnc:html-markup-h3 headline))))
)
-
- ; only setup an image if we specified one
+
+ ;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
- (begin
- (gnc:html-table-set-cell!
- t 0 0
- (gnc:make-html-text
- (gnc:html-markup-img (make-file-url logopixmap))))))
-
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 0
+ (gnc:make-html-text
+ (gnc:html-markup-img (make-file-url logopixmap))))))
+
(if (and headpixmap (> (string-length headpixmap) 0))
- (begin
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 headcolumn
+ (gnc:make-html-text
+ (string-append
+ "<div align=\"" align "\">"
+ "<img src=\"" (make-file-url headpixmap) "\">"
+ "</div>")))
+ )
(gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text
- (string-append
- "<div align=\"" align "\">"
- "<img src=\"" (make-file-url headpixmap) "\">"
- "</div>")))
- )
- (gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text " ")))
-
- (apply
- gnc:html-table-set-cell!
+ t 0 headcolumn
+ (gnc:make-html-text " ")))
+
+ (apply
+ gnc:html-table-set-cell!
t 2 headcolumn
(gnc:html-document-objects doc))
(gnc:html-document-add-object! ssdoc t)
- ; I think this is the correct place to put the footer
- (gnc:html-table-set-cell!
+ ;; I think this is the correct place to put the footer
+ (gnc:html-table-set-cell!
t 3 headcolumn
(gnc:make-html-text footer-text)))
- (gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
+ (gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>"))
+ ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
-(gnc:define-html-style-sheet
+(gnc:define-html-style-sheet
'version 1
'name (N_ "Footer")
'renderer footer-renderer
diff --git a/gnucash/report/stylesheets/stylesheet-head-or-tail.scm b/gnucash/report/stylesheets/stylesheet-head-or-tail.scm
index c2cbfd4cc..ad755094c 100644
--- a/gnucash/report/stylesheets/stylesheet-head-or-tail.scm
+++ b/gnucash/report/stylesheets/stylesheet-head-or-tail.scm
@@ -35,7 +35,7 @@
(define-module (gnucash report stylesheet-head-or-tail))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash core-utils)) ; for gnc:version
(use-modules (gnucash gettext))
@@ -45,9 +45,9 @@
(define (head-or-tail-options)
(let* ((options (gnc:new-options))
- (opt-register
- (lambda (opt)
- (gnc:register-option options opt))))
+ (opt-register
+ (lambda (opt)
+ (gnc:register-option options opt))))
(opt-register
(gnc:make-string-option
(N_ "General")
@@ -96,7 +96,7 @@
(N_ "Enable Links") "h"
(N_ "Enable hyperlinks in reports.")
#t))
- ; FIXME: put this in a more sensible tab like Text or Header/Footer
+ ;; FIXME: put this in a more sensible tab like Text or Header/Footer
(opt-register
(gnc:make-text-option
(N_ "General")
@@ -151,14 +151,14 @@
(N_ "Heading Alignment") "c" (N_ "Banner for top of report.")
'left
(list (vector 'left
- (N_ "Left")
- (N_ "Align the banner to the left."))
+ (N_ "Left")
+ (N_ "Align the banner to the left."))
(vector 'center
- (N_ "Center")
- (N_ "Align the banner in the center."))
+ (N_ "Center")
+ (N_ "Align the banner in the center."))
(vector 'right
- (N_ "Right")
- (N_ "Align the banner to the right."))
+ (N_ "Right")
+ (N_ "Align the banner to the right."))
)))
(opt-register
(gnc:make-pixmap-option
@@ -249,54 +249,54 @@
(define (head-or-tail-renderer options doc)
(let* ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (color-val
- (lambda (section name)
- (gnc:color-option->html
- (gnc:lookup-option options section name))))
- (preparer (opt-val (N_ "General") (N_ "Preparer")))
- (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
- (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
- (show-receiver? (opt-val (N_ "General") (N_ "Show receiver info")))
- (show-date? (opt-val (N_ "General") (N_ "Show date")))
- (show-time? (opt-val (N_ "General") (N_ "Show time in addition to date")))
- (show-gnucash-version? (opt-val (N_ "General") (N_ "Show GnuCash Version")))
+ (opt-val
+ (lambda (section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name))))
+ (color-val
+ (lambda (section name)
+ (gnc:color-option->html
+ (gnc:lookup-option options section name))))
+ (preparer (opt-val (N_ "General") (N_ "Preparer")))
+ (prepared-for (opt-val (N_ "General") (N_ "Prepared for")))
+ (show-preparer? (opt-val (N_ "General") (N_ "Show preparer info")))
+ (show-receiver? (opt-val (N_ "General") (N_ "Show receiver info")))
+ (show-date? (opt-val (N_ "General") (N_ "Show date")))
+ (show-time? (opt-val (N_ "General") (N_ "Show time in addition to date")))
+ (show-gnucash-version? (opt-val (N_ "General") (N_ "Show GnuCash Version")))
(show-preparer-at-bottom? (opt-val (N_ "General") (N_ "Show preparer info at bottom")))
(show-receiver-at-bottom? (opt-val (N_ "General") (N_ "Show receiver info at bottom")))
(show-date-time-at-bottom? (opt-val (N_ "General") (N_ "Show date/time at bottom")))
(show-comments-at-bottom? (opt-val (N_ "General") (N_ "Show comments at bottom")))
(show-gnucash-version-at-bottom? (opt-val (N_ "General") (N_ "Show GnuCash version at bottom")))
- (links? (opt-val (N_ "General") (N_ "Enable Links")))
- (additional-comments (opt-val (N_ "General") (N_ "Additional Comments")))
- (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
- (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
- (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
- (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
- (alternate-row-color (color-val (N_ "Colors")
- (N_ "Alternate Table Cell Color")))
- (primary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Subheading/Subtotal Cell Color")))
- (secondary-subheading-color
- (color-val (N_ "Colors")
- (N_ "Sub-subheading/total Cell Color")))
- (grand-total-color (color-val (N_ "Colors")
- (N_ "Grand Total Cell Color")))
- (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
- (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
- (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
+ (links? (opt-val (N_ "General") (N_ "Enable Links")))
+ (additional-comments (opt-val (N_ "General") (N_ "Additional Comments")))
+ (bgcolor (color-val (N_ "Colors") (N_ "Background Color")))
+ (textcolor (color-val (N_ "Colors") (N_ "Text Color")))
+ (linkcolor (color-val (N_ "Colors") (N_ "Link Color")))
+ (normal-row-color (color-val (N_ "Colors") (N_ "Table Cell Color")))
+ (alternate-row-color (color-val (N_ "Colors")
+ (N_ "Alternate Table Cell Color")))
+ (primary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Subheading/Subtotal Cell Color")))
+ (secondary-subheading-color
+ (color-val (N_ "Colors")
+ (N_ "Sub-subheading/total Cell Color")))
+ (grand-total-color (color-val (N_ "Colors")
+ (N_ "Grand Total Cell Color")))
+ (bgpixmap (opt-val (N_ "Images") (N_ "Background Tile")))
+ (headpixmap (opt-val (N_ "Images") (N_ "Heading Banner")))
+ (logopixmap (opt-val (N_ "Images") (N_ "Logo")))
(align (gnc:value->string(opt-val (N_ "Images") (N_ "Heading Alignment"))))
- (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
- (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
- (border (opt-val (N_ "Tables") (N_ "Table border width")))
+ (spacing (opt-val (N_ "Tables") (N_ "Table cell spacing")))
+ (padding (opt-val (N_ "Tables") (N_ "Table cell padding")))
+ (border (opt-val (N_ "Tables") (N_ "Table border width")))
(headcolumn 0))
- ; center the document without elements inheriting anything
+ ;; center the document without elements inheriting anything
(gnc:html-document-add-object! ssdoc
- (gnc:make-html-text "<center>"))
+ (gnc:make-html-text "<center>"))
(gnc:html-document-set-style!
ssdoc "body"
@@ -372,10 +372,10 @@
'attribute (list "class" "centered-label-cell"))
(if (and bgpixmap
- (not (string=? bgpixmap "")))
- (gnc:html-document-set-style!
- ssdoc "body"
- 'attribute (list "background" (make-file-url bgpixmap))))
+ (not (string=? bgpixmap "")))
+ (gnc:html-document-set-style!
+ ssdoc "body"
+ 'attribute (list "background" (make-file-url bgpixmap))))
(gnc:html-document-set-style!
ssdoc "table"
@@ -406,7 +406,7 @@
;; don't surround marked-up links with <a> </a>
(if (not links?)
- (gnc:html-document-set-style! ssdoc "a" 'tag ""))
+ (gnc:html-document-set-style! ssdoc "a" 'tag ""))
(add-css-information-to-doc options ssdoc doc)
@@ -418,122 +418,122 @@
'attribute (list "border" 0)
'inheritable? #f)
- ; set the header column to be the 2nd when we have a logo
- ; do this so that when logo is not present, the document
- ; is perfectly centered
+ ;; set the header column to be the 2nd when we have a logo
+ ;; do this so that when logo is not present, the document
+ ;; is perfectly centered
(if (and logopixmap (> (string-length logopixmap) 0))
- (set! headcolumn 1))
+ (set! headcolumn 1))
(let* ((title (gnc:html-document-title doc))
(doc-headline (gnc:html-document-headline doc))
(headline (if (eq? doc-headline #f) title doc-headline)))
(gnc:html-table-set-cell!
- t 1 headcolumn
- ;; print title
- (gnc:make-html-text
- (gnc:html-markup-h3 headline))
- (if (and show-preparer? (not show-preparer-at-bottom?))
- ;; print preparer info as additional header info
- (gnc:make-html-text
+ t 1 headcolumn
+ ;; print title
+ (gnc:make-html-text
+ (gnc:html-markup-h3 headline))
+ (if (and show-preparer? (not show-preparer-at-bottom?))
+ ;; print preparer info as additional header info
+ (gnc:make-html-text
(gnc:html-markup-i
- (_ "Prepared by: ")
- (gnc:html-markup-b preparer)
- )
+ (_ "Prepared by: ")
+ (gnc:html-markup-b preparer)
+ )
(gnc:html-markup-br)
- )
- " "
- )
- (if (and show-receiver? (not show-receiver-at-bottom?))
- ;; print receiver info as additional header info
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Prepared for: ")
- (gnc:html-markup-b prepared-for)
- (gnc:html-markup-br)
- )
- )
- " "
- )
- (if (and show-date? (not show-date-time-at-bottom?))
- ;; print date/time info as additional header info
- (if show-time?
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Report Creation Date: ")
- (qof-print-date (gnc:get-today))
- " "
- (strftime "%X %Z" (localtime (current-time)))
- )
- (gnc:html-markup-br)
- )
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Report Creation Date: ")
- (qof-print-date (gnc:get-today))
- )
- (gnc:html-markup-br)
)
- )
- " "
- )
- (if (and show-gnucash-version? (not show-gnucash-version-at-bottom?))
- ;; print the GnuCash version string as additional header info
- (gnc:make-html-text
+ " "
+ )
+ (if (and show-receiver? (not show-receiver-at-bottom?))
+ ;; print receiver info as additional header info
+ (gnc:make-html-text
(gnc:html-markup-i
- "GnuCash "
- gnc:version
+ (_ "Prepared for: ")
+ (gnc:html-markup-b prepared-for)
+ (gnc:html-markup-br)
+ )
)
+ " "
+ )
+ (if (and show-date? (not show-date-time-at-bottom?))
+ ;; print date/time info as additional header info
+ (if show-time?
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ (_ "Report Creation Date: ")
+ (qof-print-date (gnc:get-today))
+ " "
+ (strftime "%X %Z" (localtime (current-time)))
+ )
+ (gnc:html-markup-br)
+ )
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ (_ "Report Creation Date: ")
+ (qof-print-date (gnc:get-today))
+ )
+ (gnc:html-markup-br)
+ )
+ )
+ " "
+ )
+ (if (and show-gnucash-version? (not show-gnucash-version-at-bottom?))
+ ;; print the GnuCash version string as additional header info
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ "GnuCash "
+ gnc:version
+ )
(gnc:html-markup-br)
- )
- " "
- )
- (if (not show-comments-at-bottom?)
- ;; print additional comments as additional header info
- (gnc:make-html-text
+ )
+ " "
+ )
+ (if (not show-comments-at-bottom?)
+ ;; print additional comments as additional header info
+ (gnc:make-html-text
(gnc:html-markup-br)
(gnc:html-markup-i additional-comments)
(gnc:html-markup-br)
- )
- " "
- )
- ;; add separator line if any additional header info is printed
- (if (or
- (and show-preparer? (not show-preparer-at-bottom?))
- (and show-receiver? (not show-receiver-at-bottom?))
- (and show-date? (not show-date-time-at-bottom?))
- (and show-gnucash-version? (not show-gnucash-version-at-bottom?))
- (not show-comments-at-bottom?)
)
- (gnc:make-html-text
+ " "
+ )
+ ;; add separator line if any additional header info is printed
+ (if (or
+ (and show-preparer? (not show-preparer-at-bottom?))
+ (and show-receiver? (not show-receiver-at-bottom?))
+ (and show-date? (not show-date-time-at-bottom?))
+ (and show-gnucash-version? (not show-gnucash-version-at-bottom?))
+ (not show-comments-at-bottom?)
+ )
+ (gnc:make-html-text
(gnc:html-markup-br)
- )
- " "
- )
+ )
+ " "
+ )
+ )
)
- )
- ; only setup an image if we specified one
+ ;; only setup an image if we specified one
(if (and logopixmap (> (string-length logopixmap) 0))
- (begin
- (gnc:html-table-set-cell!
- t 0 0
- (gnc:make-html-text
- (gnc:html-markup-img (make-file-url logopixmap))))))
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 0
+ (gnc:make-html-text
+ (gnc:html-markup-img (make-file-url logopixmap))))))
(if (and headpixmap (> (string-length headpixmap) 0))
- (begin
+ (begin
+ (gnc:html-table-set-cell!
+ t 0 headcolumn
+ (gnc:make-html-text
+ (string-append
+ "<div align=\"" align "\">"
+ "<img src=\"" (make-file-url headpixmap) "\">"
+ "</div>")))
+ )
(gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text
- (string-append
- "<div align=\"" align "\">"
- "<img src=\"" (make-file-url headpixmap) "\">"
- "</div>")))
- )
- (gnc:html-table-set-cell!
- t 0 headcolumn
- (gnc:make-html-text " ")))
+ t 0 headcolumn
+ (gnc:make-html-text " ")))
(apply
gnc:html-table-set-cell!
@@ -541,88 +541,88 @@
(gnc:html-document-objects doc))
(gnc:html-document-add-object! ssdoc t)
- ; I think this is the correct place to put the footer
- (gnc:html-table-set-cell!
+ ;; I think this is the correct place to put the footer
+ (gnc:html-table-set-cell!
t 3 headcolumn
;;(gnc:make-html-text additional-comments)
- ;; add separator line if any additional header info is printed
- (if (or
- (and show-preparer? show-preparer-at-bottom?)
- (and show-receiver? show-receiver-at-bottom?)
- (and show-date? show-date-time-at-bottom?)
- (and show-gnucash-version? show-gnucash-version-at-bottom?)
- show-comments-at-bottom?
+ ;; add separator line if any additional header info is printed
+ (if (or
+ (and show-preparer? show-preparer-at-bottom?)
+ (and show-receiver? show-receiver-at-bottom?)
+ (and show-date? show-date-time-at-bottom?)
+ (and show-gnucash-version? show-gnucash-version-at-bottom?)
+ show-comments-at-bottom?
)
- (gnc:make-html-text
+ (gnc:make-html-text
(gnc:html-markup-br)
- )
- " "
- )
- (if (and show-preparer? show-preparer-at-bottom?)
- ;; print preparer info as additional header info
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Prepared by: ")
- (gnc:html-markup-b preparer)
)
- (gnc:html-markup-br)
- )
- " "
- )
- (if (and show-receiver? show-receiver-at-bottom?)
- ;; print receiver info as additional header info
- (gnc:make-html-text
+ " "
+ )
+ (if (and show-preparer? show-preparer-at-bottom?)
+ ;; print preparer info as additional header info
+ (gnc:make-html-text
(gnc:html-markup-i
- (_ "Prepared for: ")
- (gnc:html-markup-b prepared-for)
+ (_ "Prepared by: ")
+ (gnc:html-markup-b preparer)
+ )
+ (gnc:html-markup-br)
)
+ " "
+ )
+ (if (and show-receiver? show-receiver-at-bottom?)
+ ;; print receiver info as additional header info
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ (_ "Prepared for: ")
+ (gnc:html-markup-b prepared-for)
+ )
(gnc:html-markup-br)
- )
- " "
- )
- (if (and show-date? show-date-time-at-bottom?)
- ;; print date/time info as additional header info
- (if show-time?
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Report Creation Date: ")
- (qof-print-date (gnc:get-today))
- " "
- (strftime "%X %Z" (localtime (current-time)))
- )
- (gnc:html-markup-br)
)
- (gnc:make-html-text
- (gnc:html-markup-i
- (_ "Report Creation Date: ")
- (qof-print-date (gnc:get-today))
+ " "
+ )
+ (if (and show-date? show-date-time-at-bottom?)
+ ;; print date/time info as additional header info
+ (if show-time?
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ (_ "Report Creation Date: ")
+ (qof-print-date (gnc:get-today))
+ " "
+ (strftime "%X %Z" (localtime (current-time)))
+ )
(gnc:html-markup-br)
- )
- )
- )
- " "
- )
- (if (and show-gnucash-version? show-gnucash-version-at-bottom?)
- ;; print the GnuCash version string as additional header info
- (gnc:make-html-text
+ )
+ (gnc:make-html-text
+ (gnc:html-markup-i
+ (_ "Report Creation Date: ")
+ (qof-print-date (gnc:get-today))
+ (gnc:html-markup-br)
+ )
+ )
+ )
+ " "
+ )
+ (if (and show-gnucash-version? show-gnucash-version-at-bottom?)
+ ;; print the GnuCash version string as additional header info
+ (gnc:make-html-text
(gnc:html-markup-i
- (_ "GnuCash ")
- gnc:version
- )
+ (_ "GnuCash ")
+ gnc:version
+ )
(gnc:html-markup-br)
- )
- " "
- )
- (if show-comments-at-bottom?
- ;; print additional comments as additional header info
- (gnc:make-html-text
+ )
+ " "
+ )
+ (if show-comments-at-bottom?
+ ;; print additional comments as additional header info
+ (gnc:make-html-text
(gnc:html-markup-br)
- (gnc:html-markup-i additional-comments)
+ (gnc:html-markup-i additional-comments)
(gnc:html-markup-br)
- )
- " "
- )
- ))
+ )
+ " "
+ )
+ ))
(gnc:html-document-add-object! ssdoc (gnc:make-html-text "</center>")) ;;TODO: make this a div instead of <center> (deprecated)
ssdoc))
diff --git a/gnucash/report/stylesheets/stylesheet-plain.scm b/gnucash/report/stylesheets/stylesheet-plain.scm
index 2a9d7e334..97983a4b1 100644
--- a/gnucash/report/stylesheets/stylesheet-plain.scm
+++ b/gnucash/report/stylesheets/stylesheet-plain.scm
@@ -24,7 +24,7 @@
(define-module (gnucash report stylesheet-plain))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash gnc-module))
(use-modules (gnucash core-utils))
(use-modules (gnucash gettext))
@@ -39,89 +39,89 @@
;; it's supposed to be lightweight and unobtrusive.
(define (plain-options)
(let* ((options (gnc:new-options))
- (opt-register
- (lambda (opt)
- (gnc:register-option options opt))))
- (opt-register
- (gnc:make-color-option
- (N_ "General")
- (N_ "Background Color") "a" (N_ "Background color for reports.")
- (list #xff #xff #xff #xff)
- 255 #f))
(opt-register
- (gnc:make-pixmap-option
- (N_ "General")
- (N_ "Background Pixmap") "b" (N_ "Background tile for reports.")
- ""))
- (opt-register
- (gnc:make-simple-boolean-option
- (N_ "General")
- (N_ "Enable Links") "c" (N_ "Enable hyperlinks in reports.")
- #t))
- (opt-register
- (gnc:make-color-option
- (N_ "Colors")
- (N_ "Alternate Table Cell Color") "a" (N_ "Background color for alternate lines.")
- (list #xff #xff #xff #xff)
- 255 #f))
- (opt-register
- (gnc:make-number-range-option
- (N_ "Tables")
- (N_ "Table cell spacing") "a" (N_ "Space between table cells.")
- 0 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
- (N_ "Tables")
- (N_ "Table cell padding") "b" (N_ "Space between table cell edge and content.")
- 4 0 20 0 1))
- (opt-register
- (gnc:make-number-range-option
- (N_ "Tables")
- (N_ "Table border width") "c" (N_ "Bevel depth on tables.")
- 0 0 20 0 1))
- (register-font-options options)
-
- options))
+ (lambda (opt)
+ (gnc:register-option options opt))))
+ (opt-register
+ (gnc:make-color-option
+ (N_ "General")
+ (N_ "Background Color") "a" (N_ "Background color for reports.")
+ (list #xff #xff #xff #xff)
+ 255 #f))
+ (opt-register
+ (gnc:make-pixmap-option
+ (N_ "General")
+ (N_ "Background Pixmap") "b" (N_ "Background tile for reports.")
+ ""))
+ (opt-register
+ (gnc:make-simple-boolean-option
+ (N_ "General")
+ (N_ "Enable Links") "c" (N_ "Enable hyperlinks in reports.")
+ #t))
+ (opt-register
+ (gnc:make-color-option
+ (N_ "Colors")
+ (N_ "Alternate Table Cell Color") "a" (N_ "Background color for alternate lines.")
+ (list #xff #xff #xff #xff)
+ 255 #f))
+ (opt-register
+ (gnc:make-number-range-option
+ (N_ "Tables")
+ (N_ "Table cell spacing") "a" (N_ "Space between table cells.")
+ 0 0 20 0 1))
+ (opt-register
+ (gnc:make-number-range-option
+ (N_ "Tables")
+ (N_ "Table cell padding") "b" (N_ "Space between table cell edge and content.")
+ 4 0 20 0 1))
+ (opt-register
+ (gnc:make-number-range-option
+ (N_ "Tables")
+ (N_ "Table border width") "c" (N_ "Bevel depth on tables.")
+ 0 0 20 0 1))
+ (register-font-options options)
+
+ options))
(define (plain-renderer options doc)
(let*
- ((ssdoc (gnc:make-html-document))
- (opt-val
- (lambda (section name)
- (gnc:option-value
- (gnc:lookup-option options section name))))
- (bgcolor
- (gnc:color-option->html
- (gnc:lookup-option options
- "General"
- "Background Color")))
- (bgpixmap (opt-val "General" "Background Pixmap"))
- (links? (opt-val "General" "Enable Links"))
- (alternate-row-color
- (gnc:color-option->html
- (gnc:lookup-option options
- "Colors"
- "Alternate Table Cell Color")))
- (spacing (opt-val "Tables" "Table cell spacing"))
- (padding (opt-val "Tables" "Table cell padding"))
- (border (opt-val "Tables" "Table border width"))
- )
-
- (gnc:html-document-set-style!
- ssdoc "body"
- 'attribute (list "bgcolor" bgcolor))
+ ((ssdoc (gnc:make-html-document))
+ (opt-val
+ (lambda (section name)
+ (gnc:option-value
+ (gnc:lookup-option options section name))))
+ (bgcolor
+ (gnc:color-option->html
+ (gnc:lookup-option options
+ "General"
+ "Background Color")))
+ (bgpixmap (opt-val "General" "Background Pixmap"))
+ (links? (opt-val "General" "Enable Links"))
+ (alternate-row-color
+ (gnc:color-option->html
+ (gnc:lookup-option options
+ "Colors"
+ "Alternate Table Cell Color")))
+ (spacing (opt-val "Tables" "Table cell spacing"))
+ (padding (opt-val "Tables" "Table cell padding"))
+ (border (opt-val "Tables" "Table border width"))
+ )
- (if (and bgpixmap
- (not (string=? bgpixmap "")))
(gnc:html-document-set-style!
ssdoc "body"
- 'attribute (list "background" (make-file-url bgpixmap))))
+ 'attribute (list "bgcolor" bgcolor))
+
+ (if (and bgpixmap
+ (not (string=? bgpixmap "")))
+ (gnc:html-document-set-style!
+ ssdoc "body"
+ 'attribute (list "background" (make-file-url bgpixmap))))
(gnc:html-document-set-style!
- ssdoc "table"
- 'attribute (list "border" border)
- 'attribute (list "cellspacing" spacing)
- 'attribute (list "cellpadding" padding))
+ ssdoc "table"
+ 'attribute (list "border" border)
+ 'attribute (list "cellspacing" spacing)
+ 'attribute (list "cellpadding" padding))
(gnc:html-document-set-style!
ssdoc "column-heading-left"
@@ -189,13 +189,13 @@
'attribute (list "class" "centered-label-cell"))
(gnc:html-document-set-style!
- ssdoc "normal-row"
- 'tag "tr")
+ ssdoc "normal-row"
+ 'tag "tr")
(gnc:html-document-set-style!
- ssdoc "alternate-row"
- 'tag "tr"
- 'attribute (list "bgcolor" alternate-row-color))
+ ssdoc "alternate-row"
+ 'tag "tr"
+ 'attribute (list "bgcolor" alternate-row-color))
(gnc:html-document-set-style!
ssdoc "primary-subheading"
@@ -212,9 +212,9 @@
;; don't surround marked-up links with <a> </a>
(if (not links?)
- (gnc:html-document-set-style!
- ssdoc "a"
- 'tag ""))
+ (gnc:html-document-set-style!
+ ssdoc "a"
+ 'tag ""))
(add-css-information-to-doc options ssdoc doc)
@@ -223,13 +223,13 @@
(headline (if (eq? doc-headline #f)
title doc-headline)))
(if headline
- (gnc:html-document-add-object!
- ssdoc
- (gnc:make-html-text
- (gnc:html-markup-h3 headline)))))
+ (gnc:html-document-add-object!
+ ssdoc
+ (gnc:make-html-text
+ (gnc:html-markup-h3 headline)))))
(gnc:html-document-append-objects! ssdoc
- (gnc:html-document-objects doc))
+ (gnc:html-document-objects doc))
ssdoc))
diff --git a/gnucash/report/stylesheets/stylesheets.scm b/gnucash/report/stylesheets/stylesheets.scm
index abaee4a81..3f810a7eb 100644
--- a/gnucash/report/stylesheets/stylesheets.scm
+++ b/gnucash/report/stylesheets/stylesheets.scm
@@ -2,7 +2,7 @@
;; stylesheets.scm
;; load the standard stylesheet definitions
;;
-;; Copyright (c) 2001 Linux Developers Group, Inc.
+;; Copyright (c) 2001 Linux Developers Group, Inc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or
@@ -26,7 +26,7 @@
(define-module (gnucash report stylesheets))
-(use-modules (gnucash utilities))
+(use-modules (gnucash utilities))
(use-modules (gnucash report stylesheet-plain))
(use-modules (gnucash report stylesheet-fancy))
(use-modules (gnucash report stylesheet-footer))
commit 375013f9ea4857f46effc4d4a8c2a68956cb3184
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Apr 20 14:11:03 2019 +0800
[commodity-utils] simplify gnc:make-exchange-function
Remove assigning exchangelist to exchange-alist.
Removes need to test foreign-amount against 0 - multiplication will
result in 0 anyway. The only functional change is the condition
whereby foreign's commodity is not present in exchangelist; previously
it would return (gnc:make-gnc-monetary domestic 0); now it returns #f.
This function *is* allowed to return #f for invalid or missing prices;
see the (and foreign ...) conditional.
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index b4c73a116..a0877a1c5 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -690,23 +690,18 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; the <gnc:commodity*> domestic-commodity, exchanges the amount into
;; the domestic currency and returns a <gnc-monetary>.
(define (gnc:make-exchange-function exchange-alist)
- (let ((exchangelist exchange-alist))
- (lambda (foreign domestic)
- (gnc:debug "foreign: " (gnc:monetary->string foreign))
- (gnc:debug "domestic: " (gnc-commodity-get-printname domestic))
- (and foreign
- (or (gnc:exchange-by-euro foreign domestic #f)
- (gnc:exchange-if-same foreign domestic)
- (gnc:make-gnc-monetary
- domestic
- (let ((pair (assoc (gnc:gnc-monetary-commodity foreign)
- exchangelist))
- (foreign-amount (gnc:gnc-monetary-amount foreign)))
- (if (or (not pair)
- (zero? foreign-amount))
- 0
- (* foreign-amount
- (cadr pair))))))))))
+ (lambda (foreign domestic)
+ (gnc:debug "foreign: " (gnc:monetary->string foreign))
+ (gnc:debug "domestic: " (gnc-commodity-get-printname domestic))
+ (and foreign
+ (or (gnc:exchange-by-euro foreign domestic #f)
+ (gnc:exchange-if-same foreign domestic)
+ (let* ((foreign-comm (gnc:gnc-monetary-commodity foreign))
+ (pair (assoc foreign-comm exchange-alist)))
+ (and pair
+ (gnc:make-gnc-monetary
+ domestic
+ (* (gnc:gnc-monetary-amount foreign) (cadr pair)))))))))
;; Helper for the gnc:exchange-by-pricalist* below. Exchange the
;; <gnc:monetary> 'foreign' into the <gnc:commodity*> 'domestic' by
commit e111c5bb07cf3bbf85f6d248f825beb6fa7ae66c
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Tue Apr 9 21:31:41 2019 +0800
[commodity-utils] use scheme division instead of gnc-numeric
with small change to test due to increased precision
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index eca006dc5..b4c73a116 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -306,14 +306,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
pricelist))
(earlier (and (not (null? earlierlist))
(last earlierlist))))
- ;; (if earlier
- ;; (warn "earlier"
- ;; (qof-print-date (car earlier))
- ;; (gnc-numeric-to-double (cadr earlier))))
- ;; (if later
- ;; (warn "later"
- ;; (qof-print-date (car later))
- ;; (gnc-numeric-to-double (cadr later))))
(if (and earlier later)
(if (< (abs (- date (car earlier)))
@@ -637,11 +629,8 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(map
(lambda (e)
(list (car e)
- (abs
- (gnc-numeric-div ((cdadr e) 'total #f)
- ((caadr e) 'total #f)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND)))))
+ (abs (/ ((cdadr e) 'total #f)
+ ((caadr e) 'total #f)))))
(gnc:get-exchange-totals report-commodity end-date)))
(define (gnc:make-exchange-cost-alist report-commodity end-date)
@@ -651,12 +640,10 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(map
(lambda (e)
(list (car e)
- (if (zero? ((caadr e) 'total #f)) 0
- (abs
- (gnc-numeric-div ((cdadr e) 'total #f)
- ((caadr e) 'total #f)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))))))
+ (if (zero? ((caadr e) 'total #f))
+ 0
+ (abs (/ ((cdadr e) 'total #f)
+ ((caadr e) 'total #f))))))
(gnc:get-exchange-cost-totals report-commodity end-date)))
@@ -718,10 +705,8 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(if (or (not pair)
(zero? foreign-amount))
0
- (gnc-numeric-mul foreign-amount
- (cadr pair)
- (gnc-commodity-get-fraction domestic)
- GNC-RND-ROUND)))))))))
+ (* foreign-amount
+ (cadr pair))))))))))
;; Helper for the gnc:exchange-by-pricalist* below. Exchange the
;; <gnc:monetary> 'foreign' into the <gnc:commodity*> 'domestic' by
@@ -734,10 +719,8 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(gnc:make-gnc-monetary
domestic
(if price-value
- (gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
- price-value
- (gnc-commodity-get-fraction domestic)
- GNC-RND-ROUND)
+ (* (gnc:gnc-monetary-amount foreign)
+ price-value)
(begin
(warn "gnc:exchange-by-pricevalue-helper: No price found for "
(gnc:monetary->string foreign) " into "
@@ -758,10 +741,8 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
domestic
(if price
(let ((result
- (gnc-numeric-mul (gnc:gnc-monetary-amount foreign)
- (gnc-price-get-value price)
- (gnc-commodity-get-fraction domestic)
- GNC-RND-ROUND)))
+ (* (gnc:gnc-monetary-amount foreign)
+ (gnc-price-get-value price))))
(gnc-price-unref price)
result)
(begin
diff --git a/gnucash/report/report-system/test/test-commodity-utils.scm b/gnucash/report/report-system/test/test-commodity-utils.scm
index 7a1e1cac1..97d104d05 100644
--- a/gnucash/report/report-system/test/test-commodity-utils.scm
+++ b/gnucash/report/report-system/test/test-commodity-utils.scm
@@ -697,7 +697,7 @@
(gnc-dmy2time64-neutral 20 02 2016)
#f #f)))
(test-equal "gnc:case-exchange-time-fn average-cost 20/02/2012"
- 8073/100
+ 14127/175
(gnc:gnc-monetary-amount
(exchange-fn
(gnc:make-gnc-monetary AAPL 1)
commit f2aacf94cc5b30d2de391ae4ac0a81a0d765394d
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Sat Apr 6 11:05:53 2019 +0800
[commodity-utils] remove price-is-not-zero? and work-done
because now we're not adding invalid prices to pricelist, and avoids
set! calls
also fix typo in deprecation message
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index fca7f38a9..eca006dc5 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -90,11 +90,6 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(gnc:make-gnc-monetary foreign-commodity foreign-numeric)
domestic date))
-;; Returns true if the given pricealist element is a non-zero price.
-(define (gnc:price-is-not-zero? elem)
- (and (cadr elem)
- (not (zero? (cadr elem)))))
-
;; Create a list of all prices of 'price-commodity' measured in the currency
;; 'report-currency'. The prices are taken from all splits in
;; 'currency-accounts' up until the date 'end-date'. Returns a list of
@@ -202,14 +197,12 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
(all-splits (get-all-splits currency-accounts end-date))
(interesting-splits (sort (filter interesting-split? all-splits) date<?))
- (work-to-do (length commodity-list))
- (work-done 0))
+ (work-to-do (length commodity-list)))
(map
- (lambda (c)
+ (lambda (c work-done)
(define (split-has-commodity? s)
(or (gnc-commodity-equiv c (xaccTransGetCurrency (xaccSplitGetParent s)))
(gnc-commodity-equiv c (xaccAccountGetCommodity (xaccSplitGetAccount s)))))
- (set! work-done (1+ work-done))
(if start-percent
(gnc:report-percent-done
(+ start-percent (* delta-percent (/ work-done work-to-do)))))
@@ -217,7 +210,8 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(gnc:get-commodity-totalavg-prices-internal
currency-accounts end-date c report-currency
(filter split-has-commodity? interesting-splits))))
- commodity-list)))
+ commodity-list
+ (iota work-to-do))))
;; Get the instantaneous prices for the 'price-commodity', measured in
;; amounts of the 'report-currency'. The prices are taken from all
@@ -284,19 +278,17 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
"gnc:get-commoditylist-inst-prices is deprecated.")
(let ((currency-accounts
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
- (work-to-do (length commodity-list))
- (work-done 0))
+ (work-to-do (length commodity-list)))
(map
- (lambda (c)
- (begin
- (set! work-done (+ 1 work-done))
- (if start-percent
- (gnc:report-percent-done
- (+ start-percent (* delta-percent (/ work-done work-to-do)))))
- (cons c
- (gnc:get-commodity-inst-prices
- currency-accounts end-date c report-currency))))
- commodity-list)))
+ (lambda (c work-done)
+ (if start-percent
+ (gnc:report-percent-done
+ (+ start-percent (* delta-percent (/ work-done work-to-do)))))
+ (cons c
+ (gnc:get-commodity-inst-prices
+ currency-accounts end-date c report-currency)))
+ commodity-list
+ (iota work-to-do))))
;; Find the price in 'pricelist' that's nearest to 'date'. The
commit fbcf488237f0f48b3c5e594bce1cb3ddeb514659
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Apr 5 23:41:04 2019 +0800
[commodity-utils] refactor resolve-unknown-comm
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index a0c636df5..fca7f38a9 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -359,117 +359,114 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; report-commodity, and now the transactions with unknown
;; currencies should be added to that list (with an appropriate
;; exchange rate).
- (let ((reportlist (cadr (assoc report-commodity sumlist))))
-
- ;; Helper function to calculate (a*b)/c and create the new pair of
- ;; numeric-collectors, where [abc] are numeric-collectors. See the
- ;; real variable names below.
- (define (make-newrate unknown-coll un->known-coll known-pair)
- (let ((a (gnc:make-value-collector))
- (b (gnc:make-value-collector)))
- (a 'add (unknown-coll 'total #f))
- (b 'add
- ;; round to (at least) 8 significant digits
- (gnc-numeric-div
- (gnc-numeric-mul
- (un->known-coll 'total #f)
- ((cdadr known-pair) 'total #f)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 9) GNC-RND-ROUND))
- ((caadr known-pair) 'total #f)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND)))
- ;; in other words: (/ (* (caadr un->known-coll) (cdadr
- ;; known-pair)) (caadr known-pair) ))
- (cons a b)))
-
- ;; Go through sumlist.
- (for-each
- (lambda (otherlist)
- (if (not (gnc-commodity-equiv (car otherlist) report-commodity))
- (for-each
- (lambda (pair)
- ;; Check whether by any accident the report-commodity
- ;; appears here.
- (if
- (not (gnc-commodity-equiv (car pair) report-commodity))
- ;; pair-{a,b}: Try to find either the currency of
- ;; otherlist or of pair in reportlist.
- (let ((pair-a
- (or
- ;; Find the otherlist's currency in reportlist
- (assoc (car otherlist) reportlist)
- ;; Or try whether that's an Euro currency.
- (let
- ((euro-monetary
- (gnc:exchange-by-euro (gnc:make-gnc-monetary
- (car otherlist)
- ((cdadr pair) 'total #f))
- report-commodity #f)))
- ;; If this is an Euro currency, create the
- ;; pair of appropriately exchanged amounts.
- (if euro-monetary
- (let ((a (gnc:make-value-collector)))
- (a 'add
- (gnc:gnc-monetary-amount euro-monetary))
- (list report-commodity
- (cons (cdadr pair) a)))
- #f))))
- ;; Find the pair's currency in reportlist. FIXME:
- ;; Also try the Euro here.
- (pair-b (assoc (car pair) reportlist))
- (rate 0))
- (if (and (not pair-a) (not pair-b))
- ;; If neither the currency of otherlist nor of
- ;; pair was found in reportlist then we can't
- ;; resolve the exchange rate to this currency.
- (warn "gnc:resolve-unknown-comm:"
- "can't calculate rate for "
- (gnc:monetary->string
- (gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
- " = "
- (gnc:monetary->string
- (gnc:make-gnc-monetary (car otherlist) ((cdadr pair) 'total #f)))
- " to "
- (gnc:monetary->string
- (gnc:make-gnc-monetary report-commodity 0)))
- (if (and pair-a pair-b)
- ;; If both currencies are found then something
- ;; went wrong inside
- ;; gnc:get-exchange-totals. FIXME: Find a
- ;; better thing to do in this case.
- (warn "gnc:resolve-unknown-comm:"
- "Oops - exchange rate ambiguity error: "
- (gnc:monetary->string
- (gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
- " = "
- (gnc:monetary->string
- (gnc:make-gnc-monetary (car otherlist)
- ((cdadr pair) 'total #f))))
- (let
- ;; Usual case: one of pair-{a,b} was found
- ;; in reportlist, i.e. this transaction
- ;; can be resolved to report-commodity.
- ((newrate
- (if (not pair-a)
- (list (car otherlist)
- (make-newrate (cdadr pair)
- (caadr pair) pair-b))
- (list (car pair)
- (make-newrate (caadr pair)
- (cdadr pair) pair-a)))))
- (set! reportlist (cons newrate reportlist))))))
- ;; Huh, the report-currency showed up on the wrong side
- ;; -- we will just add it to the reportlist on the
- ;; right side.
- (let ((newrate (list (car otherlist)
- (cons (cdadr pair) (caadr pair)))))
- (set! reportlist (cons newrate reportlist)))))
- (cadr otherlist))))
- sumlist)
-
- ;; Return the reportlist.
- reportlist))
+
+ ;; Helper function to calculate (a*b)/c and create the new pair of
+ ;; numeric-collectors, where [abc] are numeric-collectors. See the
+ ;; real variable names below.
+ (define (make-newrate unknown-coll un->known-coll known-pair)
+ (let ((a (gnc:make-value-collector))
+ (b (gnc:make-value-collector))
+ (c ((caadr known-pair) 'total #f)))
+ (a 'add (unknown-coll 'total #f))
+ (unless (zero? c)
+ (b 'add (/ (* (un->known-coll 'total #f)
+ ((cdadr known-pair) 'total #f))
+ c)))
+ (cons a b)))
+
+ ;; Go through sumlist.
+ (let loop ((sumlist sumlist)
+ (reportlist (cadr (assoc report-commodity sumlist))))
+ (cond
+ ((null? sumlist) reportlist)
+
+ ((gnc-commodity-equiv (caar sumlist) report-commodity)
+ (loop (cdr sumlist) reportlist))
+
+ (else
+ (let innerloop ((pairs (cadr (car sumlist)))
+ (reportlist reportlist))
+ (cond
+ ((null? pairs)
+ (loop (cdr sumlist) reportlist))
+
+ ;; Check whether by any accident the report-commodity appears
+ ;; here. Huh, the report-currency showed up on the wrong
+ ;; side -- we will just add it to the reportlist on the right
+ ;; side.
+ ((gnc-commodity-equiv (caar pairs) report-commodity)
+ (innerloop (cdr pairs)
+ (cons (list (caar sumlist)
+ (cons (cdadr (car pairs)) (caadr (car pairs))))
+ reportlist)))
+
+ (else
+ ;; pair-{a,b}: Try to find either the currency of (car
+ ;; sumlist) or of pair in reportlist.
+ (let* ((pair (car pairs))
+ (pair-a (or (assoc (car (car sumlist)) reportlist)
+ ;; Find the (car sumlist)'s currency in reportlist
+ ;; Or try whether that's an Euro currency.
+ (let ((euro-monetary
+ (gnc:exchange-by-euro
+ (gnc:make-gnc-monetary
+ (car (car sumlist))
+ ((cdadr pair) 'total #f))
+ report-commodity #f)))
+ ;; If this is an Euro currency, create the
+ ;; pair of appropriately exchanged amounts.
+ (and euro-monetary
+ (let ((a (gnc:make-value-collector)))
+ (a 'add (gnc:gnc-monetary-amount euro-monetary))
+ (list report-commodity
+ (cons (cdadr pair) a)))))))
+ ;; Find the pair's currency in reportlist. FIXME:
+ ;; Also try the Euro here.
+ (pair-b (assoc (car pair) reportlist)))
+
+ (cond
+ ((and (not pair-a) (not pair-b))
+ ;; If neither the currency of (car sumlist) nor of pair
+ ;; was found in reportlist then we can't resolve the
+ ;; exchange rate to this currency.
+ (warn "gnc:resolve-unknown-comm:"
+ "can't calculate rate for "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
+ " = "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary (caar sumlist) ((cdadr pair) 'total #f)))
+ " to "
+ (gnc:monetary->string (gnc:make-gnc-monetary report-commodity 0)))
+ (innerloop (cdr pairs) reportlist))
+
+ ((and pair-a pair-b)
+ ;; If both currencies are found then something went
+ ;; wrong inside gnc:get-exchange-totals. FIXME: Find a
+ ;; better thing to do in this case.
+ (warn "gnc:resolve-unknown-comm:"
+ "Oops - exchange rate ambiguity error: "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary (car pair) ((caadr pair) 'total #f)))
+ " = "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary (caar sumlist) ((cdadr pair) 'total #f))))
+ (innerloop (cdr pairs) reportlist))
+
+ ;; Usual case: one of pair-{a,b} was found in reportlist,
+ ;; i.e. this transaction can be resolved to
+ ;; report-commodity.
+ (pair-a
+ (innerloop (cdr pairs)
+ (cons (list (car pair)
+ (make-newrate (caadr pair) (cdadr pair) pair-a))
+ reportlist)))
+ (pair-b
+ (innerloop (cdr pairs)
+ (cons (list (car (car sumlist))
+ (make-newrate (cdadr pair) (caadr pair) pair-b))
+ reportlist))))))))))))
+
;; Some thoughts: In the (and (not pair-a) (not pair-b)) case above we
;; will have unresolvable transaction exchange rates. But there might
;; be cases where we will be able to resolve this, but only after one
commit ce675eaac6b52e85cd9fe8602002f7b9d55e63ba
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Apr 5 23:31:45 2019 +0800
[commodity-utils] refactor get-exchange-cost-totals
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 1e7a90405..a0c636df5 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -563,74 +563,83 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; gains and losses, of each commodity across all accounts. Returns a
;; report-list.
(define (gnc:get-exchange-cost-totals report-commodity end-date)
- (let ((curr-accounts
- (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
- (sumlist (list (list report-commodity '()))))
-
- (if (not (null? curr-accounts))
- ;; Go through all splits and add up all value-amounts
- ;; and share-amounts
- ;; However skip splits in trading accounts as these counterbalance
- ;; the actual value and share amounts back to zero
- (for-each
- (lambda (a)
- (if (not (eq? (xaccAccountGetType (xaccSplitGetAccount a)) ACCT-TYPE-TRADING))
- (let* ((transaction-comm (xaccTransGetCurrency
- (xaccSplitGetParent a)))
- (account-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount a)))
- (share-amount (xaccSplitGetAmount a))
- (value-amount (xaccSplitGetValue a))
- (comm-list (or (assoc transaction-comm sumlist)
- (assoc account-comm sumlist))))
-
- ;; entry exists already in comm-list?
- (if (not comm-list)
- ;; no, create sub-alist from scratch
- (let ((pair (list transaction-comm
- (cons (gnc:make-value-collector)
+ (let ((curr-accounts (gnc-account-get-descendants-sorted
+ (gnc-get-current-root-account))))
+
+ (let loop ((comm-splits (gnc:get-all-commodity-splits curr-accounts end-date))
+ (sumlist (list (list report-commodity '()))))
+ (cond
+ ((null? comm-splits)
+ (gnc:resolve-unknown-comm sumlist report-commodity))
+
+ ;; However skip splits in trading accounts as these counterbalance
+ ;; the actual value and share amounts back to zero
+ ((eqv? (xaccAccountGetType (xaccSplitGetAccount (car comm-splits)))
+ ACCT-TYPE-TRADING)
+ (loop (cdr comm-splits)
+ sumlist))
+
+ ;; Go through all splits and add up all value-amounts
+ ;; and share-amounts
+ (else
+ (let* ((a (car comm-splits))
+ (txn-comm (xaccTransGetCurrency (xaccSplitGetParent a)))
+ (acc-comm (xaccAccountGetCommodity (xaccSplitGetAccount a)))
+ (share-amt (xaccSplitGetAmount a))
+ (value-amt (xaccSplitGetValue a)))
+
+ (cond
+ ((assoc txn-comm sumlist)
+ => (lambda (comm-list)
+ (cond
+ ;; other commodity already exists in comm-list?
+ ((assoc acc-comm (cadr comm-list))
+ => (lambda (pair)
+ ((caadr pair) 'add share-amt)
+ ((cdadr pair) 'add value-amt)
+ (loop (cdr comm-splits)
+ sumlist)))
+ ;; if not, create a new entry in comm-list.
+ (else
+ (let ((pair (list acc-comm (cons (gnc:make-value-collector)
+ (gnc:make-value-collector)))))
+ ((caadr pair) 'add share-amt)
+ ((cdadr pair) 'add value-amt)
+ (loop (cdr comm-splits)
+ (cons (list (car comm-list) (cons pair (cadr comm-list)))
+ (alist-delete
+ (car comm-list) sumlist))))))))
+
+ ((assoc acc-comm sumlist)
+ => (lambda (comm-list)
+ (cond
+ ;; other commodity already exists in comm-list?
+ ((assoc txn-comm (cadr comm-list))
+ => (lambda (pair)
+ ((caadr pair) 'add (- value-amt))
+ ((cdadr pair) 'add (- share-amt))
+ (loop (cdr comm-splits)
+ sumlist)))
+ (else
+ (let ((pair (list txn-comm (cons (gnc:make-value-collector)
+ (gnc:make-value-collector)))))
+ ;; And add the balances to the comm-list entry.
+ ((caadr pair) 'add (- value-amt))
+ ((cdadr pair) 'add (- share-amt))
+ (loop (cdr comm-splits)
+ (cons (list (car comm-list) (cons pair (cadr comm-list)))
+ (alist-delete
+ (car comm-list) sumlist))))))))
+
+ (else
+ ;; no, create sub-alist from scratch
+ (let ((pair (list txn-comm (cons (gnc:make-value-collector)
(gnc:make-value-collector)))))
- ((caadr pair) 'add value-amount)
- ((cdadr pair) 'add share-amount)
- (set! comm-list (list account-comm (list pair)))
- ;; and add the new sub-alist to sumlist.
- (set! sumlist (cons comm-list sumlist)))
- ;; yes, check for second commodity.
- (let*
- ;; Put the amounts in the right place.
- ((foreignlist
- (if (gnc-commodity-equiv transaction-comm
- (car comm-list))
- (list account-comm
- share-amount value-amount)
- (list transaction-comm
- (- value-amount)
- (- share-amount))))
- ;; second commodity already existing in comm-list?
- (pair (assoc (car foreignlist) (cadr comm-list))))
- ;; if not, create a new entry in comm-list.
- (if (not pair)
- (begin
- (set!
- pair (list (car foreignlist)
- (cons (gnc:make-value-collector)
- (gnc:make-value-collector))))
- (set!
- comm-list (list (car comm-list)
- (cons pair (cadr comm-list))))
- (set!
- sumlist (cons comm-list
- (alist-delete
- (car comm-list) sumlist)))))
- ;; And add the balances to the comm-list entry.
- ((caadr pair) 'add (cadr foreignlist))
- ((cdadr pair) 'add (caddr foreignlist)))))))
- (gnc:get-all-commodity-splits curr-accounts end-date)))
-
- (gnc:resolve-unknown-comm sumlist report-commodity)))
-
-;; Anybody feel free to reimplement any of these functions, either in
-;; scheme or in C. -- cstim
+ ((caadr pair) 'add value-amt)
+ ((cdadr pair) 'add share-amt)
+ ;; and add the new sub-alist to sumlist.
+ (loop (cdr comm-splits)
+ (cons (list acc-comm (list pair)) sumlist)))))))))))
(define (gnc:make-exchange-alist report-commodity end-date)
;; This returns the alist with the actual exchange rates, i.e. the
commit b2dc906bcd7c2597aaa585d4c8ae7248783b765c
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Apr 5 22:44:13 2019 +0800
[commodity-utils] refactor get-exchange-totals
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 2d49cc760..1e7a90405 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -484,75 +484,80 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
;; amount total of 2000 GBP and a value of 2400 EUR. Returns a report-list.
(define (gnc:get-exchange-totals report-commodity end-date)
- (let ((curr-accounts
- (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
- (sumlist (list (list report-commodity '()))))
-
- (if (not (null? curr-accounts))
- ;; Go through all splits and add up all value-amounts
- ;; and share-amounts
- (for-each
- (lambda (a)
- (let* ((transaction-comm (xaccTransGetCurrency
- (xaccSplitGetParent a)))
- (account-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount a)))
- ;; Always use the absolute value here.
- (share-amount (abs
- (xaccSplitGetAmount a)))
- (value-amount (abs
- (xaccSplitGetValue a)))
- (comm-list (or (assoc transaction-comm sumlist)
- (assoc account-comm sumlist))))
-
- (cond ((zero? share-amount)
- ;; Without shares this is not a buy or sell; ignore it.
- #f)
-
- ((not comm-list)
- ;; entry doesn't exist in comm-list
- ;; create sub-alist from scratch
- (let ((pair (list transaction-comm
- (cons (gnc:make-value-collector)
- (gnc:make-value-collector)))))
- ((caadr pair) 'add value-amount)
- ((cdadr pair) 'add share-amount)
- (set! comm-list (list account-comm (list pair)))
- ;; and add the new sub-alist to sumlist.
- (set! sumlist (cons comm-list sumlist))))
-
- (else
- (let*
- ;; Put the amounts in the right place.
- ((foreignlist
- (if (gnc-commodity-equiv transaction-comm
- (car comm-list))
- (list account-comm
- share-amount value-amount)
- (list transaction-comm
- value-amount share-amount)))
- ;; second commodity already existing in comm-list?
- (pair (assoc (car foreignlist) (cadr comm-list))))
- ;; if not, create a new entry in comm-list.
- (if (not pair)
- (begin
- (set!
- pair (list (car foreignlist)
- (cons (gnc:make-value-collector)
- (gnc:make-value-collector))))
- (set!
- comm-list (list (car comm-list)
- (cons pair (cadr comm-list))))
- (set!
- sumlist (cons comm-list
- (alist-delete
- (car comm-list) sumlist)))))
- ;; And add the balances to the comm-list entry.
- ((caadr pair) 'add (cadr foreignlist))
- ((cdadr pair) 'add (caddr foreignlist)))))))
- (gnc:get-all-commodity-splits curr-accounts end-date)))
-
- (gnc:resolve-unknown-comm sumlist report-commodity)))
+ (let ((curr-accounts (gnc-account-get-descendants-sorted
+ (gnc-get-current-root-account))))
+
+ ;; Go through all splits and add up all value-amounts
+ ;; and share-amounts
+ (let loop ((comm-splits (gnc:get-all-commodity-splits curr-accounts end-date))
+ (sumlist (list (list report-commodity '()))))
+ (cond
+ ((null? comm-splits)
+ (gnc:resolve-unknown-comm sumlist report-commodity))
+
+ (else
+ (let* ((a (car comm-splits))
+ (txn-comm (xaccTransGetCurrency (xaccSplitGetParent a)))
+ (acc-comm (xaccAccountGetCommodity (xaccSplitGetAccount a)))
+ ;; Always use the absolute value here.
+ (share-amt (abs (xaccSplitGetAmount a)))
+ (value-amt (abs (xaccSplitGetValue a))))
+ (cond
+ ;; Without shares this is not a buy or sell; ignore it.
+ ((zero? share-amt)
+ (loop (cdr comm-splits)
+ sumlist))
+
+ ((assoc txn-comm sumlist)
+ => (lambda (comm-list)
+ (cond
+ ((assoc acc-comm (cadr comm-list)) =>
+ ;; second commodity already exists in comm-list:
+ (lambda (pair)
+ ((caadr pair) 'add share-amt)
+ ((cdadr pair) 'add value-amt)
+ (loop (cdr comm-splits)
+ sumlist)))
+ (else
+ ;; if not, create a new entry in comm-list.
+ (let ((pair (list acc-comm (cons (gnc:make-value-collector)
+ (gnc:make-value-collector)))))
+ ((caadr pair) 'add share-amt)
+ ((cdadr pair) 'add value-amt)
+ (loop (cdr comm-splits)
+ (cons (list txn-comm (cons pair (cadr comm-list)))
+ (alist-delete txn-comm sumlist))))))))
+
+ ((assoc acc-comm sumlist)
+ => (lambda (comm-list)
+ (cond
+ ((assoc txn-comm (cadr comm-list)) =>
+ ;; second commodity already exists in comm-list:
+ (lambda (pair)
+ ((caadr pair) 'add value-amt)
+ ((cdadr pair) 'add share-amt)
+ (loop (cdr comm-splits)
+ sumlist)))
+ (else
+ ;; if not, create a new entry in comm-list.
+ (let ((pair (list txn-comm (cons (gnc:make-value-collector)
+ (gnc:make-value-collector)))))
+ ((caadr pair) 'add value-amt)
+ ((cdadr pair) 'add share-amt)
+ (loop (cdr comm-splits)
+ (cons (list acc-comm (cons pair (cadr comm-list)))
+ (alist-delete acc-comm sumlist))))))))
+
+ ;; entry doesn't exist in sumlist. create sub-alist from scratch
+ (else
+ (let ((pair (list txn-comm
+ (cons (gnc:make-value-collector)
+ (gnc:make-value-collector)))))
+ ((caadr pair) 'add value-amt)
+ ((cdadr pair) 'add share-amt)
+ (loop (cdr comm-splits)
+ (cons (list acc-comm (list pair))
+ sumlist)))))))))))
;; Sum the net amounts and values in the report commodity, including booked
;; gains and losses, of each commodity across all accounts. Returns a
commit 9ef2a2f3dd82a7731cb9dc11f4d7e5190e038f45
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Apr 5 21:23:18 2019 +0800
[commodity-utils] refactor inst price calculator
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 4938ef0c7..2d49cc760 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -228,68 +228,49 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
(define (gnc:get-commodity-inst-prices
currency-accounts end-date price-commodity report-currency)
;; go through all splits; convert all splits into a price.
- (filter
- gnc:price-is-not-zero?
- (map-in-order
- (lambda (a)
- (let* ((transaction-comm (xaccTransGetCurrency
- (xaccSplitGetParent a)))
- (account-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount a)))
- (share-amount (abs
- (xaccSplitGetAmount a)))
- (value-amount (abs
- (xaccSplitGetValue a)))
- (transaction-date (xaccTransGetDate
- (xaccSplitGetParent a)))
- (foreignlist
- (if (gnc-commodity-equiv transaction-comm price-commodity)
- (list account-comm
- share-amount value-amount)
- (list transaction-comm
- value-amount share-amount))))
-
- ;; Try EURO exchange if necessary
- (if (not (gnc-commodity-equiv (car foreignlist)
- report-currency))
- (let ((exchanged (gnc:exchange-by-euro-numeric
- (car foreignlist) (cadr foreignlist)
- report-currency transaction-date)))
- (if exchanged
- (set! foreignlist
- (list report-currency
- (gnc:gnc-monetary-amount exchanged)
- (caddr foreignlist))))))
-
- (list
- transaction-date
- (if (not (gnc-commodity-equiv (car foreignlist)
- report-currency))
- (begin
- (warn "get-commodity-inst-prices: "
- "Sorry, currency exchange not yet implemented:"
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- (car foreignlist) (cadr foreignlist)))
- " (buying "
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- price-commodity (caddr foreignlist)))
- ") =? "
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- report-currency 0)))
- 0)
- (if (not (zero? (caddr foreignlist)))
- (gnc-numeric-div
- (cadr foreignlist)
- (caddr foreignlist)
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND)) 0)))))
- ;; Get all the interesting splits, sorted by date.
- (gnc:get-match-commodity-splits-sorted
- currency-accounts
- end-date price-commodity))))
+ (let loop ((result '())
+ (commodity-splits (gnc:get-match-commodity-splits-sorted
+ currency-accounts end-date price-commodity)))
+ (if (null? commodity-splits)
+ (reverse! result)
+ (let* ((a (car commodity-splits))
+ (txn-comm (xaccTransGetCurrency (xaccSplitGetParent a)))
+ (acc-comm (xaccAccountGetCommodity (xaccSplitGetAccount a)))
+ (share-amt (abs (xaccSplitGetAmount a)))
+ (value-amt (abs (xaccSplitGetValue a)))
+ (txn-date (xaccTransGetDate (xaccSplitGetParent a))))
+ (cond
+ ((or (zero? share-amt) (zero? value-amt))
+ (loop result
+ (cdr commodity-splits)))
+
+ ((gnc-commodity-equiv acc-comm report-currency)
+ (loop (cons (list txn-date (/ share-amt value-amt)) result)
+ (cdr commodity-splits)))
+
+ ((gnc-commodity-equiv txn-comm report-currency)
+ (loop (cons (list txn-date (/ value-amt share-amt)) result)
+ (cdr commodity-splits)))
+
+ ((gnc:exchange-by-euro-numeric txn-comm value-amt report-currency txn-date)
+ => (lambda (amt)
+ (loop (cons (list txn-date (/ (gnc:gnc-monetary-amount amt) share-amt))
+ result)
+ (cdr commodity-splits))))
+
+ (else
+ (warn "get-commodity-inst-prices: "
+ "Sorry, currency exchange not yet implemented:"
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary txn-comm value-amt))
+ " (buying "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary price-commodity share-amt))
+ ") =? "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary report-currency 0)))
+ (loop result
+ (cdr commodity-splits))))))))
;; Get the instantaneous prices for all commodities in
;; 'commodity-list', i.e. the same thing as get-commodity-inst-prices
commit 91f3e9fefec44e392adf3968d9cdc7117b7d8913
Author: Christopher Lam <christopher.lck at gmail.com>
Date: Fri Apr 5 21:01:33 2019 +0800
[commodity-utils] refactor totalavg price calculator
use exact rationals, therefore test suite amended
diff --git a/gnucash/report/report-system/commodity-utilities.scm b/gnucash/report/report-system/commodity-utilities.scm
index 972672717..4938ef0c7 100644
--- a/gnucash/report/report-system/commodity-utilities.scm
+++ b/gnucash/report/report-system/commodity-utilities.scm
@@ -121,86 +121,66 @@ construct with gnc:make-gnc-monetary and gnc:monetary->string instead.")
currency-accounts end-date price-commodity)))
(define (gnc:get-commodity-totalavg-prices-internal
- currency-accounts end-date price-commodity report-currency
- commodity-splits)
- (let ((total-foreign 0)
- (total-domestic 0))
- (filter
- gnc:price-is-not-zero?
- (map-in-order
- (lambda (a)
- (let* ((transaction-comm (xaccTransGetCurrency
- (xaccSplitGetParent a)))
- (account-comm (xaccAccountGetCommodity
- (xaccSplitGetAccount a)))
- (share-amount (abs
- (xaccSplitGetAmount a)))
- (value-amount (abs
- (xaccSplitGetValue a)))
- (transaction-date (xaccTransGetDate
- (xaccSplitGetParent a)))
- (foreignlist
- (if (and
- (not (zero? share-amount))
- (not (zero? value-amount)))
- (if (gnc-commodity-equiv transaction-comm
- price-commodity)
- (list account-comm
- share-amount value-amount)
- (list transaction-comm
- value-amount share-amount))
- #f)))
-
- ;; Try EURO exchange if necessary
- (if (and foreignlist
- (not (gnc-commodity-equiv (car foreignlist)
- report-currency)))
- (let ((exchanged (gnc:exchange-by-euro-numeric
- (car foreignlist) (cadr foreignlist)
- report-currency transaction-date)))
- (if exchanged
- (set! foreignlist
- (list report-currency
- (gnc:gnc-monetary-amount exchanged)
- (caddr foreignlist))))))
-
- (list
- transaction-date
- (if foreignlist
- (if (not (gnc-commodity-equiv (car foreignlist)
- report-currency))
- (begin
- (warn "gnc:get-commodity-totalavg-prices: "
- "Sorry, currency exchange not yet implemented:"
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- (car foreignlist) (cadr foreignlist)))
- " (buying "
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- price-commodity (caddr foreignlist)))
- ") =? "
- (gnc:monetary->string
- (gnc:make-gnc-monetary
- report-currency 0)))
- 0)
- (begin
- (set! total-foreign (gnc-numeric-add total-foreign
- (caddr foreignlist)
- GNC-DENOM-AUTO
- GNC-DENOM-LCD))
- (set! total-domestic (gnc-numeric-add total-domestic
- (cadr foreignlist)
- GNC-DENOM-AUTO
- GNC-DENOM-LCD))
- (if (not (zero? total-foreign))
- (gnc-numeric-div
- total-domestic
- total-foreign
- GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND)) 0)))
- #f))))
- commodity-splits))))
+ currency-accounts end-date price-commodity report-currency commodity-splits)
+ (let loop ((tot-foreign 0)
+ (tot-domestic 0)
+ (commodity-splits commodity-splits)
+ (result '()))
+ (if (null? commodity-splits)
+ (reverse! result)
+ (let* ((a (car commodity-splits))
+ (share-amt (abs (xaccSplitGetAmount a)))
+ (value-amt (abs (xaccSplitGetValue a)))
+ (txn-comm (xaccTransGetCurrency (xaccSplitGetParent a)))
+ (acc-comm (xaccAccountGetCommodity (xaccSplitGetAccount a)))
+ (txn-date (xaccTransGetDate (xaccSplitGetParent a))))
+ (cond
+ ((or (zero? share-amt) (zero? value-amt))
+ (loop tot-foreign
+ tot-domestic
+ (cdr commodity-splits)
+ result))
+
+ ((gnc-commodity-equiv acc-comm report-currency)
+ (let ((new-foreign (+ tot-foreign value-amt))
+ (new-domestic (+ tot-domestic share-amt)))
+ (loop new-foreign
+ new-domestic
+ (cdr commodity-splits)
+ (cons (list txn-date (/ new-domestic new-foreign)) result))))
+
+ ((gnc-commodity-equiv txn-comm report-currency)
+ (let ((new-foreign (+ tot-foreign share-amt))
+ (new-domestic (+ tot-domestic value-amt)))
+ (loop new-foreign
+ new-domestic
+ (cdr commodity-splits)
+ (cons (list txn-date (/ new-domestic new-foreign)) result))))
+
+ ((gnc:exchange-by-euro-numeric txn-comm value-amt report-currency txn-date)
+ => (lambda (amt)
+ (let ((new-foreign (+ tot-foreign share-amt))
+ (new-domestic (+ tot-domestic (gnc:gnc-monetary-amount amt))))
+ (loop new-foreign
+ new-domestic
+ (cdr commodity-splits)
+ (cons (list txn-date (/ new-domestic new-foreign)) result)))))
+
+ (else
+ (warn "gnc:get-commodity-totalavg-prices: "
+ "Sorry, currency exchange not yet implemented:"
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary txn-comm value-amt))
+ " (buying "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary price-commodity share-amt))
+ ") =? "
+ (gnc:monetary->string
+ (gnc:make-gnc-monetary report-currency 0)))
+ (loop tot-foreign
+ tot-domestic
+ (cdr commodity-splits)
+ result)))))))
;; Create a list of prices for all commodities in 'commodity-list',
diff --git a/gnucash/report/report-system/test/test-commodity-utils.scm b/gnucash/report/report-system/test/test-commodity-utils.scm
index 3a17d62ab..7a1e1cac1 100644
--- a/gnucash/report/report-system/test/test-commodity-utils.scm
+++ b/gnucash/report/report-system/test/test-commodity-utils.scm
@@ -566,26 +566,22 @@
(test-equal "MSFT totalavg 2012-01-15" (/ 4216500/100 1500)
(cadr (assoc (gnc-dmy2time64-neutral 15 01 2012)
report-list)))
-;; We have to use gnc-numeric-div with rounding in order to match the results
-;; from the function. Astute observers will notice that the totals include the
+;; Astute observers will notice that the totals include the
;; capital gain split but not the acutal sell split on the day because the
;; capital gain price is first in the list so that's the one (assoc) finds. See
;; the comment at the gnc:get-commodity-totalavg-prices definition for more
;; about the prices from this function.
(test-equal "MSFT totalavg 2014-12-05"
- (gnc-numeric-div 6637500/100 2000 GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
- (cadr (assoc (gnc-dmy2time64-neutral 5 12 2014)
- report-list)))
+ (/ 6637500/100 2000)
+ (cadr (assoc (gnc-dmy2time64-neutral 5 12 2014)
+ report-list)))
(test-equal "MSFT totalavg 2015-04-02"
- (gnc-numeric-div 9860700/100 2800 GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
- (cadr (assoc (gnc-dmy2time64-neutral 2 4 2015) report-list)))
+ (/ 9860700/100 2800)
+ (cadr (assoc (gnc-dmy2time64-neutral 2 4 2015) report-list)))
(test-equal "MSFT totalavg 2016-03-11"
- (gnc-numeric-div 14637000/100 3700 GNC-DENOM-AUTO
- (logior (GNC-DENOM-SIGFIGS 8) GNC-RND-ROUND))
- (cadr (assoc (gnc-dmy2time64-neutral 11 3 2016)
- report-list))))
+ (/ 14637000/100 3700)
+ (cadr (assoc (gnc-dmy2time64-neutral 11 3 2016)
+ report-list))))
(test-end "Microsoft-USD")
(test-begin "Daimler-DEM")
Summary of changes:
.../report/report-system/commodity-utilities.scm | 854 ++++++++++-----------
.../report-system/test/test-commodity-utils.scm | 24 +-
gnucash/report/stylesheets/stylesheet-easy.scm | 244 +++---
gnucash/report/stylesheets/stylesheet-fancy.scm | 248 +++---
gnucash/report/stylesheets/stylesheet-footer.scm | 251 +++---
.../report/stylesheets/stylesheet-head-or-tail.scm | 430 +++++------
gnucash/report/stylesheets/stylesheet-plain.scm | 178 ++---
gnucash/report/stylesheets/stylesheets.scm | 4 +-
libgnucash/app-utils/options.scm | 8 +-
9 files changed, 1083 insertions(+), 1158 deletions(-)
More information about the gnucash-changes
mailing list