IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2025-02-25 18:55:30 -06:00
Code Issues Packages Projects Releases Wiki Activity

[master] remove deprecated scheme functions

Browse Source
This commit is contained in:
Christopher Lam 2021-01-01 20:30:27 +08:00
parent 5378023075
commit ebcb0bc478
34 changed files with 10 additions and 4665 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
bindings/guile/CMakeLists.txt
View File

@ -127,14 +127,6 @@ gnc_add_scheme_targets(scm-engine-2
add_custom_target(scm-engine ALL DEPENDS scm-engine-2 scm-engine-1 scm-engine-0)
set(scm_gnc_module_DEPENDS
gnucash-guile)
gnc_add_scheme_targets(scm-gnc-module
SOURCES gnc-module.scm
OUTPUT_DIR gnucash
DEPENDS "${scm_gnc_module_DEPENDS}")
set_local_dist(guile_DIST_local
CMakeLists.txt
core-utils.scm

35
bindings/guile/business-core.scm
View File

@ -30,7 +30,6 @@
(export gnc:owner-get-address-dep)
(export gnc:owner-get-name-and-address-dep)
(export gnc:owner-get-owner-id)
(export gnc:owner-from-split)
(export gnc:split->owner)
(define (gnc:owner-get-address owner)
@ -105,37 +104,9 @@
(gnc:owner-get-owner-id (gncJobGetOwner (gncOwnerGetJob owner))))
(else ""))))
;; this function aims to find a split's owner. various splits are
;; supported: (1) any splits in the invoice posted transaction, in
;; APAR or income/expense accounts (2) any splits from invoice's
;; payments, in APAR or asset/liability accounts. it returns either
;; the owner or '() if not found. in addition, if owner was found, the
;; result-owner argument is mutated to it.
(define (gnc:owner-from-split split result-owner)
(define (notnull x) (and (not (null? x)) x))
(issue-deprecation-warning
"gnc:owner-from-split is deprecated in 4.x. use gnc:split->owner instead.")
(let* ((trans (xaccSplitGetParent split))
(invoice (notnull (gncInvoiceGetInvoiceFromTxn trans)))
(temp (gncOwnerNew))
(owner (or (and invoice (gncInvoiceGetOwner invoice))
(any
(lambda (split)
(let* ((lot (xaccSplitGetLot split))
(invoice (notnull (gncInvoiceGetInvoiceFromLot lot))))
(or (and invoice (gncInvoiceGetOwner invoice))
(and (gncOwnerGetOwnerFromLot lot temp) temp))))
(xaccTransGetSplitList trans)))))
(gncOwnerFree temp)
(cond (owner (gncOwnerCopy (gncOwnerGetEndOwner owner) result-owner)
result-owner)
(else '()))))
;; optimized from above, and simpler: does not search all transaction
;; splits. It will allocate and memoize (cache) the owners because
;; gncOwnerGetOwnerFromLot is slow. after use, it must be called with
;; #f to free the owners.
;; this function aims to find a split's owner. It will allocate and
;; memoize (cache) the owners because gncOwnerGetOwnerFromLot is
;; slow. after use, it must be called with #f to free the owners.
(define gnc:split->owner
(let ((ht (make-hash-table)))
(lambda (split)

30
bindings/guile/engine.scm
View File

@ -31,33 +31,3 @@
(gnucash engine commodity-table)
(gnucash engine gnc-numeric))
(export gnc:account-map-descendants)
(export gnc:account-map-children)
(export account-full-name<?)
(export accounts-get-children-depth)
;; A few account related utility functions which used to be in engine-utilities.scm
(define (gnc:account-map-descendants thunk account)
(issue-deprecation-warning "gnc:account-map-descendants is deprecated.")
(map thunk (or (gnc-account-get-descendants-sorted account) '())))
(define (gnc:account-map-children thunk account)
(issue-deprecation-warning "gnc:account-map-children is deprecated.")
(map thunk (or (gnc-account-get-children-sorted account) '())))
;; account related functions
;; helper for sorting of account list
(define (account-full-name<? a b)
(issue-deprecation-warning
"account-full-name<? is deprecated. use gnc:account-full-name<? instead.")
(string<? (gnc-account-get-full-name a) (gnc-account-get-full-name b)))
;; return maximum depth over accounts and their children, if any
(define (accounts-get-children-depth accounts)
(issue-deprecation-warning "accounts-get-children-depth is deprecated. use \
gnc:accounts-get-children-depth instead.")
(1- (apply max
(map (lambda (acct)
(+ (gnc-account-get-current-depth acct)
(gnc-account-get-tree-depth acct)))
accounts))))

88
bindings/guile/gnc-module.scm
View File

@ -1,88 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; gnc-module.scm
;;; Guile module which allows initialization of the gnucash module
;;; system from Scheme
;;;
;;; Copyright 2001 Linux Developers Group
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash gnc-module))
(use-modules (ice-9 match))
(define (deprecate . lst)
;; 4.x deprecation. remove in 5.x
(issue-deprecation-warning (string-concatenate lst)))
(define (no-op-deprecation-warning)
(deprecate "* WARNING * Guile wrappers for the gnc module system have been \
deprecated. This particular function call is now a no-op. Please use \
equivalent (use-modules ...) calls instead."))
(define-public gnc:module-system-init no-op-deprecation-warning)
(define-public gnc:module-system-refresh no-op-deprecation-warning)
(define-public gnc:module-load-optional no-op-deprecation-warning)
(define-public gnc:module-unload no-op-deprecation-warning)
(define-public (gnc:module-load gnc-mod-name mod-sys-version)
(let* ((mod-name-split (string-split gnc-mod-name #\/))
(mod-name-str (string-join mod-name-split " "))
(scm-mod-name (map string->symbol mod-name-split)))
(match gnc-mod-name
("gnucash/app-utils"
(deprecate "* WARNING * 'gnc:module-load (\"gnucash/app-utils\" 0)' has \
been deprecated and will be removed in gnucash 5.0. Use '(use-modules (gnucash \
engine) (gnucash app-utils))' instead. Use of the '(gnucash engine)' guile \
module is optional and depends on whether or not you use functions from \
this module in your code or not.")
(use-modules (gnucash engine) (gnucash app-utils)))
((or "gnucash/tax/de_DE" "gnucash/tax/us")
(set! scm-mod-name `(gnucash locale ,(list-ref scm-mod-name 2) tax))
(set! mod-name-str (string-join (map symbol->string scm-mod-name) " "))
(deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' has \
been deprecated. Use '(use-modules (" mod-name-str "))' instead.")
(module-use! (current-module) (resolve-interface scm-mod-name)))
((or "gnucash/gnome-utils" "gnucash/report/report-system")
(when (string=? gnc-mod-name "gnucash/report/report-system")
(set! mod-name-str "gnucash report"))
(set! scm-mod-name '(gnucash report))
(deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' has \
been deprecated. Use '(use-modules (gnucash engine) (gnucash app-utils) \
(" mod-name-str "))' instead. Use of the '(gnucash engine)' or \
'(gnucash app-utils)' guile modules is optional and depends on whether \
or not you use functions from this module in your code or not.")
(use-modules (gnucash engine) (gnucash app-utils))
(module-use! (current-module) (resolve-interface scm-mod-name)))
("gnucash/html"
(deprecate "* WARNING * '(gnc:module-load \"gnucash/html\" 0)' has \
been deprecated. Use '(use-modules (gnucash html))' instead.")
(use-modules (gnucash html))
(module-use! (current-module) (resolve-interface scm-mod-name)))
(_ (deprecate "* WARNING * '(gnc:module-load \"" gnc-mod-name "\" 0)' \
has been deprecated. Use '(use-modules (" mod-name-str "))' instead. \
Additional guile modules may have to be loaded depending on your specific code.")
(module-use! (current-module) (resolve-interface scm-mod-name))))))

2
bindings/guile/test/CMakeLists.txt
View File

@ -32,7 +32,6 @@ set(bindings_test_SCHEME
#list(APPEND engine_test_SCHEME test-scm-query-import.scm) Fails
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-core-utils
scm-engine)
@ -89,7 +88,6 @@ set(test_scm_SCHEME
)
set(GUILE_DEPENDS
scm-gnc-module
scm-app-utils
scm-engine
scm-srfi64-extras

53
bindings/guile/test/test-business-core.scm
View File

@ -242,57 +242,4 @@
(env-transfer env 01 01 1990
(get-acct "Income-GBP") (get-acct "Bank-GBP") 10)
(let ((new-owner (gncOwnerNew)))
(test-equal "new-owner is initially empty"
""
(gncOwnerGetName new-owner))
(test-equal "gnc:owner-from-split (from AR) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "AR-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from AR) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner (gncOwnerNew))
(test-equal "gnc:owner-from-split (from inc-acct) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Income-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from inc-acct) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner (gncOwnerNew))
(test-equal "gnc:owner-from-split (from payment txn) return"
"cust-1-name"
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Bank-USD")))
new-owner)))
(test-equal "gnc:owner-from-split (from payment txn) mutated"
"cust-1-name"
(gncOwnerGetName new-owner))
(set! new-owner 'reset)
(test-equal "gnc:owner-from-split (non-business split) return"
""
(gncOwnerGetName
(gnc:owner-from-split
(last (xaccAccountGetSplitList (get-acct "Bank-GBP")))
new-owner)))
(test-equal "gnc:owner-from-split (non-business split) mutated"
'reset
new-owner))
))

29
bindings/guile/test/test-scm-utilities.scm
View File

@ -34,35 +34,6 @@
"fooxyzfooxyz"
(gnc:substring-replace "foobarfoobar" "bar" "xyz"))
;; note the following 2 tests illustrate code behaviour: start from
;; 2nd matched substring, and perform either 2 or 1 substitution.
(test-equal "gnc:substring-replace-from-to ... ... 2 2"
"foobarfooxyzfooxyz"
(gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 2))
(test-equal "gnc:substring-replace-from-to ... ... 2 1"
"foobarfooxyzfoobar"
(gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 1))
;; comprehensive test suite for gnc:substring-replace-from-to:
(test-equal "gnc:substring-replace-from-to ... ... 2 1"
"foo xxx foo foo foo foo foo foo"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 2 1))
(test-equal "gnc:substring-replace-from-to ... ... 1 1"
"xxx foo foo foo foo foo foo foo"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 1 1))
(test-equal "gnc:substring-replace-from-to ... ... 4 -1"
"foo foo foo xxx xxx xxx xxx xxx"
(gnc:substring-replace-from-to
"foo foo foo foo foo foo foo foo"
"foo" "xxx" 4 -1))
(test-end "substring-replace"))
(define (test-sort-and-delete-duplicates)

20
bindings/guile/utilities.scm
View File

@ -124,26 +124,6 @@
(define (gnc:substring-replace s1 s2 s3)
(string-replace-substring s1 s2 s3))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gnc:substring-replace-from-to
;; same as gnc:substring-replace extended by:
;; start: from which occurrence onwards the replacement shall start
;; end-after: max. number times the replacement should executed
;;
;; Example: (gnc:substring-replace-from-to "foobarfoobarfoobar" "bar" "xyz" 2 1)
;; returns "foobarfooxyzfoobar".
;;
;; start=1 and end-after<=0 will call gnc:substring-replace (replace all)
;; start>1 and end-after<=0 will the replace from "start" until end of file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (gnc:substring-replace-from-to s1 s2 s3 start end-after)
(issue-deprecation-warning "gnc:substring-replace-from-to is deprecated in 4.x.")
(string-replace-substring
s1 s2 s3 0 (string-length s1) (max 0 (1- start))
(and (positive? end-after) (+ (max 0 (1- start)) (1- end-after)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; function to sanitize strings. the resulting string can be safely
;; added to html.

4
gnucash/report/CMakeLists.txt
View File

@ -53,12 +53,8 @@ set (report_SCHEME_1
commodity-utilities.scm
html-acct-table.scm
html-chart.scm
html-barchart.scm
html-document.scm
html-fonts.scm
html-piechart.scm
html-scatter.scm
html-linechart.scm
html-style-info.scm
html-style-sheet.scm
html-anytag.scm

57
gnucash/report/eguile-utilities.scm
View File

@ -41,40 +41,6 @@
(define-public fmtnumeric
(compose fmtnumber exact->inexact))
(define-public (gnc-monetary-neg? monetary)
;; return true if the monetary value is negative
(issue-deprecation-warning "gnc-monetary-neg? is deprecated")
(negative? (gnc:gnc-monetary-amount monetary)))
;; 'Safe' versions of cdr and cadr that don't crash
;; if the list is empty (is there a better way?)
(define-public safe-cdr
;; deprecate
(match-lambda
((_ . x) x)
(_ '())))
(define-public safe-cadr
;; deprecate
(match-lambda
((_ x . y) x)
(_ '())))
; deprecated - use find-stylesheet or find-template instead
(define-public (find-file fname)
;; Find the file 'fname', and return its full path.
;; First look in the user's .config/gnucash directory.
;; Then look in Gnucash's standard report directory.
;; If no file is found, returns just 'fname' for use in error messages.
(let* ((stylesheetpath (find-stylesheet fname))
(templatepath (find-template fname)))
; make sure there's a trailing delimiter
(issue-deprecation-warning "find-file is deprecated in 4.x. Please use find-stylesheet or find-template instead.")
(cond
((access? stylesheetpath R_OK) stylesheetpath)
((access? templatepath R_OK) templatepath)
(else fname))))
(define (find-internal ftype fname)
;; Find the file fname', and return its full path.
;; First look in the user's .config/gnucash directory.
@ -101,26 +67,3 @@
;; If no file is found, returns just 'fname' for use in error messages.
(find-internal "templates" fname))
;; Define syntax for more readable for loops (the built-in for-each
;; requires an explicit lambda and has the list expression all the way
;; at the end). Note: deprecated in 4.x, removal in 5.x. this syntax
;; is pythonic rather than lispy, is not recognized by code
;; highlighters, and is not necessary to seasoned schemers.
(export for)
(define-syntax for
(syntax-rules (for in do)
;; Multiple variables and equal number of lists (in
;; parenthesis). e.g.:
;; (for (a b) in (lsta lstb) do (display (+ a b)))
;; Note that this template must be defined before the
;; next one, since the template are evaluated in-order.
((for (<var> ...) in (<list> ...) do <expr> ...)
(begin
(issue-deprecation-warning "for loops are deprecated. use for-each instead.")
(for-each (lambda (<var> ...) <expr> ...) <list> ...)))
;; Single variable and list. e.g.: (for a in lst do (display a))
((for <var> in <list> do <expr> ...)
(begin
(issue-deprecation-warning "for loops are deprecated. use for-each instead.")
(for-each (lambda (<var>) <expr> ...) <list>)))))

397
gnucash/report/html-barchart.scm
View File

@ -1,397 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-barchart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2000 Bill Gribble <grib@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.
;;
;; 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@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-barchart))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-barchart>)
(export gnc:html-barchart? )
(export gnc:make-html-barchart-internal)
(export gnc:make-html-barchart)
(export gnc:html-barchart-data)
(export gnc:html-barchart-set-data!)
(export gnc:html-barchart-width)
(export gnc:html-barchart-set-width!)
(export gnc:html-barchart-height)
(export gnc:html-barchart-set-height!)
(export gnc:html-barchart-x-axis-label)
(export gnc:html-barchart-set-x-axis-label!)
(export gnc:html-barchart-y-axis-label)
(export gnc:html-barchart-set-y-axis-label!)
(export gnc:html-barchart-row-labels)
(export gnc:html-barchart-set-row-labels!)
(export gnc:html-barchart-row-labels-rotated?)
(export gnc:html-barchart-set-row-labels-rotated?!)
(export gnc:html-barchart-stacked?)
(export gnc:html-barchart-set-stacked?!)
(export gnc:html-barchart-col-labels)
(export gnc:html-barchart-set-col-labels!)
(export gnc:html-barchart-col-colors)
(export gnc:html-barchart-set-col-colors!)
(export gnc:html-barchart-legend-reversed?)
(export gnc:html-barchart-set-legend-reversed?!)
(export gnc:html-barchart-title)
(export gnc:html-barchart-set-title!)
(export gnc:html-barchart-subtitle)
(export gnc:html-barchart-set-subtitle!)
(export gnc:html-barchart-button-1-bar-urls)
(export gnc:html-barchart-set-button-1-bar-urls!)
(export gnc:html-barchart-button-2-bar-urls)
(export gnc:html-barchart-set-button-2-bar-urls!)
(export gnc:html-barchart-button-3-bar-urls)
(export gnc:html-barchart-set-button-3-bar-urls!)
(export gnc:html-barchart-button-1-legend-urls)
(export gnc:html-barchart-set-button-1-legend-urls!)
(export gnc:html-barchart-button-2-legend-urls)
(export gnc:html-barchart-set-button-2-legend-urls!)
(export gnc:html-barchart-button-3-legend-urls)
(export gnc:html-barchart-set-button-3-legend-urls!)
(export gnc:html-barchart-append-row!)
(export gnc:html-barchart-prepend-row!)
(export gnc:html-barchart-append-column!)
(export gnc:html-barchart-prepend-column!)
(export gnc:html-barchart-render barchart)
(define <html-barchart>
(make-record-type '<html-barchart>
'(width
height
title
subtitle
x-axis-label
y-axis-label
col-labels
row-labels
col-colors
legend-reversed?
row-labels-rotated?
stacked?
data
button-1-bar-urls
button-2-bar-urls
button-3-bar-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-barchart?
(record-predicate <html-barchart>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-barchart> class
;; generate the <object> form for a barchart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-barchart-internal
(record-constructor <html-barchart>))
(define (gnc:make-html-barchart)
(issue-deprecation-warning
"(gnc:make-html-barchart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-barchart-internal '(pixels . -1) '(pixels . -1) #f #f #f #f '() '() '()
#f #f #f '() #f #f #f #f #f #f))
(define gnc:html-barchart-data
(record-accessor <html-barchart> 'data))
(define gnc:html-barchart-set-data!
(record-modifier <html-barchart> 'data))
(define gnc:html-barchart-width
(record-accessor <html-barchart> 'width))
(define gnc:html-barchart-set-width!
(record-modifier <html-barchart> 'width))
(define gnc:html-barchart-height
(record-accessor <html-barchart> 'height))
(define gnc:html-barchart-set-height!
(record-modifier <html-barchart> 'height))
(define gnc:html-barchart-x-axis-label
(record-accessor <html-barchart> 'x-axis-label))
(define gnc:html-barchart-set-x-axis-label!
(record-modifier <html-barchart> 'x-axis-label))
(define gnc:html-barchart-y-axis-label
(record-accessor <html-barchart> 'y-axis-label))
(define gnc:html-barchart-set-y-axis-label!
(record-modifier <html-barchart> 'y-axis-label))
(define gnc:html-barchart-row-labels
(record-accessor <html-barchart> 'row-labels))
(define gnc:html-barchart-set-row-labels!
(record-modifier <html-barchart> 'row-labels))
(define gnc:html-barchart-row-labels-rotated?
(record-accessor <html-barchart> 'row-labels-rotated?))
(define gnc:html-barchart-set-row-labels-rotated?!
(record-modifier <html-barchart> 'row-labels-rotated?))
(define gnc:html-barchart-stacked?
(record-accessor <html-barchart> 'stacked?))
(define gnc:html-barchart-set-stacked?!
(record-modifier <html-barchart> 'stacked?))
(define gnc:html-barchart-col-labels
(record-accessor <html-barchart> 'col-labels))
(define gnc:html-barchart-set-col-labels!
(record-modifier <html-barchart> 'col-labels))
(define gnc:html-barchart-col-colors
(record-accessor <html-barchart> 'col-colors))
(define gnc:html-barchart-set-col-colors!
(record-modifier <html-barchart> 'col-colors))
(define gnc:html-barchart-legend-reversed?
(record-accessor <html-barchart> 'legend-reversed?))
(define gnc:html-barchart-set-legend-reversed?!
(record-modifier <html-barchart> 'legend-reversed?))
(define gnc:html-barchart-title
(record-accessor <html-barchart> 'title))
(define gnc:html-barchart-set-title!
(record-modifier <html-barchart> 'title))
(define gnc:html-barchart-subtitle
(record-accessor <html-barchart> 'subtitle))
(define gnc:html-barchart-set-subtitle!
(record-modifier <html-barchart> 'subtitle))
;; Note: ATM you can specify one url per column, but this url will be
;; used for all of the rows. Otherwise we could have cols*rows urls
;; (quite a lot), but this first requires fixing
;; guppi_bar_1_callback() in gnome/gnc-html-guppi.c .
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-barchart-button-1-bar-urls
(record-accessor <html-barchart> 'button-1-bar-urls))
(define gnc:html-barchart-set-button-1-bar-urls!
(record-modifier <html-barchart> 'button-1-bar-urls))
(define gnc:html-barchart-button-2-bar-urls
(record-accessor <html-barchart> 'button-2-bar-urls))
(define gnc:html-barchart-set-button-2-bar-urls!
(record-modifier <html-barchart> 'button-2-bar-urls))
(define gnc:html-barchart-button-3-bar-urls
(record-accessor <html-barchart> 'button-3-bar-urls))
(define gnc:html-barchart-set-button-3-bar-urls!
(record-modifier <html-barchart> 'button-3-bar-urls))
(define gnc:html-barchart-button-1-legend-urls
(record-accessor <html-barchart> 'button-1-legend-urls))
(define gnc:html-barchart-set-button-1-legend-urls!
(record-modifier <html-barchart> 'button-1-legend-urls))
(define gnc:html-barchart-button-2-legend-urls
(record-accessor <html-barchart> 'button-2-legend-urls))
(define gnc:html-barchart-set-button-2-legend-urls!
(record-modifier <html-barchart> 'button-2-legend-urls))
(define gnc:html-barchart-button-3-legend-urls
(record-accessor <html-barchart> 'button-3-legend-urls))
(define gnc:html-barchart-set-button-3-legend-urls!
(record-modifier <html-barchart> 'button-3-legend-urls))
(define (gnc:html-barchart-append-row! barchart newrow)
(let ((dd (gnc:html-barchart-data barchart)))
(set! dd (append dd (list newrow)))
(gnc:html-barchart-set-data! barchart dd)))
(define (gnc:html-barchart-prepend-row! barchart newrow)
(let ((dd (gnc:html-barchart-data barchart)))
(set! dd (cons newrow dd))
(gnc:html-barchart-set-data! barchart dd)))
(define (gnc:html-barchart-append-column! barchart newcol)
(let ((colnum 0)
(rownum 0)
(rows (gnc:html-barchart-data barchart))
(this-row #f)
(new-row #f))
;; find out how many cols are already there in the deepest row
(for-each
(lambda (row)
(let ((l (length row)))
(if (> l colnum)
(set! colnum l))))
rows)
;; append the elements of 'newrow' to the rowumns
(for-each
(lambda (newelt)
;; find the row, or append one
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
;; make sure the rowumn is long enough, then append the data
(let loop ((l (length this-row))
(r (reverse this-row)))
(if (< l colnum)
(loop (+ l 1) (cons #f r))
(set! this-row
(reverse (cons newelt r)))))
(if new-row
(gnc:html-barchart-append-row! barchart this-row)
(list-set! (gnc:html-barchart-data barchart) rownum this-row))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-barchart-prepend-column! barchart newcol)
(let ((rows (gnc:html-barchart-data barchart))
(this-row #f)
(new-row #f)
(rownum 0))
(for-each
(lambda (elt)
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(if new-row
(gnc:html-barchart-append-row! barchart (list elt))
(list-set! (gnc:html-barchart-data barchart) rownum
(cons elt this-row)))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-barchart-render barchart doc)
(let* ((chart (gnc:make-html-chart))
(data (gnc:html-barchart-data barchart)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'bar)
(gnc:html-chart-set-width! chart (gnc:html-barchart-width barchart))
(gnc:html-chart-set-height! chart (gnc:html-barchart-height barchart))
(gnc:html-chart-set-data-labels! chart (gnc:html-barchart-row-labels barchart))
(for-each
(lambda (label series color)
(gnc:html-chart-add-data-series! chart label series color))
(gnc:html-barchart-col-labels barchart)
data
(gnc:html-barchart-col-colors barchart))
(gnc:html-chart-set-title! chart (list
(gnc:html-barchart-title barchart)
(gnc:html-barchart-subtitle barchart)))
(gnc:html-chart-set-stacking?! chart (gnc:html-barchart-stacked? barchart))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering barchart")
""))))
(gnc:guard-html-chart gnc:html-barchart-data)
(gnc:guard-html-chart gnc:html-barchart-set-data!)
(gnc:guard-html-chart gnc:html-barchart-width)
(gnc:guard-html-chart gnc:html-barchart-set-width!)
(gnc:guard-html-chart gnc:html-barchart-height)
(gnc:guard-html-chart gnc:html-barchart-set-height!)
(gnc:guard-html-chart gnc:html-barchart-x-axis-label)
(gnc:guard-html-chart gnc:html-barchart-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-barchart-y-axis-label)
(gnc:guard-html-chart gnc:html-barchart-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-barchart-row-labels)
(gnc:guard-html-chart gnc:html-barchart-set-row-labels!)
(gnc:guard-html-chart gnc:html-barchart-row-labels-rotated?)
(gnc:guard-html-chart gnc:html-barchart-set-row-labels-rotated?!)
(gnc:guard-html-chart gnc:html-barchart-stacked?)
(gnc:guard-html-chart gnc:html-barchart-set-stacked?!)
(gnc:guard-html-chart gnc:html-barchart-col-labels)
(gnc:guard-html-chart gnc:html-barchart-set-col-labels!)
(gnc:guard-html-chart gnc:html-barchart-col-colors)
(gnc:guard-html-chart gnc:html-barchart-set-col-colors!)
(gnc:guard-html-chart gnc:html-barchart-legend-reversed?)
(gnc:guard-html-chart gnc:html-barchart-set-legend-reversed?!)
(gnc:guard-html-chart gnc:html-barchart-title)
(gnc:guard-html-chart gnc:html-barchart-set-title!)
(gnc:guard-html-chart gnc:html-barchart-subtitle)
(gnc:guard-html-chart gnc:html-barchart-set-subtitle!)
(gnc:guard-html-chart gnc:html-barchart-button-1-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-1-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-2-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-2-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-3-bar-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-3-bar-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-barchart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-barchart-append-row!)
(gnc:guard-html-chart gnc:html-barchart-prepend-row!)
(gnc:guard-html-chart gnc:html-barchart-append-column!)
(gnc:guard-html-chart gnc:html-barchart-prepend-column!)
(gnc:guard-html-chart gnc:html-barchart-render)

16
gnucash/report/html-document.scm
View File

@ -25,11 +25,7 @@
(use-modules (gnucash html))
(use-modules (gnucash report html-anytag))
(use-modules (gnucash report html-barchart))
(use-modules (gnucash report html-chart))
(use-modules (gnucash report html-linechart))
(use-modules (gnucash report html-piechart))
(use-modules (gnucash report html-scatter))
(use-modules (gnucash report html-style-info))
(use-modules (gnucash report html-style-sheet))
(use-modules (gnucash report html-table))
@ -368,18 +364,6 @@
((gnc:html-table-cell? obj)
(gnc:make-html-object-internal gnc:html-table-cell-render obj))
((gnc:html-barchart? obj)
(gnc:make-html-object-internal gnc:html-barchart-render obj))
((gnc:html-piechart? obj)
(gnc:make-html-object-internal gnc:html-piechart-render obj))
((gnc:html-scatter? obj)
(gnc:make-html-object-internal gnc:html-scatter-render obj))
((gnc:html-linechart? obj)
(gnc:make-html-object-internal gnc:html-linechart-render obj))
((gnc:html-object? obj)
obj)

475
gnucash/report/html-linechart.scm
View File

@ -1,475 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-linechart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2008 Sven Henkel <shenkel@gmail.com>
;;
;; Adapted from html-barchart.scm which is
;; Copyright 2000 Bill Gribble <grib@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.
;;
;; 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@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-linechart))
(use-modules (srfi srfi-1))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-linechart>)
(export gnc:html-linechart? )
(export gnc:make-html-linechart-internal)
(export gnc:make-html-linechart)
(export gnc:html-linechart-data)
(export gnc:html-linechart-set-data!)
(export gnc:html-linechart-width)
(export gnc:html-linechart-set-width!)
(export gnc:html-linechart-height)
(export gnc:html-linechart-set-height!)
(export gnc:html-linechart-x-axis-label)
(export gnc:html-linechart-set-x-axis-label!)
(export gnc:html-linechart-y-axis-label)
(export gnc:html-linechart-set-y-axis-label!)
(export gnc:html-linechart-row-labels)
(export gnc:html-linechart-set-row-labels!)
(export gnc:html-linechart-row-labels-rotated?)
(export gnc:html-linechart-set-row-labels-rotated?!)
(export gnc:html-linechart-stacked?)
(export gnc:html-linechart-set-stacked?!)
(export gnc:html-linechart-markers?)
(export gnc:html-linechart-set-markers?!)
(export gnc:html-linechart-major-grid?)
(export gnc:html-linechart-set-major-grid?!)
(export gnc:html-linechart-minor-grid?)
(export gnc:html-linechart-set-minor-grid?!)
(export gnc:html-linechart-col-labels)
(export gnc:html-linechart-set-col-labels!)
(export gnc:html-linechart-col-colors)
(export gnc:html-linechart-set-col-colors!)
(export gnc:html-linechart-legend-reversed?)
(export gnc:html-linechart-set-legend-reversed?!)
(export gnc:html-linechart-title)
(export gnc:html-linechart-set-title!)
(export gnc:html-linechart-subtitle)
(export gnc:html-linechart-set-subtitle!)
(export gnc:html-linechart-button-1-line-urls)
(export gnc:html-linechart-set-button-1-line-urls!)
(export gnc:html-linechart-button-2-line-urls)
(export gnc:html-linechart-set-button-2-line-urls!)
(export gnc:html-linechart-button-3-line-urls)
(export gnc:html-linechart-set-button-3-line-urls!)
(export gnc:html-linechart-button-1-legend-urls)
(export gnc:html-linechart-set-button-1-legend-urls!)
(export gnc:html-linechart-button-2-legend-urls)
(export gnc:html-linechart-set-button-2-legend-urls!)
(export gnc:html-linechart-button-3-legend-urls)
(export gnc:html-linechart-set-button-3-legend-urls!)
(export gnc:html-linechart-append-row!)
(export gnc:html-linechart-prepend-row!)
(export gnc:html-linechart-append-column!)
(export gnc:html-linechart-prepend-column!)
(export gnc:html-linechart-render linechart)
(export gnc:html-linechart-set-line-width!)
(export gnc:html-linechart-line-width)
(define <html-linechart>
(make-record-type '<html-linechart>
'(width
height
title
subtitle
x-axis-label
y-axis-label
col-labels
row-labels
col-colors
legend-reversed?
row-labels-rotated?
stacked?
markers?
major-grid?
minor-grid?
data
button-1-line-urls
button-2-line-urls
button-3-line-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls
line-width)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-linechart?
(record-predicate <html-linechart>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-linechart> class
;; generate the <object> form for a linechart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-linechart-internal
(record-constructor <html-linechart>))
(define (gnc:make-html-linechart)
(issue-deprecation-warning
"(gnc:make-html-linechart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-linechart-internal
'(pixels . -1) ;;width
'(pixels . -1) ;;height
#f ;;title
#f ;;subtitle
#f ;;x-axis-label
#f ;;y-axis-label
'() ;;col-labels
'() ;;row-labels
'() ;;col-colors
#f ;;legend-reversed?
#f ;;row-labels-rotated?
#f ;;stacked?
#t ;;markers?
#t ;;major-grid?
#t ;;minor-grid?
'() ;;data
#f ;;button-1-line-urls
#f ;;button-2-line-urls
#f ;;button-3-line-urls
#f ;;button-1-legend-urls
#f ;;button-2-legend-urls
#f ;;button-3-legend-urls
1.5 ;;line-width
)
)
(define gnc:html-linechart-data
(record-accessor <html-linechart> 'data))
(define gnc:html-linechart-set-data!
(record-modifier <html-linechart> 'data))
(define gnc:html-linechart-width
(record-accessor <html-linechart> 'width))
(define gnc:html-linechart-set-width!
(record-modifier <html-linechart> 'width))
(define gnc:html-linechart-height
(record-accessor <html-linechart> 'height))
(define gnc:html-linechart-set-height!
(record-modifier <html-linechart> 'height))
(define gnc:html-linechart-x-axis-label
(record-accessor <html-linechart> 'x-axis-label))
(define gnc:html-linechart-set-x-axis-label!
(record-modifier <html-linechart> 'x-axis-label))
(define gnc:html-linechart-y-axis-label
(record-accessor <html-linechart> 'y-axis-label))
(define gnc:html-linechart-set-y-axis-label!
(record-modifier <html-linechart> 'y-axis-label))
(define gnc:html-linechart-row-labels
(record-accessor <html-linechart> 'row-labels))
(define gnc:html-linechart-set-row-labels!
(record-modifier <html-linechart> 'row-labels))
(define gnc:html-linechart-row-labels-rotated?
(record-accessor <html-linechart> 'row-labels-rotated?))
(define gnc:html-linechart-set-row-labels-rotated?!
(record-modifier <html-linechart> 'row-labels-rotated?))
(define gnc:html-linechart-stacked?
(record-accessor <html-linechart> 'stacked?))
(define gnc:html-linechart-set-stacked?!
(record-modifier <html-linechart> 'stacked?))
(define gnc:html-linechart-markers?
(record-accessor <html-linechart> 'markers?))
(define gnc:html-linechart-set-markers?!
(record-modifier <html-linechart> 'markers?))
(define gnc:html-linechart-major-grid?
(record-accessor <html-linechart> 'major-grid?))
(define gnc:html-linechart-set-major-grid?!
(record-modifier <html-linechart> 'major-grid?))
(define gnc:html-linechart-minor-grid?
(record-accessor <html-linechart> 'minor-grid?))
(define gnc:html-linechart-set-minor-grid?!
(record-modifier <html-linechart> 'minor-grid?))
(define gnc:html-linechart-col-labels
(record-accessor <html-linechart> 'col-labels))
(define gnc:html-linechart-set-col-labels!
(record-modifier <html-linechart> 'col-labels))
(define gnc:html-linechart-col-colors
(record-accessor <html-linechart> 'col-colors))
(define gnc:html-linechart-set-col-colors!
(record-modifier <html-linechart> 'col-colors))
(define gnc:html-linechart-legend-reversed?
(record-accessor <html-linechart> 'legend-reversed?))
(define gnc:html-linechart-set-legend-reversed?!
(record-modifier <html-linechart> 'legend-reversed?))
(define gnc:html-linechart-title
(record-accessor <html-linechart> 'title))
(define gnc:html-linechart-set-title!
(record-modifier <html-linechart> 'title))
(define gnc:html-linechart-subtitle
(record-accessor <html-linechart> 'subtitle))
(define gnc:html-linechart-set-subtitle!
(record-modifier <html-linechart> 'subtitle))
;; Note: ATM you can specify one url per column, but this url will be
;; used for all of the rows. Otherwise we could have cols*rows urls
;; (quite a lot), but this first requires fixing
;; guppi_line_1_callback() in gnome/gnc-html-guppi.c .
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-linechart-button-1-line-urls
(record-accessor <html-linechart> 'button-1-line-urls))
(define gnc:html-linechart-set-button-1-line-urls!
(record-modifier <html-linechart> 'button-1-line-urls))
(define gnc:html-linechart-button-2-line-urls
(record-accessor <html-linechart> 'button-2-line-urls))
(define gnc:html-linechart-set-button-2-line-urls!
(record-modifier <html-linechart> 'button-2-line-urls))
(define gnc:html-linechart-button-3-line-urls
(record-accessor <html-linechart> 'button-3-line-urls))
(define gnc:html-linechart-set-button-3-line-urls!
(record-modifier <html-linechart> 'button-3-line-urls))
(define gnc:html-linechart-button-1-legend-urls
(record-accessor <html-linechart> 'button-1-legend-urls))
(define gnc:html-linechart-set-button-1-legend-urls!
(record-modifier <html-linechart> 'button-1-legend-urls))
(define gnc:html-linechart-button-2-legend-urls
(record-accessor <html-linechart> 'button-2-legend-urls))
(define gnc:html-linechart-set-button-2-legend-urls!
(record-modifier <html-linechart> 'button-2-legend-urls))
(define gnc:html-linechart-button-3-legend-urls
(record-accessor <html-linechart> 'button-3-legend-urls))
(define gnc:html-linechart-set-button-3-legend-urls!
(record-modifier <html-linechart> 'button-3-legend-urls))
(define gnc:html-linechart-line-width
(record-accessor <html-linechart> 'line-width))
(define gnc:html-linechart-set-line-width!
(record-modifier <html-linechart> 'line-width))
(define (gnc:html-linechart-append-row! linechart newrow)
(let ((dd (gnc:html-linechart-data linechart)))
(set! dd (append dd (list newrow)))
(gnc:html-linechart-set-data! linechart dd)))
(define (gnc:html-linechart-prepend-row! linechart newrow)
(let ((dd (gnc:html-linechart-data linechart)))
(set! dd (cons newrow dd))
(gnc:html-linechart-set-data! linechart dd)))
(define (gnc:html-linechart-append-column! linechart newcol)
(let ((colnum 0)
(rownum 0)
(rows (gnc:html-linechart-data linechart))
(this-row #f)
(new-row #f))
;; find out how many cols are already there in the deepest row
(for-each
(lambda (row)
(let ((l (length row)))
(if (> l colnum)
(set! colnum l))))
rows)
;; append the elements of 'newrow' to the rowumns
(for-each
(lambda (newelt)
;; find the row, or append one
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
;; make sure the rowumn is long enough, then append the data
(let loop ((l (length this-row))
(r (reverse this-row)))
(if (< l colnum)
(loop (+ l 1) (cons #f r))
(set! this-row
(reverse (cons newelt r)))))
(if new-row
(gnc:html-linechart-append-row! linechart this-row)
(list-set! (gnc:html-linechart-data linechart) rownum this-row))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-linechart-prepend-column! linechart newcol)
(let ((rows (gnc:html-linechart-data linechart))
(this-row #f)
(new-row #f)
(rownum 0))
(for-each
(lambda (elt)
(if (not (null? rows))
(begin
(set! new-row #f)
(set! this-row (car rows))
(if (null? (cdr rows))
(set! rows #f)
(set! rows (cdr rows))))
(begin
(set! new-row #t)
(set! this-row '())))
(if new-row
(gnc:html-linechart-append-row! linechart (list elt))
(list-set! (gnc:html-linechart-data linechart) rownum
(cons elt this-row)))
(set! rownum (+ 1 rownum)))
newcol)))
(define (gnc:html-linechart-render linechart doc)
(let* ((chart (gnc:make-html-chart))
(data (gnc:html-linechart-data linechart))
(line-width (gnc:html-linechart-line-width linechart))
(radius (if (gnc:html-linechart-markers? linechart) 3 0)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'line)
(gnc:html-chart-set-width! chart (gnc:html-linechart-width linechart))
(gnc:html-chart-set-height! chart (gnc:html-linechart-height linechart))
(gnc:html-chart-set-data-labels! chart (gnc:html-linechart-row-labels linechart))
(for-each
(lambda (label series color)
(gnc:html-chart-add-data-series! chart label series color
'borderWidth line-width
'pointRadius radius
'fill #f))
(gnc:html-linechart-col-labels linechart)
(apply zip data)
(gnc:html-linechart-col-colors linechart))
(gnc:html-chart-set-title! chart (list
(gnc:html-linechart-title linechart)
(gnc:html-linechart-subtitle linechart)))
(gnc:html-chart-set-stacking?! chart (gnc:html-linechart-stacked? linechart))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering linechart")
""))))
(gnc:guard-html-chart gnc:html-linechart-data)
(gnc:guard-html-chart gnc:html-linechart-set-data!)
(gnc:guard-html-chart gnc:html-linechart-width)
(gnc:guard-html-chart gnc:html-linechart-set-width!)
(gnc:guard-html-chart gnc:html-linechart-height)
(gnc:guard-html-chart gnc:html-linechart-set-height!)
(gnc:guard-html-chart gnc:html-linechart-x-axis-label)
(gnc:guard-html-chart gnc:html-linechart-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-linechart-y-axis-label)
(gnc:guard-html-chart gnc:html-linechart-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-linechart-row-labels)
(gnc:guard-html-chart gnc:html-linechart-set-row-labels!)
(gnc:guard-html-chart gnc:html-linechart-row-labels-rotated?)
(gnc:guard-html-chart gnc:html-linechart-set-row-labels-rotated?!)
(gnc:guard-html-chart gnc:html-linechart-stacked?)
(gnc:guard-html-chart gnc:html-linechart-set-stacked?!)
(gnc:guard-html-chart gnc:html-linechart-markers?)
(gnc:guard-html-chart gnc:html-linechart-set-markers?!)
(gnc:guard-html-chart gnc:html-linechart-major-grid?)
(gnc:guard-html-chart gnc:html-linechart-set-major-grid?!)
(gnc:guard-html-chart gnc:html-linechart-minor-grid?)
(gnc:guard-html-chart gnc:html-linechart-set-minor-grid?!)
(gnc:guard-html-chart gnc:html-linechart-col-labels)
(gnc:guard-html-chart gnc:html-linechart-set-col-labels!)
(gnc:guard-html-chart gnc:html-linechart-col-colors)
(gnc:guard-html-chart gnc:html-linechart-set-col-colors!)
(gnc:guard-html-chart gnc:html-linechart-legend-reversed?)
(gnc:guard-html-chart gnc:html-linechart-set-legend-reversed?!)
(gnc:guard-html-chart gnc:html-linechart-title)
(gnc:guard-html-chart gnc:html-linechart-set-title!)
(gnc:guard-html-chart gnc:html-linechart-subtitle)
(gnc:guard-html-chart gnc:html-linechart-set-subtitle!)
(gnc:guard-html-chart gnc:html-linechart-button-1-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-1-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-2-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-2-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-3-line-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-3-line-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-linechart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-linechart-append-row!)
(gnc:guard-html-chart gnc:html-linechart-prepend-row!)
(gnc:guard-html-chart gnc:html-linechart-append-column!)
(gnc:guard-html-chart gnc:html-linechart-prepend-column!)
(gnc:guard-html-chart gnc:html-linechart-render)
(gnc:guard-html-chart gnc:html-linechart-set-line-width!)
(gnc:guard-html-chart gnc:html-linechart-line-width)

239
gnucash/report/html-piechart.scm
View File

@ -1,239 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-piechart.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2000 Bill Gribble <grib@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.
;;
;; 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@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-piechart))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-piechart>)
(export gnc:html-piechart?)
(export gnc:make-html-piechart-internal)
(export gnc:make-html-piechart)
(export gnc:html-piechart-data)
(export gnc:html-piechart-set-data!)
(export gnc:html-piechart-width)
(export gnc:html-piechart-set-width!)
(export gnc:html-piechart-height)
(export gnc:html-piechart-set-height!)
(export gnc:html-piechart-labels)
(export gnc:html-piechart-set-labels!)
(export gnc:html-piechart-colors)
(export gnc:html-piechart-set-colors!)
(export gnc:html-piechart-title)
(export gnc:html-piechart-set-title!)
(export gnc:html-piechart-subtitle)
(export gnc:html-piechart-set-subtitle!)
(export gnc:html-piechart-button-1-slice-urls)
(export gnc:html-piechart-set-button-1-slice-urls!)
(export gnc:html-piechart-button-2-slice-urls)
(export gnc:html-piechart-set-button-2-slice-urls!)
(export gnc:html-piechart-button-3-slice-urls)
(export gnc:html-piechart-set-button-3-slice-urls!)
(export gnc:html-piechart-button-1-legend-urls)
(export gnc:html-piechart-set-button-1-legend-urls!)
(export gnc:html-piechart-button-2-legend-urls)
(export gnc:html-piechart-set-button-2-legend-urls!)
(export gnc:html-piechart-button-3-legend-urls)
(export gnc:html-piechart-set-button-3-legend-urls!)
(export gnc:html-piechart-render)
(define <html-piechart>
(make-record-type '<html-piechart>
'(width
height
title
subtitle
data
colors
labels
button-1-slice-urls
button-2-slice-urls
button-3-slice-urls
button-1-legend-urls
button-2-legend-urls
button-3-legend-urls)))
(define gnc:html-piechart?
(record-predicate <html-piechart>))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-piechart> class
;; generate the <object> form for a piechart.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-piechart-internal
(record-constructor <html-piechart>))
(define (gnc:make-html-piechart)
(issue-deprecation-warning
"(gnc:make-html-piechart) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-piechart-internal '(pixels . -1) '(pixels . -1) #f #f #f #f #f #f #f #f #f #f #f))
(define gnc:html-piechart-data
(record-accessor <html-piechart> 'data))
(define gnc:html-piechart-set-data!
(record-modifier <html-piechart> 'data))
(define gnc:html-piechart-width
(record-accessor <html-piechart> 'width))
(define gnc:html-piechart-set-width!
(record-modifier <html-piechart> 'width))
(define gnc:html-piechart-height
(record-accessor <html-piechart> 'height))
(define gnc:html-piechart-set-height!
(record-modifier <html-piechart> 'height))
(define gnc:html-piechart-labels
(record-accessor <html-piechart> 'labels))
(define gnc:html-piechart-set-labels!
(record-modifier <html-piechart> 'labels))
(define gnc:html-piechart-colors
(record-accessor <html-piechart> 'colors))
(define gnc:html-piechart-set-colors!
(record-modifier <html-piechart> 'colors))
(define gnc:html-piechart-title
(record-accessor <html-piechart> 'title))
(define gnc:html-piechart-set-title!
(record-modifier <html-piechart> 'title))
(define gnc:html-piechart-subtitle
(record-accessor <html-piechart> 'subtitle))
(define gnc:html-piechart-set-subtitle!
(record-modifier <html-piechart> 'subtitle))
;; FIXME url's haven't been working since GnuCash 1.x
;; GnuCash 2.x switched from guppy to goffice, which
;; made it very hard to remain the url functionality
;; At this point I (gjanssens) is in the process of
;; moving from goffice to jqplot for our charts
;; which perhaps may allow urls again in the charts
;; I'm keeping the parameters below around to remind
;; us this still has to be investigated again
(define gnc:html-piechart-button-1-slice-urls
(record-accessor <html-piechart> 'button-1-slice-urls))
(define gnc:html-piechart-set-button-1-slice-urls!
(record-modifier <html-piechart> 'button-1-slice-urls))
(define gnc:html-piechart-button-2-slice-urls
(record-accessor <html-piechart> 'button-2-slice-urls))
(define gnc:html-piechart-set-button-2-slice-urls!
(record-modifier <html-piechart> 'button-2-slice-urls))
(define gnc:html-piechart-button-3-slice-urls
(record-accessor <html-piechart> 'button-3-slice-urls))
(define gnc:html-piechart-set-button-3-slice-urls!
(record-modifier <html-piechart> 'button-3-slice-urls))
(define gnc:html-piechart-button-1-legend-urls
(record-accessor <html-piechart> 'button-1-legend-urls))
(define gnc:html-piechart-set-button-1-legend-urls!
(record-modifier <html-piechart> 'button-1-legend-urls))
(define gnc:html-piechart-button-2-legend-urls
(record-accessor <html-piechart> 'button-2-legend-urls))
(define gnc:html-piechart-set-button-2-legend-urls!
(record-modifier <html-piechart> 'button-2-legend-urls))
(define gnc:html-piechart-button-3-legend-urls
(record-accessor <html-piechart> 'button-3-legend-urls))
(define gnc:html-piechart-set-button-3-legend-urls!
(record-modifier <html-piechart> 'button-3-legend-urls))
(define (gnc:html-piechart-render piechart doc)
(let* ((chart (gnc:make-html-chart))
(title (gnc:html-piechart-title piechart))
(subtitle (gnc:html-piechart-subtitle piechart))
(data (gnc:html-piechart-data piechart))
(colors (gnc:html-piechart-colors piechart)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'pie)
(gnc:html-chart-set-axes-display! chart #f)
(gnc:html-chart-set-width! chart (gnc:html-piechart-width piechart))
(gnc:html-chart-set-height! chart (gnc:html-piechart-height piechart))
(gnc:html-chart-set-data-labels! chart (gnc:html-piechart-labels piechart))
(gnc:html-chart-add-data-series! chart "" data colors)
(gnc:html-chart-set-title! chart (list title subtitle))
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering piechart")
""))))
(gnc:guard-html-chart gnc:html-piechart-data)
(gnc:guard-html-chart gnc:html-piechart-set-data!)
(gnc:guard-html-chart gnc:html-piechart-width)
(gnc:guard-html-chart gnc:html-piechart-set-width!)
(gnc:guard-html-chart gnc:html-piechart-height)
(gnc:guard-html-chart gnc:html-piechart-set-height!)
(gnc:guard-html-chart gnc:html-piechart-labels)
(gnc:guard-html-chart gnc:html-piechart-set-labels!)
(gnc:guard-html-chart gnc:html-piechart-colors)
(gnc:guard-html-chart gnc:html-piechart-set-colors!)
(gnc:guard-html-chart gnc:html-piechart-title)
(gnc:guard-html-chart gnc:html-piechart-set-title!)
(gnc:guard-html-chart gnc:html-piechart-subtitle)
(gnc:guard-html-chart gnc:html-piechart-set-subtitle!)
(gnc:guard-html-chart gnc:html-piechart-button-1-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-1-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-2-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-2-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-3-slice-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-3-slice-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-1-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-1-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-2-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-2-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-button-3-legend-urls)
(gnc:guard-html-chart gnc:html-piechart-set-button-3-legend-urls!)
(gnc:guard-html-chart gnc:html-piechart-render)

227
gnucash/report/html-scatter.scm
View File

@ -1,227 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; html-scatter.scm : generate HTML programmatically, with support
;; for simple style elements.
;; Copyright 2001 Christian Stimming <stimming@tuhh.de>
;;
;; Adapted from html-barchart.scm which is
;; Copyright 2000 Bill Gribble <grib@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.
;;
;; 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@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash report html-scatter))
(use-modules (gnucash utilities))
(use-modules (gnucash report html-chart)
(gnucash report report-utilities))
(export <html-scatter>)
(export gnc:html-scatter-add-datapoint!)
(export gnc:html-scatter-data)
(export gnc:html-scatter-height)
(export gnc:html-scatter-marker)
(export gnc:html-scatter-markercolor)
(export gnc:html-scatter-render)
(export gnc:html-scatter-set-data!)
(export gnc:html-scatter-set-height!)
(export gnc:html-scatter-set-marker!)
(export gnc:html-scatter-set-markercolor!)
(export gnc:html-scatter-set-subtitle!)
(export gnc:html-scatter-set-title!)
(export gnc:html-scatter-set-width!)
(export gnc:html-scatter-set-x-axis-label!)
(export gnc:html-scatter-set-y-axis-label!)
(export gnc:html-scatter-subtitle)
(export gnc:html-scatter-title)
(export gnc:html-scatter-width)
(export gnc:html-scatter-x-axis-label)
(export gnc:html-scatter-y-axis-label)
(export gnc:html-scatter?)
(export gnc:make-html-scatter)
(export gnc:make-html-scatter-internal)
(define <html-scatter>
(make-record-type '<html-scatter>
'(width
height
title
subtitle
x-axis-label
y-axis-label
;; a list of x-y-value lists.
data
;; Valid marker names are:
;; diamond, circle, square, x, plus, dash,
;; filledDiamond, filledCircle, filledSquare
marker
;; The color of the markers outline. Should be a hex string,
;; as returned by gnc:color-option->hex-string, prefixed by
;; #, like "#ff0000" for red
markercolor
)))
(define-syntax-rule (gnc:guard-html-chart api)
;; this macro applied to old html-bar/line/scatter/pie apis will
;; guard a report writer from passing html-chart objects. this
;; should be removed in 5.x series.
(let ((old-api api))
(set! api
(lambda args
(if (and (pair? args) (gnc:html-chart? (car args)))
(gnc:warn "using old-api " (procedure-name api) " on html-chart object. set options via gnc:html-chart-set! or its shortcuts gnc:html-chart-set-title! etc, and set data via gnc:html-chart-add-data-series! see sample-graphs.scm for examples.")
(apply old-api args))))))
(define gnc:html-scatter?
(record-predicate <html-scatter>))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; <html-scatter> class
;; generate the <object> form for a scatter plot.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define gnc:make-html-scatter-internal
(record-constructor <html-scatter>))
(define (gnc:make-html-scatter)
(issue-deprecation-warning
"(gnc:make-html-scatter) is deprecated in 4.x. use gnc:make-html-chart instead.")
(gnc:make-html-scatter-internal '(pixels . -1) '(pixels . -1) #f #f #f #f '() #f #f))
(define gnc:html-scatter-width
(record-accessor <html-scatter> 'width))
(define gnc:html-scatter-set-width!
(record-modifier <html-scatter> 'width))
(define gnc:html-scatter-height
(record-accessor <html-scatter> 'height))
(define gnc:html-scatter-set-height!
(record-modifier <html-scatter> 'height))
(define gnc:html-scatter-title
(record-accessor <html-scatter> 'title))
(define gnc:html-scatter-set-title!
(record-modifier <html-scatter> 'title))
(define gnc:html-scatter-subtitle
(record-accessor <html-scatter> 'subtitle))
(define gnc:html-scatter-set-subtitle!
(record-modifier <html-scatter> 'subtitle))
(define gnc:html-scatter-x-axis-label
(record-accessor <html-scatter> 'x-axis-label))
(define gnc:html-scatter-set-x-axis-label!
(record-modifier <html-scatter> 'x-axis-label))
(define gnc:html-scatter-y-axis-label
(record-accessor <html-scatter> 'y-axis-label))
(define gnc:html-scatter-set-y-axis-label!
(record-modifier <html-scatter> 'y-axis-label))
(define gnc:html-scatter-data
(record-accessor <html-scatter> 'data))
(define gnc:html-scatter-set-data!
(record-modifier <html-scatter> 'data))
(define gnc:html-scatter-marker
(record-accessor <html-scatter> 'marker))
(define gnc:html-scatter-set-marker!
(record-modifier <html-scatter> 'marker))
(define gnc:html-scatter-markercolor
(record-accessor <html-scatter> 'markercolor))
(define gnc:html-scatter-set-markercolor!
(record-modifier <html-scatter> 'markercolor))
(define (gnc:html-scatter-add-datapoint! scatter newpoint)
(if (and (list? newpoint)
(not (null? newpoint)))
(gnc:html-scatter-set-data!
scatter
(cons newpoint (gnc:html-scatter-data scatter)))))
;; The Renderer
(define (gnc:html-scatter-render scatter doc)
(let* ((chart (gnc:make-html-chart))
(mcolor (gnc:html-scatter-markercolor scatter))
(data (gnc:html-scatter-data scatter)))
(cond
((and (pair? data) (gnc:not-all-zeros data))
(gnc:html-chart-set-type! chart 'scatter)
(gnc:html-chart-set-width! chart (gnc:html-scatter-width scatter))
(gnc:html-chart-set-height! chart (gnc:html-scatter-height scatter))
(gnc:html-chart-set-data-labels! chart (make-list (length data) #f))
(gnc:html-chart-add-data-series! chart "scatter"
(map
(lambda (datum)
(list
(cons 'x (car datum))
(cons 'y (cadr datum))))
data)
(make-list (length data) mcolor)
'showLine #t
'fill #f
'borderColor mcolor)
(gnc:html-chart-set-title! chart (list
(gnc:html-scatter-title scatter)
(gnc:html-scatter-subtitle scatter)))
(gnc:html-chart-set! chart
'(options elements point pointStyle)
(case (gnc:html-scatter-marker scatter)
((filleddiamond diamond) "rectRot")
((filledcircle circle) "circle")
((filledsquare square) "rect")
((cross) "crossRot")
((plus) "cross")
((dash) "line")
(else #f)))
(gnc:html-chart-set! chart '(options scales xAxes (0) type) "linear")
(gnc:html-chart-render chart doc))
(else
(gnc:warn "null-data, not rendering scatter")
""))))
(gnc:guard-html-chart gnc:html-scatter-width)
(gnc:guard-html-chart gnc:html-scatter-set-width!)
(gnc:guard-html-chart gnc:html-scatter-height)
(gnc:guard-html-chart gnc:html-scatter-set-height!)
(gnc:guard-html-chart gnc:html-scatter-title)
(gnc:guard-html-chart gnc:html-scatter-set-title!)
(gnc:guard-html-chart gnc:html-scatter-subtitle)
(gnc:guard-html-chart gnc:html-scatter-set-subtitle!)
(gnc:guard-html-chart gnc:html-scatter-x-axis-label)
(gnc:guard-html-chart gnc:html-scatter-set-x-axis-label!)
(gnc:guard-html-chart gnc:html-scatter-y-axis-label)
(gnc:guard-html-chart gnc:html-scatter-set-y-axis-label!)
(gnc:guard-html-chart gnc:html-scatter-data)
(gnc:guard-html-chart gnc:html-scatter-set-data!)
(gnc:guard-html-chart gnc:html-scatter-marker)
(gnc:guard-html-chart gnc:html-scatter-set-marker!)
(gnc:guard-html-chart gnc:html-scatter-markercolor)
(gnc:guard-html-chart gnc:html-scatter-set-markercolor!)
(gnc:guard-html-chart gnc:html-scatter-add-datapoint!)
(gnc:guard-html-chart gnc:html-scatter-render)

25
gnucash/report/html-table.scm
View File

@ -97,7 +97,6 @@
(export gnc:html-table-get-cell)
(export gnc:html-table-set-cell!)
(export gnc:html-table-set-cell/tag!)
(export gnc:html-table-append-column!)
(export gnc:html-table-render)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -412,30 +411,6 @@
(gnc:html-table-cell-set-tag! tc tag)
(gnc:html-table-set-cell-datum! table row col tc)))
(define (gnc:html-table-append-column! table newcol)
(define width (apply max (cons 0 (map length (gnc:html-table-data table)))))
(define (add-fn a b) (list-set-safe! b width a))
(issue-deprecation-warning "gnc:html-table-append-column! deprecated. please \
populate html-table row-wise using gnc:html-table-append-row! instead.")
(let lp ((newcol newcol)
(olddata (reverse (gnc:html-table-data table)))
(res '())
(numrows 0))
(cond
((null? newcol)
(gnc:html-table-set-num-rows-internal! table numrows)
(gnc:html-table-set-data! table res))
((null? olddata)
(lp (cdr newcol)
'()
(cons (add-fn (car newcol) '()) res)
(1+ numrows)))
(else
(lp (cdr newcol)
(cdr olddata)
(cons (add-fn (car newcol) (car olddata)) res)
(1+ numrows))))))
(define (gnc:html-table-render table doc)
(let* ((retval '())
(push (lambda (l) (set! retval (cons l retval)))))

27
gnucash/report/html-utilities.scm
View File

@ -247,33 +247,6 @@
table (list (gnc:make-html-table-cell/size
1 colspan (gnc:make-html-text (gnc:html-markup-hr))))))
;; Create a html-table of all exchange rates. The report-commodity is
;; 'common-commodity', the exchange rates are given through the
;; function 'exchange-fn' and the 'accounts' determine which
;; commodities to show. Returns a html-object, a <html-table>.
(define (gnc:html-make-exchangerates common-commodity exchange-fn accounts)
(issue-deprecation-warning
"gnc:html-make-exchangerates is deprecated. use gnc:html-make-rates-table instead.")
(let* ((comm-list (gnc:accounts-get-commodities accounts common-commodity))
(entries (length comm-list))
(markup (lambda (c) (gnc:make-html-table-cell/markup "number-cell" c)))
(table (gnc:make-html-table)))
(unless (= 0 entries)
(for-each
(lambda (commodity)
(let* ((orig-amt (gnc:make-gnc-monetary commodity 1))
(exchanged (exchange-fn orig-amt common-commodity))
(conv-amount (gnc:gnc-monetary-amount exchanged)))
(gnc:html-table-append-row!
table (list (markup orig-amt)
(markup (gnc:default-price-renderer common-commodity
conv-amount))))))
comm-list)
(gnc:html-table-set-col-headers!
table (list (gnc:make-html-table-header-cell/size
1 2 (NG_ "Exchange rate" "Exchange rates" entries)))))
table))
;; Create a html-table of all prices. The report-currency is
;; 'currency', The prices are given through the function 'price-fn'
;; and the 'accounts' determine which commodities to show. Returns a

30
gnucash/report/report-core.scm
View File

@ -77,7 +77,6 @@
(export gnc:report-options)
(export gnc:report-render-html)
(export gnc:render-report)
(export gnc:report-run)
(export gnc:report-serialize)
(export gnc:report-set-ctext!)
(export gnc:report-set-dirty?!)
@ -112,7 +111,6 @@
(export gnc:report-to-template-new)
(export gnc:report-to-template-update)
(export gnc:report-type)
(export gnc:restore-report-by-guid)
(export gnc:restore-report-by-guid-with-custom-template)
;; Terminology in this file:
@ -383,20 +381,6 @@ not found.")))
(gnc:report-set-id! r (gnc-report-add r))
(gnc:report-id r)))
(define (gnc:restore-report-by-guid id template-id template-name options)
(issue-deprecation-warning "gnc:restore-report-by-guid is now deprecated.
use gnc:restore-report-by-guid-with-custom-template instead.")
(if options
(let* ((r (make-report template-id id options #t #t #f #f ""))
(report-id (gnc-report-add r)))
(if (number? report-id)
(gnc:report-set-id! r report-id))
report-id)
(begin
(gui-error-missing-template template-name)
#f)))
(define (gnc:restore-report-by-guid-with-custom-template
id template-id template-name custom-template-id options)
(if options
@ -761,20 +745,6 @@ not found.")))
(define (get-report) (gnc:report-render-html report #t))
(gnc:apply-with-error-handling get-report '()))
;; looks up the report by id and renders it with gnc:report-render-html
;; marks the cursor busy during rendering; returns the html
(define (gnc:report-run id)
(issue-deprecation-warning "gnc:report-run is deprecated. use gnc:render-report instead.")
(let ((report (gnc-report-find id))
(html #f))
(gnc-set-busy-cursor '() #t)
(gnc:backtrace-if-exception
(lambda ()
(if report (set! html (gnc:report-render-html report #t)))))
(gnc-unset-busy-cursor '())
html))
;; "thunk" should take the report-type and the report template record
(define (gnc:report-templates-for-each thunk)
(hash-for-each

68
gnucash/report/report-utilities.scm
View File

@ -592,39 +592,6 @@
accounts)
collector))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Intended for usage with a profit and loss
;; report, hence a) only the income/expense accounts are regarded, and
;; b) the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-profit accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-profit deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-INCOME ACCT-TYPE-EXPENSE) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Only the income accounts are regarded, and
;; the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-income accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-income deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-INCOME) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Only the expense accounts are regarded, and
;; the result is sign reversed. Returns a commodity-collector.
(define (gnc:accounts-get-comm-total-expense accounts
get-balance-fn)
(issue-deprecation-warning "gnc:accounts-get-comm-total-expense deprecated.")
(gnc:accounts-get-balance-helper
(gnc:filter-accountlist-type (list ACCT-TYPE-EXPENSE) accounts)
get-balance-fn
(lambda(x) #t)))
;; Adds all accounts' balances, where the balances are determined with
;; the get-balance-fn. Intended for usage with a balance sheet, hence
@ -668,41 +635,6 @@
(define (gnc:accountlist-get-comm-balance-at-date-with-closing accountlist date)
(gnc:account-get-trans-type-balance-interval-with-closing accountlist #f #f date))
;; utility function - ensure that a query matches only non-voids. Destructive.
(define (gnc:query-set-match-non-voids-only! query book)
(issue-deprecation-warning
"gnc:query-set-match-non-voids-only! is deprecated. add query for\
(logand CLEARED-ALL (lognot CLEARED-VOIDED)) instead.")
(let ((temp-query (qof-query-create-for-splits)))
(qof-query-set-book temp-query book)
(xaccQueryAddClearedMatch
temp-query
CLEARED-VOIDED
QOF-QUERY-AND)
(let ((inv-query (qof-query-invert temp-query)))
(qof-query-merge-in-place query inv-query QOF-QUERY-AND)
(qof-query-destroy inv-query)
(qof-query-destroy temp-query))))
;; utility function - ensure that a query matches only voids. Destructive
(define (gnc:query-set-match-voids-only! query book)
(issue-deprecation-warning
"gnc:query-set-match-non-voids-only! is deprecated. add CLEARED-VOIDED \
query instead.")
(let ((temp-query (qof-query-create-for-splits)))
(qof-query-set-book temp-query book)
(xaccQueryAddClearedMatch
temp-query
CLEARED-VOIDED
QOF-QUERY-AND)
(qof-query-merge-in-place query temp-query QOF-QUERY-AND)
(qof-query-destroy temp-query)))
(define (gnc:split-voided? split)
(let ((trans (xaccSplitGetParent split)))
(xaccTransGetVoidStatus trans)))

198
gnucash/report/reports/CMakeLists.txt
View File

@ -4,7 +4,6 @@ add_subdirectory(support)
#These provide some functions used by more than one report.
set (reports_common_SCHEME
aging.scm #deprecated 4.x to be removed in 5.x
cash-flow-calc.scm
)
@ -13,10 +12,7 @@ set (reports_common_SCHEME
set (reports_standard_with_exposed_generator_SCHEME
standard/new-aging.scm
standard/register.scm
standard/owner-report.scm #deprecated 4.x to be removed in 5.x
standard/new-owner-report.scm
standard/payables.scm #deprecated 4.x to be removed in 5.x
standard/receivables.scm #deprecated 4.x to be removed in 5.x
)
set (reports_standard_SCHEME
@ -51,7 +47,6 @@ set (reports_standard_SCHEME
standard/taxinvoice.scm
standard/receipt.scm
standard/invoice.scm
standard/job-report.scm
standard/balsheet-eg.scm
)
@ -169,199 +164,6 @@ add_custom_target(scm-reports ALL DEPENDS
scm-reports-us
scm-reports-de_DE)
# Module interfaces deprecated in 4.x, will be removed for 5.x
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports"
NEW_MODULE "gnucash reports"
DEPENDS "scm-rpt-reports")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report aging"
NEW_MODULE "gnucash reports aging"
DEPENDS "scm-reports-common")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports average-balance"
NEW_MODULE "gnucash reports example average-balance"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports daily-reports"
NEW_MODULE "gnucash reports example daily-reports"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report hello-world"
NEW_MODULE "gnucash reports example hello-world"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report test-graphing"
NEW_MODULE "gnucash reports example sample-graphs"
DEPENDS "scm-reports-example")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report locale-specific de_DE"
NEW_MODULE "gnucash reports locale-specific de_DE taxtxf"
DEPENDS "scm-reports-de_DE")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxtxf-de_DE"
NEW_MODULE "gnucash reports locale-specific de_DE taxtxf"
DEPENDS "scm-reports-de_DE")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report locale-specific us"
NEW_MODULE "gnucash reports locale-specific us taxtxf"
DEPENDS "scm-reports-us")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxtxf"
NEW_MODULE "gnucash reports locale-specific us taxtxf"
DEPENDS "scm-reports-us")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports account-piecharts"
NEW_MODULE "gnucash reports standard account-piecharts"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports account-summary"
NEW_MODULE "gnucash reports standard account-summary"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports advanced-portfolio"
NEW_MODULE "gnucash reports standard advanced-portfolio"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balance-forecast"
NEW_MODULE "gnucash reports standard balance-forecast"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balance-sheet"
NEW_MODULE "gnucash reports standard balance-sheet"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report balsheet-eg"
NEW_MODULE "gnucash reports standard balsheet-eg"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports balsheet-pnl"
NEW_MODULE "gnucash reports standard balsheet-pnl"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-balance-sheet"
NEW_MODULE "gnucash reports standard budget-balance-sheet"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-barchart"
NEW_MODULE "gnucash reports standard budget-barchart"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-flow"
NEW_MODULE "gnucash reports standard budget-flow"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget"
NEW_MODULE "gnucash reports standard budget"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports budget-income-statement"
NEW_MODULE "gnucash reports standard budget-income-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports cashflow-barchart"
NEW_MODULE "gnucash reports standard cashflow-barchart"
DEPENDS "scm-reports-standard-2")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports cash-flow"
NEW_MODULE "gnucash reports standard cash-flow"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports category-barchart"
NEW_MODULE "gnucash reports standard category-barchart"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report customer-summary"
NEW_MODULE "gnucash reports standard customer-summary"
DEPENDS "scm-reports-standard-2")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report welcome-to-gnucash"
NEW_MODULE "gnucash reports standard dashboard"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports equity-statement"
NEW_MODULE "gnucash reports standard equity-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports general-journal"
NEW_MODULE "gnucash reports standard general-journal"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports general-ledger"
NEW_MODULE "gnucash reports standard general-ledger"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports income-gst-statement"
NEW_MODULE "gnucash reports standard income-gst-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports income-statement"
NEW_MODULE "gnucash reports standard income-statement"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report invoice"
NEW_MODULE "gnucash reports standard invoice"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report job-report"
NEW_MODULE "gnucash reports standard job-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports net-charts"
NEW_MODULE "gnucash reports standard net-charts"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report owner-report"
NEW_MODULE "gnucash reports standard owner-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report payables"
NEW_MODULE "gnucash reports standard payables"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports portfolio"
NEW_MODULE "gnucash reports standard portfolio"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports price-scatter"
NEW_MODULE "gnucash reports standard price-scatter"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report receipt"
NEW_MODULE "gnucash reports standard receipt"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report receivables"
NEW_MODULE "gnucash reports standard receivables"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports reconcile-report"
NEW_MODULE "gnucash reports standard reconcile-report"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports register"
NEW_MODULE "gnucash reports standard register"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports sx-summary"
NEW_MODULE "gnucash reports standard account-summary"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report taxinvoice"
NEW_MODULE "gnucash reports standard taxinvoice"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports transaction"
NEW_MODULE "gnucash reports standard transaction"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report standard-reports trial-balance"
NEW_MODULE "gnucash reports standard trial-balance"
DEPENDS "scm-reports-standard")
gnc_add_scheme_deprecated_module (
OLD_MODULE "gnucash report view-column"
NEW_MODULE "gnucash reports standard view-column"
DEPENDS "scm-reports-standard")
set_local_dist(reports_DIST_local CMakeLists.txt ${reports_SCHEME}
${reports_common_SCHEME} ${reports_standard_SCHEME} ${reports_standard_SCHEME_2}

847
gnucash/report/reports/aging.scm
View File

@ -1,847 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; aging.scm : accounts payable/receivable aging report utilities
;;
;; By Derek Atkins <warlord@MIT.EDU> taken from the original...
;; By Robert Merkel (rgmerk@mira.net)
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; 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@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports aging))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash gnome-utils))
(use-modules (srfi srfi-9))
(define optname-to-date (N_ "To"))
(define optname-sort-by (N_ "Sort By"))
(define optname-sort-order (N_ "Sort Order"))
(define optname-report-currency (N_ "Report's currency"))
(define optname-price-source (N_ "Price Source"))
(define optname-multicurrency-totals (N_ "Show Multi-currency Totals"))
(define optname-show-zeros (N_ "Show zero balance items"))
(define optname-date-driver (N_ "Due or Post Date"))
;; Display tab options
(define optname-addr-source (N_ "Address Source")) ;; Billing or Shipping addresses
(define optname-disp-addr-name (N_ "Address Name"))
(define optname-disp-addr1 (N_ "Address 1"))
(define optname-disp-addr2 (N_ "Address 2"))
(define optname-disp-addr3 (N_ "Address 3"))
(define optname-disp-addr4 (N_ "Address 4"))
(define optname-disp-addr-phone (N_ "Address Phone"))
(define optname-disp-addr-fax (N_ "Address Fax"))
(define optname-disp-addr-email (N_ "Address Email"))
(define optname-disp-active (N_ "Active"))
(export optname-show-zeros)
;; The idea is: have a hash with the key being the contact name
;; (In future this might be GUID'ed, but for now it's a string
;; from the description or the split memo.
;; The value is a record which contains the currency that contact
;; is stored in (you can only owe a particular contact one
;; currency, it just gets far too difficult otherwise), and a list
;; of buckets containing the money owed for each interval,
;; oldest first.
;; overpayment is just that - it stores the current overpayment,
;; if any. Any bills get taken out of the overpayment before
;; incurring debt.
(define-record-type :company-info
(make-company-private currency bucket overpayment owner-obj)
company-info?
(currency company-get-currency)
(bucket company-get-buckets company-set-buckets)
(overpayment company-get-overpayment company-set-overpayment)
(owner-obj company-get-owner-obj company-set-owner-obj!))
(define num-buckets 5)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-company currency owner-obj)
(make-company-private currency (new-bucket-vector) 0 owner-obj))
;; Put an invoice in the appropriate bucket
(define (process-invoice company amount bucket-intervals date)
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(gnc:debug "looking for bucket for date: " date)
(begin
(gnc:debug "current bucket: " current-bucket)
(gnc:debug "bucket-intervals: " bucket-intervals)
(if (> current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
(begin
(gnc:debug "found bucket")
current-bucket)
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (calculate-adjusted-values amount overpayment)
(if (>= (gnc-numeric-compare amount overpayment) 0)
(cons (gnc-numeric-sub-fixed amount overpayment)
(gnc-numeric-zero))
(cons (gnc-numeric-zero)
(gnc-numeric-sub-fixed overpayment amount))))
(let* ((current-overpayment (company-get-overpayment company))
(adjusted-values (calculate-adjusted-values amount current-overpayment))
(adjusted-amount (car adjusted-values))
(adjusted-overpayment (cdr adjusted-values))
(bucket-index (find-bucket 0 bucket-intervals date))
(buckets (company-get-buckets company))
(new-bucket-value
(gnc-numeric-add-fixed adjusted-amount (vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-bucket-value)
(company-set-buckets company buckets)
(company-set-overpayment company adjusted-overpayment)))
;; NOTE: We assume that bill payments occur in a FIFO manner - ie
;; any payment to a company goes towards the *oldest* bill first
(define (process-payment company amount)
(define (process-payment-driver amount buckets current-bucket-index)
(if (>= current-bucket-index (vector-length buckets))
amount
(let ((current-bucket-amt (vector-ref buckets current-bucket-index)))
(if (>= (gnc-numeric-compare current-bucket-amt amount) 0)
(begin
(vector-set! buckets current-bucket-index (gnc-numeric-sub-fixed
current-bucket-amt amount))
(gnc-numeric-zero))
(begin
(vector-set! buckets current-bucket-index (gnc-numeric-zero))
(process-payment-driver
(gnc-numeric-sub-fixed amount current-bucket-amt)
buckets
(+ current-bucket-index 1)))))))
(let ((overpayment (company-get-overpayment company)))
;; if there's already an overpayment, make it bigger
(gnc:debug "processing payment of " amount)
(gnc:debug "overpayment was " overpayment)
(if (gnc-numeric-positive-p overpayment)
(company-set-overpayment company (gnc-numeric-add-fixed overpayment amount))
(let ((result (process-payment-driver amount (company-get-buckets company) 0)))
(gnc:debug "payment-driver processed. new overpayment: " result)
(company-set-overpayment company result)))))
;; determine date function to use
(define (get-selected-date-from-txn transaction date-type)
(if (eq? date-type 'postdate)
(xaccTransGetDate transaction)
(xaccTransRetDateDue transaction)))
;; deal with a transaction - figure out if we've seen the company before
;; if so, either process it as a bill or a payment, if not, create
;; a new company record in the hash
(define (update-company-hash hash split bucket-intervals
reverse? show-zeros date-type)
(define (do-update value)
(let* ((transaction (xaccSplitGetParent split))
(temp-owner (gncOwnerNew))
(owner (gnc:owner-from-split split temp-owner)))
(if (not (null? owner))
(let* ((guid (gncOwnerReturnGUID owner))
(this-currency (xaccTransGetCurrency transaction))
(this-date (get-selected-date-from-txn transaction date-type))
(company-info (hash-ref hash guid)))
(gnc:debug "update-company-hash called")
(gnc:debug "owner: " owner ", guid: " guid)
(gnc:debug "split-value: " value)
(if reverse? (set! value (gnc-numeric-neg value)))
(if company-info
;; if it's an existing company, destroy the temp owner and
;; then make sure the currencies match
(begin
(if (not (gnc-commodity-equiv
this-currency
(company-get-currency company-info)))
(let ((error-str
(string-append "IGNORING TRANSACTION!\n" "Invoice Owner: " (gnc:strify owner)
"\nTransaction:" (gnc:strify transaction)
"\nSplits are:\n"
(string-join
(map gnc:strify (xaccTransGetSplitList transaction))
"\n")
"\nTransaction Currency:" (gnc:strify this-currency)
"\nClient Currency:" (gnc:strify (company-get-currency company-info)))))
(gnc-error-dialog '() error-str)
(gnc:error error-str)
(cons #f (format #f (G_ "Transactions relating to '~a' contain \
more than one currency. This report is not designed to cope with this possibility.") (gncOwnerGetName owner))))
(begin
(gnc:debug "it's an old company")
(if (gnc-numeric-negative-p value)
(process-invoice company-info (gnc-numeric-neg value) bucket-intervals this-date)
(process-payment company-info value))
(hash-set! hash guid company-info)
(cons #t guid)))
(gncOwnerFree temp-owner))
;; if it's a new company
(begin
(gnc:debug "value" value)
(let ((new-company (make-company this-currency owner)))
(if (gnc-numeric-negative-p value)
(process-invoice new-company (gnc-numeric-neg value) bucket-intervals this-date)
(process-payment new-company value))
(hash-set! hash guid new-company))
(cons #t guid))))
; else (no owner)
(gncOwnerFree temp-owner))))
;; figure out if this split is part of a closed lot
;; also save the split value...
(let* ((lot (xaccSplitGetLot split))
(value (xaccSplitGetValue split))
(is-paid? (if (null? lot) #f (gnc-lot-is-closed lot))))
;; if it's closed, then ignore it because it doesn't matter.
;; XXX: we _could_ just set the value to 0 in order to list
;; the company. I'm not sure what to do. Perhaps add an
;; option?
(if (or (not is-paid?) show-zeros)
(do-update value))))
;; get the total debt from the buckets
(define (buckets-get-total buckets)
(let ((running-total (gnc-numeric-zero))
(buckets-list (vector->list buckets)))
(for-each (lambda (bucket)
(set! running-total
(gnc-numeric-add-fixed bucket running-total)))
buckets-list)
running-total))
;; compare by the total in the buckets
(define (safe-strcmp a b)
(if (and a b)
(cond
((string<? a b) -1)
((string>? a b) 1)
(else 0))
(cond
(a 1)
(b -1)
(else 0))))
(define (compare-total litem-a litem-b)
(let* ((company-a (cdr litem-a))
(bucket-a (company-get-buckets company-a))
(company-b (cdr litem-b))
(bucket-b (company-get-buckets company-b))
(total-a (buckets-get-total bucket-a))
(total-b (buckets-get-total bucket-b))
(difference-sign (gnc-numeric-compare (gnc-numeric-sub-fixed total-a total-b) (gnc-numeric-zero))))
;; if same totals, compare by name
(if (= difference-sign 0)
(safe-strcmp (car litem-a) (car litem-b))
difference-sign)))
;; compare by buckets, oldest first.
(define (compare-buckets litem-a litem-b)
(define (driver buckets-a buckets-b)
(if (null? buckets-a)
0
(let ((diff (gnc-numeric-compare
(gnc-numeric-sub-fixed
(car buckets-a)
(car buckets-b))
(gnc-numeric-zero))))
(if (= diff 0)
(driver (cdr buckets-a) (cdr buckets-b))
diff))))
(let* ((company-a (cdr litem-a))
(bucket-a (vector->list (company-get-buckets company-a)))
(company-b (cdr litem-b))
(bucket-b (vector->list (company-get-buckets company-b)))
(difference (driver bucket-a bucket-b)))
;; if same totals, compare by name
(if (= difference 0)
(safe-strcmp (car litem-a) (car litem-b))
difference)))
;; set up the query to get the splits in the chosen account
(define (setup-query query account date)
(qof-query-set-book query (gnc-get-current-book))
(xaccQueryAddClearedMatch
query (logand CLEARED-ALL (lognot CLEARED-VOIDED)) QOF-QUERY-AND)
(xaccQueryAddSingleAccountMatch query account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT query #f 0 #t date QOF-QUERY-AND)
(qof-query-set-sort-order query
(list SPLIT-TRANS TRANS-DATE-POSTED)
'() '())
(qof-query-set-sort-increasing query #t #t #t))
(define (aging-options-generator options)
(let* ((add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(gnc:options-add-report-date!
options gnc:pagename-general
optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-value (gnc:lookup-option options
gnc:pagename-general
optname-to-date)
(cons 'relative 'today))
;; all about currencies
(gnc:options-add-currency!
options gnc:pagename-general
optname-report-currency "b")
(gnc:options-add-price-source!
options gnc:pagename-general
optname-price-source "c" 'weighted-average)
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-sort-by
"i"
(N_ "Sort companies by.")
'name
(list
(vector 'name (N_ "Name") (N_ "Name of the company."))
(vector 'total (N_ "Total Owed") (N_ "Total amount owed to/from Company."))
(vector 'oldest-bracket (N_ "Bracket Total Owed") (N_ "Amount owed in oldest bracket - if same go to next oldest.")))))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-sort-order
"ia"
(N_ "Sort order.")
'increasing
(list
(vector 'increasing (N_ "Increasing") (N_ "0 .. 999,999.99, A .. Z."))
(vector 'decreasing (N_ "Decreasing") (N_ "999,999.99 .. 0, Z .. A.")))))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general
optname-multicurrency-totals
"i"
(N_ "Show multi-currency totals. If not selected, convert all \
totals to report currency.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-general
optname-show-zeros
"j"
(N_ "Show all vendors/customers even if they have a zero balance.")
#f))
(add-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-date-driver
"k"
(N_ "Leading date.")
'duedate
(list
(vector 'duedate (N_ "Due Date") (N_ "Due date is leading.")) ;; Should be using standard label for due date?
(vector 'postdate (N_ "Post Date") (N_ "Post date is leading."))))) ;; Should be using standard label for post date?
;; display tab options
;; option optname-addr-source is added in receivables.scm
;; as cannot access the value of an option in aging-options-generator
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-name
"b"
(N_ "Display Address Name. This, and other fields, may be useful if \
copying this report to a spreadsheet for use in a mail merge.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr1
"c"
(N_ "Display Address 1.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr2
"d"
(N_ "Display Address 2.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr3
"e"
(N_ "Display Address 3.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr4
"f"
(N_ "Display Address 4.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-phone
"g"
(N_ "Display Phone.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-fax
"h"
(N_ "Display Fax.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-addr-email
"i"
(N_ "Display Email.")
#f))
(add-option
(gnc:make-simple-boolean-option
gnc:pagename-display
optname-disp-active
"j"
(N_ "Display Active status.")
#f))
(gnc:options-set-default-section options "General")
options))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
;; Have make-list create a stepped list, then add a date in the future for the "current" bucket
(define (make-extended-interval-list to-date)
(define dayforcurrent (incdate to-date YearDelta)) ;; MAGIC CONSTANT
(define oldintervalreversed (reverse (make-interval-list to-date)))
(reverse (cons dayforcurrent oldintervalreversed)))
(define (aging-renderer report-obj reportname account reverse?)
(define receivable #t) ;; receivable=#t payable=#f
(define (get-name a)
(let* ((owner (company-get-owner-obj (cdr a))))
(gncOwnerGetName owner)))
;; Predicates for sorting the companys once the data has been collected
;; Format: (cons 'sort-key (cons 'increasing-pred 'decreasing-pred))
(define sort-preds
(list
(cons 'name (cons (lambda (a b)
(string<? (get-name a) (get-name b)))
(lambda (a b)
(string>? (get-name a) (get-name b)))))
(cons 'total (cons (lambda (a b)
(< (compare-total a b) 0))
(lambda (a b)
(> (compare-total a b) 0))))
(cons 'oldest-bracket (cons
(lambda (a b)
(< (compare-buckets a b) 0))
(lambda (a b)
(> (compare-buckets a b) 0))))))
(define (get-sort-pred sort-criterion sort-order)
(let ((choice (assq-ref sort-preds sort-criterion)))
(gnc:debug "sort-criterion" sort-criterion)
(gnc:debug "sort-order" sort-order)
(gnc:debug "choice: " choice)
(if choice
(if (eq? sort-order 'increasing)
(car choice)
(cdr choice))
(begin
(gnc:warn "internal sorting option errorin aging.scm")
(lambda (a b)
(string<? (car a) (car b)))))))
(define (get-op section name)
(gnc:lookup-option (gnc:report-options report-obj) section name))
(define (op-value section name)
(gnc:option-value (get-op section name)))
;; XXX: This is a hack - will be fixed when we move to a
;; more general interval scheme in this report
(define make-heading-list
(list
(G_ "Company")
(G_ "Current")
(G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")
(G_ "Total")))
;; following cols are optional
;; (G_ "Address Name")
;; (G_ "Address 1")
;; (G_ "Address 2")
;; (G_ "Address 3")
;; (G_ "Address 4")
;; (G_ "Phone")
;; (G_ "Fax")
;; (G_ "Email")
;; (G_ "Active")
;; Make a list of commodity collectors for column totals
(define (make-collector-list)
(define (make-collector-driver done total)
(if (< done total)
(cons
(gnc:make-commodity-collector)
(make-collector-driver (+ done 1) total))
'()))
(make-collector-driver 0 (+ num-buckets 1)))
;; update the column totals
(define (add-to-column-totals column-totals monetary-list)
(begin
(gnc:debug "column-totals" column-totals)
(gnc:debug "monetary-list" monetary-list)
(map (lambda (amount collector)
(begin
(gnc:debug "amount" amount)
(gnc:debug "collector" collector)
(collector 'add
(gnc:gnc-monetary-commodity amount)
(gnc:gnc-monetary-amount amount))))
monetary-list
column-totals)))
;; convert the buckets in the header data structure
(define (convert-to-monetary-list bucket-list currency overpayment)
(let* ((running-total (gnc-numeric-neg overpayment))
(monetised-buckets
(map (lambda (bucket-list-entry)
(begin
(set! running-total
(gnc-numeric-add-fixed running-total bucket-list-entry))
(gnc:make-gnc-monetary currency bucket-list-entry)))
(vector->list bucket-list))))
(append (reverse monetised-buckets)
(list (gnc:make-gnc-monetary currency running-total)))))
;; convert the collectors to the right output format
(define (convert-collectors collector-list report-currency
exchange-fn
multi-currencies-p)
(define (fmt-one-currency collector)
(let ((monetary (gnc:sum-collector-commodity collector report-currency exchange-fn)))
(if monetary
monetary
(begin
(gnc:warn "Exchange-lookup failed in fmt-one-currency")
#f))))
(define (fmt-multiple-currencies collector)
(let ((mini-table (gnc:make-html-table)))
(collector 'format
(lambda (commodity amount)
(gnc:html-table-append-row!
mini-table
(list (gnc:make-gnc-monetary
commodity amount))))
#f)
mini-table))
(let ((fmt-function
(if multi-currencies-p
fmt-multiple-currencies
fmt-one-currency)))
(map fmt-function collector-list)))
;; return pointer to either billing or shipping address
;; note customers have a shipping address but not vendors
(define (get-addr owner disp-addr-source)
(if (and receivable (eq? disp-addr-source 'shipping))
(gncCustomerGetShipAddr (gncOwnerGetCustomer owner)) ;; shipping
(gncOwnerGetAddr owner))) ;; billing
(issue-deprecation-warning
"old aging reports are deprecated and will be removed in 5.x")
(set! receivable (eq? (op-value "__hidden" "receivable-or-payable") 'R))
(gnc:report-starting reportname)
(let* ((companys (make-hash-table 23))
(report-title (op-value gnc:pagename-general gnc:optname-reportname))
;; document will be the HTML document that we return.
(report-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(op-value gnc:pagename-general optname-to-date))))
(interval-vec (list->vector (make-extended-interval-list report-date)))
(sort-pred (get-sort-pred
(op-value gnc:pagename-general optname-sort-by)
(op-value gnc:pagename-general optname-sort-order)))
(report-currency (op-value gnc:pagename-general optname-report-currency))
(price-source (op-value gnc:pagename-general optname-price-source))
(multi-totals-p (op-value gnc:pagename-general optname-multicurrency-totals))
(show-zeros (op-value gnc:pagename-general optname-show-zeros))
(date-type (op-value gnc:pagename-general optname-date-driver))
(disp-addr-source (if receivable
(op-value gnc:pagename-display optname-addr-source)
'billing))
(disp-addr-name (op-value gnc:pagename-display optname-disp-addr-name))
(disp-addr1 (op-value gnc:pagename-display optname-disp-addr1))
(disp-addr2 (op-value gnc:pagename-display optname-disp-addr2))
(disp-addr3 (op-value gnc:pagename-display optname-disp-addr3))
(disp-addr4 (op-value gnc:pagename-display optname-disp-addr4))
(disp-addr-phone (op-value gnc:pagename-display optname-disp-addr-phone))
(disp-addr-fax (op-value gnc:pagename-display optname-disp-addr-fax))
(disp-addr-email (op-value gnc:pagename-display optname-disp-addr-email))
(disp-active (op-value gnc:pagename-display optname-disp-active))
(heading-list make-heading-list)
(exchange-fn (gnc:case-exchange-fn price-source report-currency report-date))
(total-collector-list (make-collector-list))
(table (gnc:make-html-table))
(query (qof-query-create-for-splits))
(company-list '())
(work-done 0)
(work-to-do 0)
(document (gnc:make-html-document)))
; (gnc:debug "Account: " account)
;; add optional column headings
(if disp-addr-name
(set! heading-list (append heading-list (list (G_ "Address Name")))))
(if disp-addr1
(set! heading-list (append heading-list (list (G_ "Address 1")))))
(if disp-addr2
(set! heading-list (append heading-list (list (G_ "Address 2")))))
(if disp-addr3
(set! heading-list (append heading-list (list (G_ "Address 3")))))
(if disp-addr4
(set! heading-list (append heading-list (list (G_ "Address 4")))))
(if disp-addr-phone
(set! heading-list (append heading-list (list (G_ "Phone")))))
(if disp-addr-fax
(set! heading-list (append heading-list (list (G_ "Fax")))))
(if disp-addr-email
(set! heading-list (append heading-list (list (G_ "Email")))))
(if disp-active
(set! heading-list (append heading-list (list (G_ "Active")))))
;; set default title
(gnc:html-document-set-title! document report-title)
;; maybe redefine better...
(if (and account (not (null? account)))
(begin
(gnc:html-document-set-title!
document (string-append report-title ": " (xaccAccountGetName account)))
(gnc:html-document-set-headline! document
(gnc:html-markup
"!"
report-title
": "
(gnc:html-markup-anchor
(gnc:account-anchor-text account)
(xaccAccountGetName account))))))
(gnc:html-table-set-col-headers! table heading-list)
(if (and account (not (null? account)))
(begin
(setup-query query account report-date)
;; get the appropriate splits
(let ((splits (qof-query-run query)))
; (gnc:debug "splits" splits)
;; build the table
(set! work-to-do (length splits))
;; work-done is already zero
(for-each (lambda (split)
(gnc:report-percent-done (* 50 (/ work-done work-to-do)))
(set! work-done (+ 1 work-done))
(update-company-hash companys
split
interval-vec
reverse? show-zeros
date-type))
splits)
; (gnc:debug "companys" companys)
;; turn the hash into a list
(hash-for-each (lambda (key value)
(set! company-list
(cons (cons key value) company-list)))
companys)
; (gnc:debug "company list" company-list)
(set! company-list (sort-list! company-list
sort-pred))
;; build the table
(set! work-to-do (length company-list))
(set! work-done 0)
(for-each (lambda (company-list-entry)
(gnc:report-percent-done (+ 50 (* 50 (/ work-done work-to-do))))
(set! work-done (+ 1 work-done))
(let* ((monetary-list (convert-to-monetary-list
(company-get-buckets
(cdr company-list-entry))
(company-get-currency
(cdr company-list-entry))
(company-get-overpayment
(cdr company-list-entry))))
(owner (company-get-owner-obj
(cdr company-list-entry)))
(company-name (gncOwnerGetName owner))
(addr (get-addr owner disp-addr-source))
(addr-name (gncAddressGetName addr))
(addr-addr1 (gncAddressGetAddr1 addr))
(addr-addr2 (gncAddressGetAddr2 addr))
(addr-addr3 (gncAddressGetAddr3 addr))
(addr-addr4 (gncAddressGetAddr4 addr))
(addr-phone (gncAddressGetPhone addr))
(addr-fax (gncAddressGetFax addr))
(addr-email (gncAddressGetEmail addr))
(company-active (if (gncOwnerGetActive owner)
(C_ "One-letter indication for 'yes'" "Y") (C_ "One-letter indication for 'no'" "N")))
(opt-fld-list '())
)
;; (gnc:debug "aging-renderer: disp-addr-source=" disp-addr-source
;; " owner=" owner
;; " gncOwnerGetID=" (gncOwnerGetID owner) ;; cust no
;; " gncCustomerGetShipAddr="
;; (gncCustomerGetShipAddr (gncOwnerGetCustomer owner)))
(if disp-addr-name
(set! opt-fld-list (append opt-fld-list (list addr-name))))
(if disp-addr1
(set! opt-fld-list (append opt-fld-list (list addr-addr1))))
(if disp-addr2
(set! opt-fld-list (append opt-fld-list (list addr-addr2))))
(if disp-addr3
(set! opt-fld-list (append opt-fld-list (list addr-addr3))))
(if disp-addr4
(set! opt-fld-list (append opt-fld-list (list addr-addr4))))
(if disp-addr-phone
(set! opt-fld-list (append opt-fld-list (list addr-phone))))
(if disp-addr-fax
(set! opt-fld-list (append opt-fld-list (list addr-fax))))
(if disp-addr-email
(set! opt-fld-list (append opt-fld-list (list addr-email))))
(if disp-active
(set! opt-fld-list (append opt-fld-list (list company-active))))
(add-to-column-totals total-collector-list
monetary-list)
(let* ((ml (reverse monetary-list))
(total (car ml))
(rest (cdr ml)))
(set! monetary-list
(reverse
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-report-text owner account report-date)
total))
rest))))
(gnc:html-table-append-row! table
(append
(cons
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
company-name))
monetary-list)
opt-fld-list))
(gncOwnerFree owner)))
company-list)
;; add the totals
(gnc:html-table-append-row!
table
(cons (G_ "Total") (convert-collectors total-collector-list
report-currency
exchange-fn
multi-totals-p)))
(gnc:html-document-add-object!
document table)))
(gnc:html-document-add-object!
document
(gnc:make-html-text
(G_ "No valid account selected. Click on the Options button and select the account to use."))))
(qof-query-destroy query)
(gnc:report-finished)
document))
(export aging-options-generator)
(export aging-renderer)

2
gnucash/report/reports/example/average-balance.scm
View File

@ -455,9 +455,7 @@
barchart (gnc-commodity-get-nice-symbol report-currency))
(gnc:html-chart-set-data-labels! barchart col-labels)
;; (gnc:html-barchart-set-col-colors! barchart col-colors)
(gnc:html-chart-set-data-labels! barchart (map car data))
;; (gnc:html-chart-set-row-labels-rotated?! barchart #t)
(gnc:html-chart-set-width! barchart width)
(gnc:html-chart-set-height! barchart height)
(gnc:html-chart-set-height! barchart height)

6
gnucash/report/reports/standard/income-gst-statement.scm
View File

@ -70,7 +70,7 @@ accounts may be tagged with *EUGOODS* in the account description."))
(gnc:html-markup-p
(G_ "This message will be removed when tax accounts are specified."))))
(define* (gst-statement-renderer rpt #:optional export-type file-name)
(define* (gst-statement-renderer rpt #:optional export-type)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options rpt) section name)))
@ -83,10 +83,6 @@ accounts may be tagged with *EUGOODS* in the account description."))
#:custom-source-accounts sales-purch-accounts
#:custom-split-filter gst-custom-split-filter
#:export-type export-type))
(when file-name
(issue-deprecation-warning "gst-statement-renderer filename is \
obsolete, and not supported for exports. please set html-document \
export-string instead. this warning will be removed in GnuCash 5.0"))
(when (null? (opt-val "Accounts" "Tax Accounts"))
(gnc:html-document-add-object! document TAX-SETUP-DESC))
document)

601
gnucash/report/reports/standard/job-report.scm
View File

@ -1,601 +0,0 @@
;; -*-scheme-*-
;; owner-report.scm -- Print out a detailed owner report, which is a
;; summary of invoices and payments for a particular
;; company (the owner) applied to an account.
;;
;; Created by: Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; 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@gnu.org
(define-module (gnucash reports standard job-report))
(use-modules (gnucash engine))
(use-modules (gnucash utilities)) ; for gnc:debug
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (srfi srfi-1))
(define acct-string (N_ "Account"))
(define owner-string (N_ "Job"))
(define owner-page gnc:pagename-general)
(define date-header (N_ "Date"))
(define due-date-header (N_ "Due Date"))
(define reference-header (N_ "Reference"))
(define type-header (N_ "Type"))
(define desc-header (N_ "Description"))
(define amount-header (N_ "Amount"))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
(vector-ref columns-used 1))
(define (num-col columns-used)
(vector-ref columns-used 2))
(define (type-col columns-used)
(vector-ref columns-used 3))
(define (memo-col columns-used)
(vector-ref columns-used 4))
(define (value-col columns-used)
(vector-ref columns-used 5))
(define columns-used-size 6)
(define (build-column-used options)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(define (make-set-col col-vector)
(let ((col 0))
(lambda (used? index)
(if used?
(begin
(vector-set! col-vector index col)
(set! col (+ col 1)))
(vector-set! col-vector index #f)))))
(let* ((col-vector (make-vector columns-used-size #f))
(set-col (make-set-col col-vector)))
(set-col (opt-val "Display Columns" date-header) 0)
(set-col (opt-val "Display Columns" due-date-header) 1)
(set-col (opt-val "Display Columns" reference-header) 2)
(set-col (opt-val "Display Columns" type-header) 3)
(set-col (opt-val "Display Columns" desc-header) 4)
(set-col (opt-val "Display Columns" amount-header) 5)
col-vector))
(define (make-heading-list column-vector)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (G_ date-header)))
(if (date-due-col column-vector)
(addto! heading-list (G_ due-date-header)))
(if (num-col column-vector)
(addto! heading-list (G_ reference-header)))
(if (type-col column-vector)
(addto! heading-list (G_ type-header)))
(if (memo-col column-vector)
(addto! heading-list (G_ desc-header)))
(if (value-col column-vector)
(addto! heading-list (G_ amount-header)))
(reverse heading-list)))
(define num-buckets 4)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
(define (make-aging-table options query bucket-intervals reverse? currency)
(let ((lots (xaccQueryGetLots query QUERY-TXN-MATCH-ANY))
(buckets (new-bucket-vector))
(payments (gnc-numeric-zero))
(table (gnc:make-html-table)))
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(begin
(if (>= current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
current-bucket
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (apply-invoice date value)
(let* ((bucket-index (find-bucket 0 bucket-intervals date))
(new-value (gnc-numeric-add-fixed
value
(vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-value)))
(define (apply-payment value)
(set! payments (gnc-numeric-add-fixed value payments)))
(for-each
(lambda (lot)
(let* ((bal (gnc-lot-get-balance lot))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(post-date (gncInvoiceGetDatePosted invoice)))
(if (not (gnc-numeric-zero-p bal))
(begin
(if reverse?
(set! bal (gnc-numeric-neg bal)))
(if (not (null? invoice))
(begin
(apply-invoice post-date bal))
(apply-payment bal))))))
lots)
(gnc:html-table-set-col-headers!
table
(list (G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")))
(gnc:html-table-append-row!
table
(reverse (map (lambda (entry)
(gnc:make-gnc-monetary currency entry))
(vector->list buckets))))
table))
;;
;; Make a row list based on the visible columns
;;
(define (make-row column-vector date due-date num type-str memo monetary)
(let ((row-contents '()))
(if (date-col column-vector)
(addto! row-contents (qof-print-date date)))
(if (date-due-col column-vector)
(addto! row-contents
(if due-date
(qof-print-date due-date)
"")))
(if (num-col column-vector)
(addto! row-contents num))
(if (type-col column-vector)
(addto! row-contents type-str))
(if (memo-col column-vector)
(addto! row-contents memo))
(if (value-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" monetary)))
row-contents))
;;
;; Adds the 'Balance' row to the table if it has not been printed and
;; total is not zero
;;
;; Returns printed?
;;
(define (add-balance-row table column-vector txn odd-row? printed? start-date total)
(if (not printed?)
(begin
(set! printed? #t)
(if (not (gnc-numeric-zero-p total))
(let ((row (make-row column-vector start-date #f "" (G_ "Balance") ""
(gnc:make-gnc-monetary (xaccTransGetCurrency txn) total)))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style (reverse row))
(set! odd-row? (not odd-row?))
(set! row-style (if odd-row? "normal-row" "alternate-row")))
)))
printed?)
;;
;; Make sure the caller checks the type first and only calls us with
;; invoice and payment transactions. we don't verify it here.
;;
;; Return a list of (printed? value odd-row?)
;;
(define (add-txn-row table txn acc column-vector odd-row? printed?
inv-str reverse? start-date total)
(let* ((type (xaccTransGetTxnType txn))
(date (xaccTransGetDate txn))
(due-date #f)
(value (xaccTransGetAccountValue txn acc))
(split (xaccTransGetSplit txn 0))
(invoice (gncInvoiceGetInvoiceFromTxn txn))
(currency (xaccTransGetCurrency txn))
(type-str
(cond
((equal? type TXN-TYPE-INVOICE)
(if (not (null? invoice))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text invoice)
inv-str))
inv-str))
((equal? type TXN-TYPE-PAYMENT) (G_ "Payment, thank you!"))
(else (G_ "Unknown"))))
)
(if reverse?
(set! value (gnc-numeric-neg value)))
(if (< start-date date)
(begin
; Adds 'balance' row if needed
(set! printed? (add-balance-row table column-vector txn odd-row? printed? start-date total))
; Now print out the invoice row
(if (and (not (null? invoice))
(gncInvoiceIsPosted invoice))
(set! due-date (gncInvoiceGetDateDue invoice)))
(let ((row (make-row column-vector date due-date (gnc-get-num-action txn split)
type-str (xaccSplitGetMemo split)
(gnc:make-gnc-monetary currency value)))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style
(reverse row)))
(set! odd-row? (not odd-row?))
))
(list printed? value odd-row?)
))
(define (make-txn-table options query acc start-date end-date)
(let ((txns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ANY))
(used-columns (build-column-used options))
(total (gnc-numeric-zero))
(currency (xaccAccountGetCommodity acc))
(table (gnc:make-html-table))
(inv-str (gnc:option-value (gnc:lookup-option options "__reg"
"inv-str")))
(reverse? (gnc:option-value (gnc:lookup-option options "__reg"
"reverse?"))))
(gnc:html-table-set-col-headers!
table
(make-heading-list used-columns))
; Order the transactions properly
(set! txns (sort txns (lambda (a b) (> 0 (xaccTransOrder a b)))))
(let ((printed? #f)
(odd-row? #t))
(for-each
(lambda (txn)
(let ((type (xaccTransGetTxnType txn)))
(if
(or (equal? type TXN-TYPE-INVOICE)
(equal? type TXN-TYPE-PAYMENT))
(let ((result (add-txn-row table txn acc used-columns odd-row? printed?
inv-str reverse? start-date total)))
(set! printed? (car result))
(set! total (gnc-numeric-add-fixed total (cadr result)))
(set! odd-row? (caddr result))
))))
txns)
;Balance row may not have been added if all transactions were before
;start-date (and no other rows would be added either) so add it now
(if (not (null? txns))
(add-balance-row table used-columns (car txns) odd-row? printed? start-date total)
))
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(if (gnc-numeric-negative-p total)
(G_ "Total Credit")
(G_ "Total Due")))
'())
(list (gnc:make-html-table-cell/size/markup
1 (value-col used-columns)
"total-number-cell"
(gnc:make-gnc-monetary currency total)))))
(let* ((interval-vec (list->vector (make-interval-list end-date))))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list (gnc:make-html-table-cell/size/markup
1 (+ 1 (value-col used-columns))
"centered-label-cell"
(make-aging-table options query interval-vec reverse? currency)))))
table))
(define (options-generator acct-type-list owner-type inv-str reverse?)
(define gnc:*report-options* (gnc:new-options))
(define (gnc:register-inv-option new-option)
(gnc:register-option gnc:*report-options* new-option))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "inv-str" inv-str))
(gnc:register-inv-option
(gnc:make-simple-boolean-option "__reg" "reverse?" "" "" reverse?))
(gnc:register-inv-option
(gnc:make-owner-option owner-page owner-string "v"
(N_ "The job for this report.")
(lambda () '()) #f owner-type))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "owner-type" owner-type))
(gnc:register-inv-option
(gnc:make-account-sel-limited-option owner-page acct-string "w"
(N_ "The account to search for transactions.")
#f #f acct-type-list))
(gnc:options-add-date-interval!
gnc:*report-options* gnc:pagename-general
(N_ "From") (N_ "To") "a")
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") date-header
"b" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") due-date-header
"c" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") reference-header
"d" (N_ "Display the transaction reference?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") type-header
"g" (N_ "Display the transaction type?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") desc-header
"ha" (N_ "Display the transaction description?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") amount-header
"hb" (N_ "Display the transaction amount?") #t))
(gnc:options-set-default-section gnc:*report-options* "General")
gnc:*report-options*)
(define (job-options-generator)
(options-generator (list ACCT-TYPE-RECEIVABLE) GNC-OWNER-JOB
(G_ "Invoice") #f))
(define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID owner)))
(qof-query-add-guid-match
q
(list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER
QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT OWNER-FROM-LOT QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER
QOF-PARAM-GUID)
guid QOF-QUERY-OR)
(xaccQueryAddSingleAccountMatch q account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
q))
(define (make-owner-table owner)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row!
table
(list (gnc:multiline-to-html-text
(gnc:owner-get-name-and-address-dep owner))))
(gnc:html-table-append-row!
table (gnc:make-html-text (gnc:html-markup-br)))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-myname-table book date-format)
(let* ((table (gnc:make-html-table))
(name (gnc:company-info book gnc:*company-name*))
(addy (gnc:company-info book gnc:*company-addy*)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "align" "right")
'attribute (list "valign" "top")
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row! table (list (gnc:multiline-to-html-text (or addy ""))))
(gnc:html-table-append-row!
table (list (gnc-print-time64 (current-time) date-format)))
table))
(define (make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-br))))
(define (reg-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(issue-deprecation-warning
"old job report is deprecated and will be removed in 5.x. Its functionality \
is now merged into new-owner-report.scm.")
(let* ((document (gnc:make-html-document))
(table '())
(orders '())
(query (qof-query-create-for-splits))
(account (opt-val owner-page acct-string))
(owner (opt-val owner-page owner-string))
(start-date (gnc:time64-start-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general (N_ "From")))))
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general (N_ "To")))))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date book))
(type (opt-val "__reg" "owner-type"))
(type-str "")
(report-title-str ""))
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(set! type-str (N_ "Customer"))
(set! report-title-str (G_ "Customer Report")))
((eqv? type GNC-OWNER-JOB)
(set! type-str (N_ "Job"))
(set! report-title-str (G_ "Job Report")))
((eqv? type GNC-OWNER-VENDOR)
(set! type-str (N_ "Vendor"))
(set! report-title-str (G_ "Vendor Report")))
((eqv? type GNC-OWNER-EMPLOYEE)
(set! type-str (N_ "Employee"))
(set! report-title-str (G_ "Employee Report"))))
(gnc:html-document-set-title! document report-title-str)
(if (gncOwnerIsValid owner)
(begin
(setup-query query owner account end-date)
(gnc:html-document-set-title!
document
(string-append report-title-str ": " (gncOwnerGetName owner)))
(gnc:html-document-set-headline!
document (gnc:html-markup
"span"
report-title-str ": "
(gnc:html-markup-anchor
(gnc:job-anchor-text (gncOwnerGetJob owner))
(gncOwnerGetName owner))))
(if (not (null? account))
(begin
(set! table (make-txn-table (gnc:report-options report-obj)
query account start-date end-date))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 1)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 4)))
(set!
table
(gnc:make-html-text
(G_ "No valid account selected. Click on the Options button and select the account to use."))))
(gnc:html-document-add-object!
document
(make-myname-table book date-format))
(gnc:html-document-add-object!
document
(make-owner-table owner))
(make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(G_ "Date Range")
": "
(qof-print-date start-date)
" - "
(qof-print-date end-date))))
(make-break! document)
(gnc:html-document-add-object! document table))
;; else....
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(G_ "No valid customer selected."))
((eqv? type GNC-OWNER-JOB)
(G_ "No valid job selected."))
((eqv? type GNC-OWNER-VENDOR)
(G_ "No valid vendor selected."))
((eqv? type GNC-OWNER-EMPLOYEE)
(G_ "No valid employee selected."))
(else ""))
" "
(G_ "Click on the \"Options\" button to select a company.")))))
(qof-query-destroy query)
document))
(gnc:define-report
'version 1
'name "Job Report (legacy)"
'report-guid "5518ac227e474f47a34439f2d4d049de-old"
'menu-path (list gnc:menuname-business-reports)
'options-generator job-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

861
gnucash/report/reports/standard/owner-report.scm
View File

@ -1,861 +0,0 @@
;; -*-scheme-*-
;; owner-report.scm -- Print out a detailed owner report, which is a
;; summary of invoices and payments for a particular
;; company (the owner) applied to an account.
;;
;; Created by: Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;; Modified by AMM to show tax figures of invoice.
;;
;; 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@gnu.org
(define-module (gnucash reports standard owner-report))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-8))
(use-modules (gnucash engine))
(use-modules (gnucash utilities)) ; for gnc:debug
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
;; Option names
(define optname-from-date (N_ "From"))
(define optname-to-date (N_ "To"))
(define optname-date-driver (N_ "Due or Post Date"))
;; let's define a name for the report-guid's, much prettier
(define employee-report-guid "08ae9c2e884b4f9787144f47eacd7f44-old")
(define vendor-report-guid "d7d1e53505ee4b1b82efad9eacedaea0-old")
(define customer-report-guid "c146317be32e4948a561ec7fc89d15c1-old")
(define acct-string (N_ "Account"))
(define owner-page gnc:pagename-general)
(define date-header (N_ "Date"))
(define due-date-header (N_ "Due Date"))
(define reference-header (N_ "Reference"))
(define type-header (N_ "Type"))
(define desc-header (N_ "Description"))
(define sale-header (N_ "Sale"))
(define tax-header (N_ "Tax"))
(define credit-header (N_ "Credits"))
(define debit-header (N_ "Debits"))
(define amount-header (N_ "Amount"))
;; Depending on the report type we want to set up some lists/cases
;; with strings to ease overview and translation
;; note: we default to company
;; owner-string & doctype-str are nearly equivalent, report is vendor report
;; but default option naming was Company.
;; Names in Option panel (Untranslated! Because it is used for option
;; naming and lookup only, and the display of the option name will be
;; translated somewhere else.)
(define (owner-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (N_ "Customer"))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (N_ "Employee"))
;; FALL THROUGH
(else
(N_ "Company"))))
;; Error strings in case there is no (valid) selection (translated)
(define (invalid-selection-title-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "No valid customer selected."))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "No valid employee selected."))
;; FALL THROUGH
(else
(G_ "No valid company selected."))))
(define (invalid-selection-string owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "This report requires a customer to be selected."))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "This report requires a employee to be selected."))
;; FALL THROUGH
(else
(G_ "This report requires a company to be selected."))))
;; Html formatted error message documents
(define (gnc:html-make-no-owner-warning
report-title-string report-id)
(gnc:html-make-generic-warning
report-title-string
report-id
invalid-selection-title-string
invalid-selection-string))
(define (gnc:html-make-no-valid-account-warning
report-title-string report-id)
(gnc:html-make-generic-warning
report-title-string
report-id
(G_ "No valid account selected")
(G_ "This report requires a valid account to be selected.")))
;; Document names, used in report names (translated)
(define (doctype-str owner-type)
(cond ((eqv? owner-type GNC-OWNER-CUSTOMER) (G_ "Customer"))
((eqv? owner-type GNC-OWNER-EMPLOYEE) (G_ "Employee"))
;; FALL THROUGH
(else
(G_ "Vendor"))))
(define (date-col columns-used)
(vector-ref columns-used 0))
(define (date-due-col columns-used)
(vector-ref columns-used 1))
(define (num-col columns-used)
(vector-ref columns-used 2))
(define (type-col columns-used)
(vector-ref columns-used 3))
(define (memo-col columns-used)
(vector-ref columns-used 4))
(define (sale-col columns-used)
(vector-ref columns-used 5))
(define (tax-col columns-used)
(vector-ref columns-used 6))
(define (credit-col columns-used)
(vector-ref columns-used 7))
(define (debit-col columns-used)
(vector-ref columns-used 8))
(define (value-col columns-used)
(vector-ref columns-used 9))
(define columns-used-size 10)
(define (build-column-used options)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option options section name)))
(define (make-set-col col-vector)
(let ((col 0))
(lambda (used? index)
(if used?
(begin
(vector-set! col-vector index col)
(set! col (+ col 1)))
(vector-set! col-vector index #f)))))
(let* ((col-vector (make-vector columns-used-size #f))
(set-col (make-set-col col-vector)))
(set-col (opt-val "Display Columns" date-header) 0)
(set-col (opt-val "Display Columns" due-date-header) 1)
(set-col (opt-val "Display Columns" reference-header) 2)
(set-col (opt-val "Display Columns" type-header) 3)
(set-col (opt-val "Display Columns" desc-header) 4)
(set-col (opt-val "Display Columns" sale-header) 5)
(set-col (opt-val "Display Columns" tax-header) 6)
(set-col (opt-val "Display Columns" credit-header) 7)
(set-col (opt-val "Display Columns" debit-header) 8)
(set-col (opt-val "Display Columns" amount-header) 9)
col-vector))
(define (make-heading-list column-vector)
(let ((heading-list '()))
(if (date-col column-vector)
(addto! heading-list (G_ date-header)))
(if (date-due-col column-vector)
(addto! heading-list (G_ due-date-header)))
(if (num-col column-vector)
(addto! heading-list (G_ reference-header)))
(if (type-col column-vector)
(addto! heading-list (G_ type-header)))
(if (memo-col column-vector)
(addto! heading-list (G_ desc-header)))
(if (sale-col column-vector)
(addto! heading-list (G_ sale-header)))
(if (tax-col column-vector)
(addto! heading-list (G_ tax-header)))
(if (credit-col column-vector)
(addto! heading-list (G_ credit-header)))
(if (debit-col column-vector)
(addto! heading-list (G_ debit-header)))
(if (value-col column-vector)
(addto! heading-list (G_ amount-header)))
(reverse heading-list)))
(define num-buckets 5)
(define (new-bucket-vector)
(make-vector num-buckets (gnc-numeric-zero)))
(define (make-interval-list to-date)
(let ((begindate to-date))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(set! begindate (decdate begindate ThirtyDayDelta))
(gnc:make-date-list begindate to-date ThirtyDayDelta)))
;; Have make-list create a stepped list, then add a date in the future for the "current" bucket
(define (make-extended-interval-list to-date)
(define dayforcurrent (incdate to-date YearDelta)) ;; MAGIC CONSTANT
(define oldintervalreversed (reverse (make-interval-list to-date)))
(reverse (cons dayforcurrent oldintervalreversed)))
(define (make-aging-table options query bucket-intervals reverse? date-type currency)
(let ((lots (xaccQueryGetLots query QUERY-TXN-MATCH-ANY))
(buckets (new-bucket-vector))
(payments (gnc-numeric-zero))
(table (gnc:make-html-table)))
(define (in-interval this-date current-bucket)
(< this-date current-bucket))
(define (find-bucket current-bucket bucket-intervals date)
(begin
(if (>= current-bucket (vector-length bucket-intervals))
(gnc:error "sanity check failed in find-bucket")
(if (in-interval date (vector-ref bucket-intervals current-bucket))
current-bucket
(find-bucket (+ current-bucket 1) bucket-intervals date)))))
(define (apply-invoice date value)
(let* ((bucket-index (find-bucket 0 bucket-intervals date))
(new-value (gnc-numeric-add-fixed
value
(vector-ref buckets bucket-index))))
(vector-set! buckets bucket-index new-value)))
(define (apply-payment value)
(set! payments (gnc-numeric-add-fixed value payments)))
(for-each
(lambda (lot)
(let* ((bal (gnc-lot-get-balance lot))
(invoice (gncInvoiceGetInvoiceFromLot lot))
(date (if (eq? date-type 'postdate)
(gncInvoiceGetDatePosted invoice)
(gncInvoiceGetDateDue invoice)))
)
(if (not (gnc-numeric-zero-p bal))
(begin
(if reverse?
(set! bal (gnc-numeric-neg bal)))
(if (not (null? invoice))
(begin
(apply-invoice date bal))
(apply-payment bal))))))
lots)
(gnc:html-table-set-col-headers!
table
(list (G_ "Current")
(G_ "0-30 days")
(G_ "31-60 days")
(G_ "61-90 days")
(G_ "91+ days")))
(gnc:html-table-append-row!
table
(reverse (map (lambda (entry)
(gnc:make-gnc-monetary currency entry))
(vector->list buckets))))
table))
;;
;; Make a row list based on the visible columns
;;
(define (make-row column-vector date due-date num type-str memo monetary credit debit sale tax)
(let ((row-contents '()))
(if (date-col column-vector)
(addto! row-contents (qof-print-date date)))
(if (date-due-col column-vector)
(addto! row-contents
(if due-date
(qof-print-date due-date)
"")))
(if (num-col column-vector)
(addto! row-contents (gnc:html-string-sanitize num)))
(if (type-col column-vector)
(addto! row-contents type-str))
(if (memo-col column-vector)
(addto! row-contents (gnc:html-string-sanitize memo)))
(if (sale-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" sale)))
(if (tax-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" tax)))
(if (credit-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" credit)))
(if (debit-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" debit)))
(if (value-col column-vector)
(addto! row-contents
(gnc:make-html-table-cell/markup "number-cell" monetary)))
row-contents))
;;
;; Adds the 'Balance' row to the table if it has not been printed and
;; total is not zero
;;
;; Returns printed?
;;
(define (add-balance-row table column-vector txn odd-row? printed? start-date total)
(if (not printed?)
(begin
(set! printed? #t)
(if (and (value-col column-vector) (not (gnc-numeric-zero-p total)))
(let ((row (make-row column-vector start-date #f "" (G_ "Balance") ""
(gnc:make-gnc-monetary (xaccTransGetCurrency txn) total) "" "" "" ""))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style (reverse row))
(set! odd-row? (not odd-row?))
(set! row-style (if odd-row? "normal-row" "alternate-row")))
)))
printed?)
;;
;; Make sure the caller checks the type first and only calls us with
;; invoice and payment transactions. we don't verify it here.
;;
;; Return a list of (printed? value odd-row?)
;;
(define (add-txn-row table txn acc column-vector odd-row? printed?
reverse? start-date total)
(let* ((type (xaccTransGetTxnType txn))
(date (xaccTransGetDate txn))
(due-date #f)
(value (xaccTransGetAccountValue txn acc))
(sale (gnc-numeric-zero))
(tax (gnc-numeric-zero))
(split (xaccTransGetSplit txn 0))
(invoice (gncInvoiceGetInvoiceFromTxn txn))
(currency (xaccTransGetCurrency txn))
(type-str
(cond
((equal? type TXN-TYPE-INVOICE)
(if (not (null? invoice))
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:invoice-anchor-text invoice)
(gncInvoiceGetTypeString invoice)))
(G_ "Unknown")))
((equal? type TXN-TYPE-PAYMENT)
(gnc:make-html-text
(gnc:html-markup-anchor
(gnc:split-anchor-text split) (G_ "Payment"))))
(else (G_ "Unknown"))))
)
(if reverse?
(set! value (gnc-numeric-neg value)))
(if (<= start-date date)
(begin
; Adds 'balance' row if needed
(set! printed? (add-balance-row table column-vector txn odd-row? printed? start-date total))
; Now print out the invoice row
(if (not (null? invoice))
(begin
(set! due-date (and (gncInvoiceIsPosted invoice)
(gncInvoiceGetDateDue invoice)))
(set! sale (gncInvoiceGetTotalSubtotal invoice))
(set! tax (gncInvoiceGetTotalTax invoice))))
(if (gncInvoiceGetIsCreditNote invoice)
(begin
(set! tax (gnc-numeric-neg tax))
(set! sale (gnc-numeric-neg sale))))
(let ((row (make-row column-vector date due-date (gnc-get-num-action txn split)
type-str (xaccSplitGetMemo split)
(gnc:make-gnc-monetary currency value)
(if (not (gnc-numeric-negative-p value))
(gnc:make-gnc-monetary currency value) "")
(if (gnc-numeric-negative-p value)
(gnc:make-gnc-monetary currency value) "")
(if (not (null? invoice))
(gnc:make-gnc-monetary currency sale) "")
(if (not (null? invoice))
(gnc:make-gnc-monetary currency tax) "")
))
(row-style (if odd-row? "normal-row" "alternate-row")))
(gnc:html-table-append-row/markup! table row-style
(reverse row)))
(set! odd-row? (not odd-row?))
))
(list printed? value odd-row? sale tax)
))
(define (make-txn-table options query acc start-date end-date date-type)
(let ((txns (xaccQueryGetTransactions query QUERY-TXN-MATCH-ANY))
(used-columns (build-column-used options))
(total (gnc-numeric-zero))
(debit (gnc-numeric-zero))
(credit (gnc-numeric-zero))
(tax (gnc-numeric-zero))
(sale (gnc-numeric-zero))
(currency (xaccAccountGetCommodity acc))
(table (gnc:make-html-table))
(reverse? (gnc:option-value (gnc:lookup-option options "__reg"
"reverse?"))))
(gnc:html-table-set-col-headers!
table
(make-heading-list used-columns))
; Order the transactions properly
(set! txns (sort txns (lambda (a b) (> 0 (xaccTransOrder a b)))))
(let ((printed? #f)
(odd-row? #t))
(for-each
(lambda (txn)
(let ((type (xaccTransGetTxnType txn)))
(if
(or (equal? type TXN-TYPE-INVOICE)
(equal? type TXN-TYPE-PAYMENT))
(let ((result (add-txn-row table txn acc used-columns odd-row? printed?
reverse? start-date total)))
(set! printed? (car result))
(if (and printed? total)
(begin
(set! sale (gnc-numeric-add-fixed sale (cadddr result)))
(set! tax (gnc-numeric-add-fixed tax (car (cddddr result))))
(if (gnc-numeric-negative-p (cadr result))
(set! debit (gnc-numeric-add-fixed debit (cadr result)))
(set! credit (gnc-numeric-add-fixed credit (cadr result))))))
(set! total (gnc-numeric-add-fixed total (cadr result)))
(set! odd-row? (caddr result))
))))
txns)
;Balance row may not have been added if all transactions were before
;start-date (and no other rows would be added either) so add it now
(if (not (null? txns))
(add-balance-row table used-columns (car txns) odd-row? printed? start-date total)
))
(if (or (sale-col used-columns) (tax-col used-columns) (credit-col used-columns) (debit-col used-columns))
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(G_ "Period Totals"))
'())
(let ((row-contents '())
(pre-span 0))
; HTML gets generated in reverse order
(if (value-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency (gnc-numeric-add-fixed credit debit)))))
(if (debit-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency debit))))
(if (credit-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency credit))))
(if (tax-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency tax))))
(if (sale-col used-columns) (addto! row-contents
(gnc:make-html-table-cell/size/markup
1 1 "total-number-cell"
(gnc:make-gnc-monetary currency sale))))
(if (memo-col used-columns) (set! pre-span (+ pre-span 1)))
(if (type-col used-columns) (set! pre-span (+ pre-span 1)))
(if (num-col used-columns) (set! pre-span (+ pre-span 1)))
(if (date-due-col used-columns) (set! pre-span (+ pre-span 1)))
(if (date-col used-columns) (set! pre-span (+ pre-span 1)))
(if (>= pre-span 2) (addto! row-contents (gnc:make-html-table-cell/size 1 (- pre-span 1) "")))
row-contents))))
(if (value-col used-columns)
(gnc:html-table-append-row/markup!
table
"grand-total"
(append (cons (gnc:make-html-table-cell/markup
"total-label-cell"
(if (gnc-numeric-negative-p total)
(G_ "Total Credit")
(G_ "Total Due")))
'())
(list (gnc:make-html-table-cell/size/markup
1 (value-col used-columns)
"total-number-cell"
(gnc:make-gnc-monetary currency total))))))
(let* ((interval-vec (list->vector (make-extended-interval-list end-date))))
(gnc:html-table-append-row/markup!
table
"grand-total"
(list (gnc:make-html-table-cell/size
1 columns-used-size
(make-aging-table options query interval-vec reverse? date-type currency)))))
table))
(define (options-generator acct-type-list owner-type reverse?)
(define gnc:*report-options* (gnc:new-options))
(define (gnc:register-inv-option new-option)
(gnc:register-option gnc:*report-options* new-option))
(gnc:register-inv-option
(gnc:make-simple-boolean-option "__reg" "reverse?" "" "" reverse?))
(gnc:register-inv-option
(gnc:make-owner-option owner-page (owner-string owner-type) "v"
(N_ "The company for this report.")
(lambda () '()) #f owner-type))
(gnc:register-inv-option
(gnc:make-internal-option "__reg" "owner-type" owner-type))
(gnc:register-inv-option
(gnc:make-account-sel-limited-option owner-page acct-string "w"
(N_ "The account to search for transactions.")
#f #f acct-type-list))
(gnc:options-add-date-interval!
gnc:*report-options* gnc:pagename-general
optname-from-date optname-to-date "a")
;; Use a default report date of 'today'
(gnc:option-set-default-value
(gnc:lookup-option gnc:*report-options* gnc:pagename-general optname-to-date)
(cons 'relative 'today))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") date-header
"b" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") due-date-header
"c" (N_ "Display the transaction date?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") reference-header
"d" (N_ "Display the transaction reference?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") type-header
"g" (N_ "Display the transaction type?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") desc-header
"ha" (N_ "Display the transaction description?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") sale-header
"haa" (N_ "Display the sale amount column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") tax-header
"hab" (N_ "Display the tax column?") #f))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") credit-header
"hac" (N_ "Display the period credits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") debit-header
"had" (N_ "Display the period debits column?") #t))
(gnc:register-inv-option
(gnc:make-simple-boolean-option
(N_ "Display Columns") amount-header
"hb" (N_ "Display the transaction amount?") #t))
(gnc:register-inv-option
(gnc:make-multichoice-option
gnc:pagename-general
optname-date-driver
"k"
(N_ "Leading date.")
'duedate
(list
(vector 'duedate (N_ "Due Date") (N_ "Due date is leading.")) ;; Should be using standard label for due date?
(vector 'postdate (N_ "Post Date") (N_ "Post date is leading."))))) ;; Should be using standard label for post date?
(gnc:options-set-default-section gnc:*report-options* "General")
gnc:*report-options*)
(define (customer-options-generator)
(options-generator (list ACCT-TYPE-RECEIVABLE) GNC-OWNER-CUSTOMER #f))
(define (vendor-options-generator)
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-VENDOR #t))
(define (employee-options-generator)
(options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE #t))
(define (setup-query q owner account end-date)
(let* ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner))))
(qof-query-add-guid-match
q
(list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER
OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT OWNER-FROM-LOT OWNER-PARENTG)
guid QOF-QUERY-OR)
(qof-query-add-guid-match
q
(list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER
OWNER-PARENTG)
guid QOF-QUERY-OR)
(xaccQueryAddSingleAccountMatch q account QOF-QUERY-AND)
(xaccQueryAddDateMatchTT q #f end-date #t end-date QOF-QUERY-AND)
(qof-query-set-book q (gnc-get-current-book))
q))
(define (make-owner-table owner)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row!
table (gnc:multiline-to-html-text (gnc:owner-get-name-and-address-dep owner)))
(gnc:html-table-append-row!
table (gnc:make-html-text (gnc:html-markup-br)))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-date-row! table label date)
(gnc:html-table-append-row!
table
(list
(string-append label ": ")
(qof-print-date date))))
(define (make-date-table)
(let ((table (gnc:make-html-table)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-set-last-row-style!
table "td"
'attribute (list "valign" "top"))
table))
(define (make-myname-table book date-format)
(let* ((table (gnc:make-html-table))
(name (gnc:company-info book gnc:*company-name*))
(addy (gnc:company-info book gnc:*company-addy*)))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 0)
'attribute (list "align" "right")
'attribute (list "valign" "top")
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 0))
(gnc:html-table-append-row! table (list (or name "")))
(gnc:html-table-append-row!
table (list (gnc:multiline-to-html-text (or addy ""))))
(gnc:html-table-append-row!
table (list (gnc-print-time64 (gnc:get-today) date-format)))
table))
(define (make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(gnc:html-markup-br))))
(define (reg-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(issue-deprecation-warning
"old owner reports are deprecated and will be removed in 5.x")
(let* ((document (gnc:make-html-document))
(table '())
(orders '())
(query (qof-query-create-for-splits))
(account (opt-val owner-page acct-string))
(start-date (gnc:time64-start-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-from-date))))
(end-date (gnc:time64-end-day-time
(gnc:date-option-absolute-time
(opt-val gnc:pagename-general optname-to-date))))
(book (gnc-get-current-book))
(date-format (gnc:options-fancy-date book))
(type (opt-val "__reg" "owner-type"))
(owner-descr (owner-string type))
(date-type (opt-val gnc:pagename-general optname-date-driver))
(owner (opt-val owner-page owner-descr))
(report-title (string-append (doctype-str type) " " (G_ "Report"))))
(if (not (gncOwnerIsValid owner))
(gnc:html-document-add-object!
document
(gnc:html-make-no-owner-warning
report-title (gnc:report-id report-obj)))
;; else....
(begin
(set! report-title (string-append report-title ": " (gncOwnerGetName owner)))
(if (null? account)
(gnc:html-document-add-object!
document
(gnc:html-make-no-valid-account-warning
report-title (gnc:report-id report-obj)))
;; else....
(begin
(setup-query query owner account end-date)
(gnc:html-document-set-title! document report-title)
(gnc:html-document-set-headline!
document (gnc:html-markup
"span"
(doctype-str type)
" " (G_ "Report:") " "
(gnc:html-markup-anchor
(gnc:owner-anchor-text owner)
(gncOwnerGetName owner))))
(set! table (make-txn-table (gnc:report-options report-obj)
query account start-date end-date date-type))
(gnc:html-table-set-style!
table "table"
'attribute (list "border" 1)
'attribute (list "cellspacing" 0)
'attribute (list "cellpadding" 4))
(gnc:html-document-add-object!
document
(make-myname-table book date-format))
(gnc:html-document-add-object!
document
(make-owner-table owner))
(make-break! document)
(gnc:html-document-add-object!
document
(gnc:make-html-text
(string-append
(G_ "Date Range")
": "
(qof-print-date start-date)
" - "
(qof-print-date end-date))))
(make-break! document)
(gnc:html-document-add-object! document table)
(qof-query-destroy query)))))
document))
(define* (find-first-account type #:key currency)
(or (find
(lambda (acc)
(and (eqv? type (xaccAccountGetType acc))
(or (not currency)
(gnc-commodity-equiv currency (xaccAccountGetCommodity acc)))))
(gnc-account-get-descendants-sorted (gnc-get-current-root-account)))
'()))
(define* (find-first-account-for-owner owner #:key currency)
(let ((type (gncOwnerGetType (gncOwnerGetEndOwner owner))))
(cond
((eqv? type GNC-OWNER-CUSTOMER)
(find-first-account ACCT-TYPE-RECEIVABLE #:currency currency))
((eqv? type GNC-OWNER-VENDOR)
(find-first-account ACCT-TYPE-PAYABLE #:currency currency))
((eqv? type GNC-OWNER-EMPLOYEE)
(find-first-account ACCT-TYPE-PAYABLE #:currency currency))
((eqv? type GNC-OWNER-JOB)
(find-first-account-for-owner (gncOwnerGetEndOwner owner)
#:currency currency))
(else
'()))))
(gnc:define-report
'version 1
'name "Customer Report (legacy)"
'report-guid customer-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator customer-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))
(gnc:define-report
'version 1
'name "Vendor Report (legacy)"
'report-guid vendor-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator vendor-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))
(gnc:define-report
'version 1
'name "Employee Report (legacy)"
'report-guid employee-report-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator employee-options-generator
'renderer reg-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

81
gnucash/report/reports/standard/payables.scm
View File

@ -1,81 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; payables.scm : accounts payable aging report
;;
;; By Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; 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@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard payables))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash reports aging))
(define acc-page gnc:pagename-general)
(define this-acc (N_ "Payable Account"))
(define (options-generator)
(let* ((options (gnc:new-options))
(add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(add-option
(gnc:make-account-sel-limited-option
acc-page this-acc
"w" (N_ "The payable account you wish to examine.")
#f #f (list ACCT-TYPE-PAYABLE)))
;; As aging.scm functions are used by both receivables.scm and payables.scm
;; add option "receivable" on hidden page "__hidden" with default value 'P
;; so aging.scm functions can tell if they are reporting on
;; accounts receivable or payable, as customers have a shipping address
;; but vendors do not. The Address Source option therefore only applies
;; to customers.
(add-option
(gnc:make-internal-option "__hidden" "receivable-or-payable" 'P))
(aging-options-generator options)))
(define (payables-renderer report-obj)
(define (opt-val section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(let ((payables-account (opt-val acc-page this-acc)))
(gnc:debug "payables-account" payables-account)
(aging-renderer report-obj this-acc payables-account #f)))
(define payables-aging-guid "e57770f2dbca46619d6dac4ac5469b50-old")
;; Here we define the actual report with gnc:define-report
(gnc:define-report
'version 1
'name "Payable Aging (legacy)"
'report-guid payables-aging-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator options-generator
'renderer payables-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

94
gnucash/report/reports/standard/receivables.scm
View File

@ -1,94 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; receivables.scm : accounts receivable aging report
;;
;; By Derek Atkins <warlord@MIT.EDU>
;; Copyright (c) 2002, 2003 Derek Atkins <warlord@MIT.EDU>
;;
;; 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@gnu.org
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (gnucash reports standard receivables))
(use-modules (gnucash engine))
(use-modules (gnucash utilities))
(use-modules (gnucash core-utils))
(use-modules (gnucash app-utils))
(use-modules (gnucash report))
(use-modules (gnucash reports aging))
(define acc-page gnc:pagename-general)
(define this-acc (N_ "Receivables Account"))
(define optname-addr-source (N_ "Address Source")) ;; Billing or Shipping addresses
(define (options-generator)
(let* ((options (gnc:new-options))
(add-option
(lambda (new-option)
(gnc:register-option options new-option))))
(add-option
(gnc:make-account-sel-limited-option
acc-page this-acc
"w" (N_ "The receivables account you wish to examine.")
#f #f (list ACCT-TYPE-RECEIVABLE)))
;; As aging.scm functions are used by both receivables.scm and payables.scm
;; add option "receivable" on hidden page "__hidden" with default value 'R
;; so aging.scm functions can tell if they are reporting on
;; accounts receivable or payable, as customers have a shipping address
;; but vendors do not. The Address Source option therefore only applies
;; to customers.
(add-option
(gnc:make-internal-option "__hidden" "receivable-or-payable" 'R))
(add-option
(gnc:make-multichoice-option
gnc:pagename-display
optname-addr-source
"a"
(N_ "Address source.")
'billing
(list
(vector 'billing (N_ "Billing") (N_ "Address fields from billing address."))
(vector 'shipping (N_ "Shipping") (N_ "Address fields from shipping address.")))))
(aging-options-generator options)))
(define (receivables-renderer report-obj)
(define (op-value section name)
(gnc:option-value
(gnc:lookup-option (gnc:report-options report-obj) section name)))
(let* ((receivables-account (op-value acc-page this-acc)))
(gnc:debug "receivables-account" receivables-account)
(aging-renderer report-obj this-acc receivables-account #t)))
(define receivables-aging-guid "9cf76bed17f14401b8e3e22d0079cb98-old")
;; Here we define the actual report with gnc:define-report
(gnc:define-report
'version 1
'name "Receivable Aging (legacy)"
'report-guid receivables-aging-guid
'menu-path (list gnc:menuname-business-reports)
'options-generator options-generator
'renderer receivables-renderer
'in-menu? (gnc-prefs-is-extra-enabled))

59
gnucash/report/reports/standard/test/test-owner-report.scm
View File

@ -14,11 +14,7 @@
(use-modules (system vm vm))
(define uuid-list
(list (cons 'employee "08ae9c2e884b4f9787144f47eacd7f44-old")
(cons 'vendor "d7d1e53505ee4b1b82efad9eacedaea0-old")
(cons 'customer "c146317be32e4948a561ec7fc89d15c1-old")
(cons 'customer-new "c146317be32e4948a561ec7fc89d15c1")
(cons 'job "5518ac227e474f47a34439f2d4d049de-old")))
(list (cons 'customer-new "c146317be32e4948a561ec7fc89d15c1")))
(setlocale LC_ALL "C")
@ -301,32 +297,6 @@
(gnc-dmy2time64 22 06 1980) ;due
"inv $3 CN" #t #f))
;; (gnc:dump-book) (newline)
;; (gnc:dump-invoices) (newline)
(display "customer-report tests:\n")
(test-begin "customer-report")
(let* ((options (default-testing-options 'customer owner-1 (get-acct "AR-USD")))
(sxml (options->sxml 'customer options "customer-report basic")))
(test-equal "inv-descriptions"
'("inv >90 $11.50" "inv 60-90 $7.50" "inv 30-60 $8.50"
"inv >90 payment" "inv >90 payment" "inv <30days $4.00"
"inv $200" "inv $200" "inv current $6.75" "inv $3 CN"
"$31.75" "$8.00" "$8.00")
(sxml-get-row-col sxml #f 5))
(test-equal "debit-amounts"
'("$11.50" "$7.50" "$8.50" "$4.00" "$200.00" "$6.75")
(sxml-get-row-col sxml #f 6))
(test-equal "crebit-amounts"
'("-$1.50" "-$2.00" "-$200.00" "-$3.00")
(sxml-get-row-col sxml #f 7))
;; from the report, find the 3rd table, last row, find embedded
;; table, retrieve tr contents
(test-equal "aging-table"
'("$6.75" "$1.00" "$8.50" "$7.50" "$8.00")
((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
sxml)))
(test-end "customer-report")
(display "new-owner-report tests:\n")
(test-begin "new-customer-report")
(let* ((options (default-testing-options 'customer-new
@ -371,29 +341,4 @@
'("$0.00" "$6.75" "$1.00" "$8.50" "$7.50" "$8.00" "$31.75")
((sxpath `(// (table 3) // (tr -1) // table // tbody // tr // *text*))
sxml)))
(test-end "new-customer-report")
(display "job-report tests:\n")
;; inv for job
(let ((inv-2-copy (gncInvoiceCopy inv-2)))
(gncInvoiceAddEntry inv-2-copy (entry 25/4))
(gncInvoicePostToAccount inv-2-copy
(get-acct "AR-USD") ;post-to acc
(gnc-dmy2time64 13 05 1980) ;posted
(gnc-dmy2time64 18 06 1980) ;due
"inv for job" #t #f)
(gncInvoiceApplyPayment
inv-2-copy '() (get-acct "Bank-USD") 25/4 1
(gnc-dmy2time64 18 06 1980)
"inv for job" "fully paid"))
(test-begin "job-report")
(let* ((options (default-testing-options 'job owner-2 (get-acct "AR-USD")))
(sxml (options->sxml 'job options "job-report basic")))
(test-equal "inv-descriptions"
'("inv for job" "inv for job")
(sxml-get-row-col sxml #f 5))
(test-equal "amounts"
'("$6.25" "-$6.25")
(sxml-get-row-col sxml #f 6)))
(test-end "job-report")))
(test-end "new-customer-report")))

29
gnucash/report/test/test-report-html.scm
View File

@ -703,39 +703,14 @@ HTML Document Title</title></head><body></body>\n\
)
)
(test-end "HTML Table - Cell Access and Edit")
(test-begin "HTML Table - Append Columns")
(let (
(test-doc (gnc:make-html-document))
(test-table (gnc:make-html-table))
)
(gnc:html-table-set-caption! test-table #t)
(gnc:html-table-append-row! test-table "r1c1")
(gnc:html-table-append-row! test-table '("r2c1" "r2c2" "r2c3"))
(gnc:html-table-append-row! test-table '("r3c1" "r3c2"))
(gnc:html-table-append-column! test-table '("r1c4" "r2c4" "r3c4" "r4c4"))
(test-equal "HTML Table - Check Num Rows after append column"
4
(gnc:html-table-num-rows test-table)
)
(test-equal "HTML Table - Check data after append column"
'((#f #f #f "r4c4") ("r3c1" "r3c2" #f "r3c4") ("r2c1" "r2c2" "r2c3" "r2c4") ("r1c1" #f #f "r1c4"))
(gnc:html-table-data test-table)
)
(test-equal "HTML Table - Check Cell Access after append column"
"r3c2"
(gnc:html-table-get-cell test-table 2 1)
)
)
(test-end "HTML Table - Append Columns")
(test-begin "HTML Table - Table Rendering")
(let (
(test-doc (gnc:make-html-document))
(test-table (gnc:make-html-table))
)
(gnc:html-table-set-caption! test-table #t)
(gnc:html-table-append-row! test-table "Row 1")
(gnc:html-table-append-row! test-table "Row 2")
(gnc:html-table-append-column! test-table '("Col A" "Col B"))
(gnc:html-table-append-row! test-table '("Row 1" "Col A"))
(gnc:html-table-append-row! test-table '("Row 2" "Col B"))
(test-equal "HTML Table - Check table rendering result"
"<table><caption><boolean> #t</caption>\n\
<tbody>\

24
gnucash/report/test/test-report-utilities.scm
View File

@ -383,30 +383,6 @@
(gnc-dmy2time64 01 01 2001)
#t)))
(test-equal "gnc:accounts-get-comm-total-profit"
'(("GBP" . 612) ("USD" . 2389))
(collector->list
(gnc:accounts-get-comm-total-profit all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-income"
'(("GBP" . 612) ("USD" . 2573))
(collector->list
(gnc:accounts-get-comm-total-income all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-expense"
'(("USD" . -184))
(collector->list
(gnc:accounts-get-comm-total-expense all-accounts
(lambda (acct)
(gnc:account-get-comm-balance-at-date
acct (gnc-dmy2time64 01 01 2001) #f)))))
(test-equal "gnc:accounts-get-comm-total-assets"
'(("GBP" . 608) ("USD" . 2394))
(collector->list

7
gnucash/report/test/test-report.scm
View File

@ -134,13 +134,8 @@
(test-begin "test-make-report")
(test-assert "gnc:make-report succeeds"
(gnc:make-report test4-guid))
(test-equal "gnc:restore-report-by-guid"
1
(gnc:restore-report-by-guid 1 test4-guid test4-name "options"))
(test-assert "gnc:restore-report-by-guid, no options"
(not (gnc:restore-report-by-guid 1 test4-guid test4-name #f)))
(test-equal "gnc:restore-report-by-guid-with-custom-template"
2
1
(gnc:restore-report-by-guid-with-custom-template
"id" test4-guid test4-name "custom-template-id" "options"))
(test-assert "gnc:restore-report-by-guid-with-custom-template, no options"

7
gnucash/report/trep-engine.scm
View File

@ -1979,7 +1979,7 @@ be excluded from periodic reporting.")
report-obj #:key custom-calculated-cells empty-report-message
custom-split-filter split->date split->date-include-false?
custom-source-accounts
export-type filename)
export-type)
;; the trep-renderer is a define* function which, at minimum, takes
;; the report object
;;
@ -2011,11 +2011,6 @@ be excluded from periodic reporting.")
(((? from-account?) . _) #t)
((_ . rest) (lp rest)))))
(when filename
(issue-deprecation-warning "trep-renderer filename is obsolete, and not \
supported for exports. please set html-document export-string instead. this \
warning will be removed in GnuCash 5.0"))
(gnc:report-starting (opt-val gnc:pagename-general gnc:optname-reportname))
(let* ((document (gnc:make-html-document))

11
libgnucash/app-utils/app-utils.scm
View File

@ -38,14 +38,3 @@
(export gnc:get-debit-string)
(export gnc:get-credit-string)
(export gnc:config-file-format-version)
;; Symbols deprecated in 4.x, to remove for 5.x
(define (gnc:get-debit-string acct-type)
(issue-deprecation-warning "gnc:get-debit-string is deprecated in 4.x. Please use (gnucash engine)'s gnc-account-get-debit-string instead.")
(gnc-account-get-debit-string acct-type))
(define (gnc:get-credit-string acct-type)
(issue-deprecation-warning "gnc:get-credit-string is deprecated in 4.x. Please use (gnucash engine)'s gnc-account-get-credit-string instead.")
(gnc-account-get-debit-string acct-type))
(define (gnc:config-file-format-version version)
(issue-deprecation-warning "gnc:config-file-format-version is deprecated in 4.x and will be removed from a future version.")
#t)

18
libgnucash/app-utils/c-interface.scm
View File

@ -26,7 +26,6 @@
(export gnc:apply-with-error-handling)
(export gnc:eval-string-with-error-handling)
(export gnc:backtrace-if-exception)
(export gnc:last-captured-error)
(define (gnc:call-with-error-handling cmd args)
(let ((captured-stack #f)
@ -78,22 +77,5 @@
((result #f) result)
((_ captured-error)
(display captured-error (current-error-port))
;; the next line will be removed in 5.x - deprecated
(set! gnc:last-captured-error (gnc:html-string-sanitize captured-error))
(when (defined? 'gnc:warn) (gnc:warn captured-error))
#f)))
(define gnc:last-captured-error "") ;deprecate - remove in 5.x
;; This database can be used to store and retrieve translatable
;; strings. Strings that are returned by the lookup function are
;; translated with gettext.
(define (gnc:make-string-database)
(define string-hash (make-hash-table))
(issue-deprecation-warning "gnc:make-string-database is deprecated. It \
will be removed in GnuCash 5.x")
(lambda args
(match args
(('lookup key) (G_ (hash-ref string-hash key)))
(('store key string) (hash-set! string-hash key string))
(_ (gnc:warn "string-database: bad action")))))