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

Merge branch 'maint'

Browse Source
This commit is contained in:
Christopher Lam 2019-09-26 00:19:06 +08:00
commit b49109b782
12 changed files with 385 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gnucash/gnome/gnc-plugin-report-system.c
View File

@ -29,6 +29,7 @@
#include "file-utils.h"
#include "gnc-gnome-utils.h"
#include "gnc-html.h"
#include "gnc-guile-utils.h"
#include "gnc-plugin-page-report.h"
#include "gnc-plugin-report-system.h"
#include "gnc-plugin-manager.h"
@ -141,10 +142,16 @@ gnc_report_system_report_stream_cb (const char *location, char ** data, int *len
if (!ok)
{
SCM captured = scm_c_eval_string ("gnc:last-captured-error");
gchar *captured_str = gnc_scm_to_utf8_string(captured);
*data = g_strdup_printf ("<html><body><h3>%s</h3>"
"<p>%s</p></body></html>",
_("Report error"),
_("An error occurred while running the report."));
"<p>%s</p><pre>%s</pre></body></html>",
_("Report error"),
_("An error occurred while running the report."),
captured_str);
g_free(captured_str);
/* Make sure the progress bar is finished, which will also
* make the GUI sensitive again. Easier to do this via guile

14
gnucash/gnome/gnc-split-reg.c
View File

@ -2353,15 +2353,21 @@ gnc_split_reg_enter( GNCSplitReg *gsr, gboolean next_transaction )
}
}
}
/* First record the transaction. This will perform a refresh. */
if (!gnc_split_reg_record (gsr))
{
/* make sure the sheet has the focus if the record is FALSE
/* we may come here from the transfer cell if we decline to create a
* new account, make sure the sheet has the focus if the record is FALSE
* which results in no cursor movement. */
gnc_split_reg_focus_on_sheet (gsr);
LEAVE(" ");
return;
/* if there are no changes, just enter was pressed, proceed to move
* other wise lets not move. */
if (gnc_table_current_cursor_changed (sr->table, FALSE))
{
LEAVE(" ");
return;
}
}
if (!goto_blank && next_transaction)

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

@ -368,18 +368,5 @@
"<link rel=\"stylesheet\" type=\"text/css\" href=\"file:///~a\" />\n"
(gnc-path-find-localized-html-file file)))
;; function to sanitize strings prior to sending to html
(define (gnc:html-string-sanitize str)
(with-output-to-string
(lambda ()
(string-for-each
(lambda (c)
(display
(case c
((#\&) "&amp;")
((#\<) "&lt;")
((#\>) "&gt;")
(else c))))
str))))

1
gnucash/report/report.scm
View File

@ -113,7 +113,6 @@
(export gnc:html-make-options-link)
(export gnc:html-js-include)
(export gnc:html-css-include)
(export gnc:html-string-sanitize)
;; report-core.scm
(export gnc:menuname-reports)

2
gnucash/report/reports/standard/portfolio.scm
View File

@ -196,7 +196,7 @@
(if (not (null? accounts))
(let* ((commodity-list (gnc:accounts-get-commodities
(gnc:accounts-and-all-descendants accounts)
report-currency))
currency))
(pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
(exchange-fn (gnc:case-exchange-fn price-source currency to-date))
(price-fn

1
gnucash/report/reports/standard/test/CMakeLists.txt
View File

@ -18,6 +18,7 @@ set(scm_test_with_srfi64_SOURCES
test-average-balance.scm
test-invoice.scm
test-owner-report.scm
test-portfolios.scm
)
set(scm_test_with_textual_ports_SOURCES

127
gnucash/report/reports/standard/test/test-portfolios.scm Normal file
View File

@ -0,0 +1,127 @@
(use-modules (gnucash gnc-module))
(gnc:module-begin-syntax (gnc:module-load "gnucash/app-utils" 0))
(use-modules (tests test-engine-extras))
(use-modules (gnucash reports standard portfolio))
(use-modules (gnucash reports standard advanced-portfolio))
(use-modules (gnucash report stylesheets plain))
(use-modules (gnucash report))
(use-modules (tests test-report-extras))
(use-modules (srfi srfi-64))
(use-modules (tests srfi64-extras))
(use-modules (sxml simple))
(use-modules (sxml xpath))
(use-modules (system vm coverage))
(use-modules (system vm vm))
;; This is implementation testing for both the Portfolio and the
;; Advanced Portfolio Report.
(define portfolio-uuid "4a6b82e8678c4f3d9e85d9f09634ca89")
(define advanced-uuid "21d7cfc59fc74f22887596ebde7e462d")
;; Explicitly set locale to make the report output predictable
(setlocale LC_ALL "C")
(define (run-test)
(if #f
(coverage-test)
(run-test-proper)))
(define (coverage-test)
(let ((currfile (dirname (current-filename))))
(add-to-load-path (string-take currfile (string-rindex currfile #\/))))
(call-with-values
(lambda () (with-code-coverage run-test-proper))
(lambda (data result)
(let ((port (open-output-file "/tmp/lcov.info")))
(coverage-data->lcov data port)
(close port)))))
(define (run-test-proper)
(test-runner-factory gnc:test-runner)
(test-begin "test-portfolios.scm")
(null-test "portfolio" portfolio-uuid)
(null-test "advanced-portfolio" advanced-uuid)
(portfolio-tests)
(advanced-tests)
(test-end "test-portfolios.scm"))
(define (options->sxml uuid options test-title)
(gnc:options->sxml uuid options "test-apr" test-title))
(define (set-option! options section name value)
(let ((option (gnc:lookup-option options section name)))
(if option
(gnc:option-set-value option value)
(test-assert (format #f "wrong-option ~a ~a" section name) #f))))
(define (teardown)
(gnc-pricedb-destroy
(gnc-pricedb-get-db
(gnc-get-current-book)))
(gnc-clear-current-session))
(define (null-test variant uuid)
;; This null-test tests for the presence of report.
(let ((options (gnc:make-report-options uuid)))
(test-assert (format #f "null-test ~a" variant)
(options->sxml uuid options "null-test"))))
(define (portfolio-tests)
(test-group-with-cleanup "portfolio-tests"
(let* ((account-alist (create-stock-test-data))
(options (gnc:make-report-options portfolio-uuid)))
(set-option! options "General" "Price Source" 'pricedb-latest)
(let ((sxml (options->sxml portfolio-uuid options "latest")))
(test-equal "portfolio: pricedb-latest"
'("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$252.00")
(sxml->table-row-col sxml 1 1 #f)))
(set-option! options "General" "Price Source" 'pricedb-nearest)
(set-option! options "General" "Date" (cons 'absolute (gnc-dmy2time64 1 3 1980)))
(let ((sxml (options->sxml portfolio-uuid options "nearest")))
(test-equal "portfolio: pricedb-nearest"
'("AAPL" "AAPL" "NASDAQ" "2.00" "$200.00" "$400.00")
(sxml->table-row-col sxml 1 1 #f)))
(set-option! options "General" "Price Source" 'average-cost)
(set-option! options "General" "Date" (cons 'absolute (gnc-dmy2time64 1 9 1980)))
(let ((sxml (options->sxml portfolio-uuid options "average-cost")))
(test-equal "portfolio: average-cost"
'("AAPL" "AAPL" "NASDAQ" "1.00" "$200.00" "$200.00")
(sxml->table-row-col sxml 1 1 #f)))
(set-option! options "General" "Price Source" 'weighted-average)
(let ((sxml (options->sxml portfolio-uuid options "'weighted-average")))
(test-equal "portfolio: weighted-average"
'("AAPL" "AAPL" "NASDAQ" "1.00" "$233.33" "$233 + 1/3")
(sxml->table-row-col sxml 1 1 #f))))
(teardown)))
(define (advanced-tests)
(test-group-with-cleanup "advanced-portfolio-tests"
(let ((account-alist (create-stock-test-data))
(options (gnc:make-report-options advanced-uuid)))
(let ((sxml (options->sxml advanced-uuid options "basic average")))
(test-equal "advanced: average basis"
'("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$484.88" "$252.00" "$800.00"
"$553.00" "$227.88" "-$232.88" "-$5.00" "-0.63%" "$4.00"
"$10.00" "-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f)))
(set-option! options "General" "Basis calculation method" 'fifo-basis)
(let ((sxml (options->sxml advanced-uuid options "basic fifo")))
(test-equal "advanced: fifo basis"
'("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$543.94" "$252.00" "$800.00"
"$553.00" "$286.94" "-$291.94" "-$5.00" "-0.63%" "$4.00" "$10.00"
"-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f)))
(set-option! options "General" "Basis calculation method" 'filo-basis)
(let ((sxml (options->sxml advanced-uuid options "basic filo")))
(test-equal "advanced: filo basis"
'("AAPL" "AAPL" "NASDAQ" "42.00" "$6.00" "$400.00" "$252.00" "$800.00"
"$553.00" "$143.00" "-$148.00" "-$5.00" "-0.63%" "$4.00" "$10.00"
"-$1.00" "-0.13%")
(sxml->table-row-col sxml 1 1 #f))))
(teardown)))

35
gnucash/report/test/test-html-utilities-srfi64.scm
View File

@ -12,44 +12,9 @@
(define (run-test)
(test-runner-factory gnc:test-runner)
(test-begin "test-html-utilities-srfi64.scm")
(test-gnc:html-string-sanitize)
(test-gnc:assign-colors)
(test-end "test-html-utilities-srfi64.scm"))
(define (test-gnc:html-string-sanitize)
(test-begin "gnc:html-string-sanitize")
(test-equal "null test"
"abc"
(gnc:html-string-sanitize "abc"))
(test-equal "sanitize &copy;"
"&amp;copy;"
(gnc:html-string-sanitize "&copy;"))
(if (not (string=? (with-output-to-string (lambda () (display "🎃"))) "🎃"))
(test-skip 2))
(test-equal "emoji unchanged"
"🎃"
(gnc:html-string-sanitize "🎃"))
(test-equal "complex string"
"Smiley:\"🙂\" something"
(gnc:html-string-sanitize "Smiley:\"🙂\" something"))
(test-equal "sanitize <b>bold tags</b>"
"&lt;b&gt;bold tags&lt;/b&gt;"
(gnc:html-string-sanitize "<b>bold tags</b>"))
(test-equal "quotes are unchanged for html"
"\""
(gnc:html-string-sanitize "\""))
(test-equal "backslash is unchanged for html"
"\\"
(gnc:html-string-sanitize "\\"))
(test-end "gnc:html-string-sanitize"))
(define (test-gnc:assign-colors)
(test-begin "test-gnc:assign-colors")
(test-equal "assign-colors can request many colors"

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

@ -63,14 +63,17 @@
(define (gnc:backtrace-if-exception proc . args)
(let* ((apply-result (gnc:apply-with-error-handling proc args))
(result (car apply-result))
(error (cadr apply-result)))
(captured-error (cadr apply-result)))
(cond
(error
(display error (current-error-port))
(captured-error
(display captured-error (current-error-port))
(set! gnc:last-captured-error (gnc:html-string-sanitize captured-error))
(when (defined? 'gnc:warn)
(gnc:warn error)))
(gnc:warn captured-error)))
(else result))))
(define-public gnc:last-captured-error "")
;; This database can be used to store and retrieve translatable
;; strings. Strings that are returned by the lookup function are
;; translated with gettext.

177
libgnucash/engine/test/test-engine-extras.scm
View File

@ -833,3 +833,180 @@
"trans-payment-num-1"))
(vector inv-1 inv-2 inv-3 inv-4 inv-5 inv-6 inv-7 inv-8)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; various stock transactions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This function aims to replicate the stock-split process in
;; gnc_stock_split_assistant_finish in assistant-stock-split.c. It
;; creates a 1 or 3-split transaction, and possibly a pricedb entry.
(define (stock-split account date shares description
;; price-amount may be #f
price-amount pricecurrency
;; cash-in-lieu, cash-amount may be #f
cash-amount cash-memo cash-income cash-asset)
(let* ((book (gnc-get-current-book))
(accounts '())
(trans (xaccMallocTransaction book)))
(xaccTransBeginEdit trans)
(xaccTransSetCurrency trans (gnc-default-currency))
(xaccTransSetDatePostedSecsNormalized trans date)
(xaccTransSetDescription trans description)
(let ((stocksplit (xaccMallocSplit book)))
(xaccAccountBeginEdit account)
(set! accounts (cons account accounts))
(xaccSplitSetAccount stocksplit account)
(xaccSplitSetAmount stocksplit shares)
(xaccSplitMakeStockSplit stocksplit)
(xaccSplitSetAction stocksplit "Split")
(xaccSplitSetParent stocksplit trans))
;; add pricedb
(when price-amount
(let ((price (gnc-price-create book)))
(gnc-price-begin-edit price)
(gnc-price-set-commodity price (xaccAccountGetCommodity account))
(gnc-price-set-currency price pricecurrency)
(gnc-price-set-time64 price date)
(gnc-price-set-source price PRICE-SOURCE-STOCK-SPLIT)
(gnc-price-set-typestr price "unknown")
(gnc-price-set-value price price-amount)
(gnc-price-commit-edit price)
(gnc-pricedb-add-price (gnc-pricedb-get-db book) price)))
;; cash-in-lieu
(when cash-amount
(let ((asset-split (xaccMallocSplit book)))
(xaccAccountBeginEdit cash-asset)
(set! accounts (cons cash-asset accounts))
(xaccSplitSetAccount asset-split cash-asset)
(xaccSplitSetParent asset-split trans)
(xaccSplitSetAmount asset-split cash-amount)
(xaccSplitSetValue asset-split cash-amount)
(xaccSplitSetMemo asset-split cash-memo))
(let ((income-split (xaccMallocSplit book)))
(xaccAccountBeginEdit cash-income)
(set! accounts (cons cash-income accounts))
(xaccSplitSetAccount income-split cash-income)
(xaccSplitSetParent income-split trans)
(xaccSplitSetAmount income-split (- cash-amount))
(xaccSplitSetValue income-split (- cash-amount))
(xaccSplitSetMemo income-split cash-memo)))
(xaccTransCommitEdit trans)
(for-each xaccAccountCommitEdit accounts)
trans))
(define-public (create-stock-test-data)
(define structure
(list "Root" (list (cons 'type ACCT-TYPE-ASSET))
(list "Asset"
(list "Bank"))
(list "Income" (list (cons 'type ACCT-TYPE-INCOME)))
(list "Expenses" (list (cons 'type ACCT-TYPE-EXPENSE)))
(list "Equity" (list (cons 'type ACCT-TYPE-EQUITY)))
(list "Broker"
(list "AAPL" (list (cons 'type ACCT-TYPE-STOCK)))
(list "MSFT" (list (cons 'type ACCT-TYPE-STOCK)))
(list "TSLA" (list (cons 'type ACCT-TYPE-STOCK))))))
(let* ((env (create-test-env))
(book (gnc-get-current-book))
(comm-table (gnc-commodity-table-get-table book))
(AAPL (gnc-commodity-new book "Apple" "NASDAQ" "AAPL" "" 1))
(MSFT (gnc-commodity-new book "Microsoft" "NASDAQ" "MSFT" "" 1))
(TSLA (gnc-commodity-new book "Tesla Motors" "NASDAQ" "TSLA" "" 1))
(account-alist (env-create-account-structure-alist env structure))
(bank (cdr (assoc "Bank" account-alist)))
(inco (cdr (assoc "Income" account-alist)))
(expe (cdr (assoc "Expenses" account-alist)))
(equity (cdr (assoc "Equity" account-alist)))
(aapl (cdr (assoc "AAPL" account-alist)))
(msft (cdr (assoc "MSFT" account-alist)))
(tsla (cdr (assoc "TSLA" account-alist)))
(YEAR (gnc:time64-get-year (gnc:get-today))))
;; Set account commodities
(gnc-commodity-table-insert comm-table AAPL)
(gnc-commodity-table-insert comm-table MSFT)
(gnc-commodity-table-insert comm-table TSLA)
(xaccAccountSetCommodity aapl AAPL)
(xaccAccountSetCommodity msft MSFT)
(xaccAccountSetCommodity tsla TSLA)
(env-transfer env 01 01 1980 equity bank 10000 #:description "seed money")
(env-create-multisplit-transaction
env 01 02 1980
(list (vector bank -100 -100)
(vector aapl 100 1))
#:description "buy 1 AAPL @ $100")
(env-create-multisplit-transaction
env 01 03 1980
(list (vector bank -200 -200)
(vector aapl 200 1))
#:description "buy 1 AAPL @ $200")
(env-create-multisplit-transaction
env 01 05 1980
(list (vector bank 390 390)
(vector aapl -400 -1)
(vector inco -300 -300)
(vector expe 10 10)
(vector aapl 300 0))
#:description "sell 1 AAPL @ $400 FIFO, brokerage fee = $10, into bank = $390")
;; until 1.5.1980 the account has usual buy/sell txns only, no stock splits
;; there's only 1 AAPL left, price $400
;; on 1.10.1980: stock split, 1 AAPL -> 10 AAPL
;; prev price was $400, now is $40
(stock-split aapl
(gnc-dmy2time64 1 10 1980)
9 "first 1:10 stock split"
40 (gnc-account-get-currency-or-parent aapl)
#f #f #f #f)
;; on 1.11.1980: another stock split, 10 AAPL -> 100 AAPL
;; prev price was $40, now is $4
(stock-split aapl
(gnc-dmy2time64 1 11 1980)
90 "another 1:10 stock split"
4 (gnc-account-get-currency-or-parent aapl)
#f #f #f #f)
;; on 1.12.1980: 3:1 stock split, 100 AAPL -> 33 AAPL
;; prev price was $4, now is $12, with cash-in-lieu $4
(stock-split aapl
(gnc-dmy2time64 1 12 1980)
-67 "3:1 stock split with cash-in-lieu $4"
12 (gnc-account-get-currency-or-parent aapl)
4 "cash-in-lieu" inco bank)
(env-create-multisplit-transaction
env 01 01 1981
(list (vector bank -500 -500)
(vector aapl 500 10))
#:description "buy 10 AAPL @ $5")
(env-create-multisplit-transaction
env 1 3 1981
(list (vector bank 3 3)
(vector aapl -3 -1/2)
(vector inco -5/2 -5/2)
(vector aapl 5/2 0))
#:description "sell 1/2 AAPL @ $6 FIFO, capgain = $2.50 into bank = $200")
;; FIXME: spin off $150 from AAPL is coded correctly? there's no
;; INCOME split?
(env-create-multisplit-transaction
env 1 4 1981
(list (vector bank 150 150)
(vector aapl -150 0))
#:description "spin-off $150")
account-alist))

35
libgnucash/scm/test/test-libgnucash-scm-utilities.scm
View File

@ -10,6 +10,7 @@
(test-traverse-vec)
(test-substring-replace)
(test-sort-and-delete-duplicates)
(test-gnc:html-string-sanitize)
(test-gnc:list-flatten)
(test-begin "test-libgnucash-scm-utilities.scm"))
@ -89,6 +90,40 @@
(sort-and-delete-duplicates '(3 1 2) <))
(test-end "sort-and-delete-duplicates"))
(define (test-gnc:html-string-sanitize)
(test-begin "gnc:html-string-sanitize")
(test-equal "null test"
"abc"
(gnc:html-string-sanitize "abc"))
(test-equal "sanitize &copy;"
"&amp;copy;"
(gnc:html-string-sanitize "&copy;"))
(if (not (string=? (with-output-to-string (lambda () (display "🎃"))) "🎃"))
(test-skip 2))
(test-equal "emoji unchanged"
"🎃"
(gnc:html-string-sanitize "🎃"))
(test-equal "complex string"
"Smiley:\"🙂\" something"
(gnc:html-string-sanitize "Smiley:\"🙂\" something"))
(test-equal "sanitize <b>bold tags</b>"
"&lt;b&gt;bold tags&lt;/b&gt;"
(gnc:html-string-sanitize "<b>bold tags</b>"))
(test-equal "quotes are unchanged for html"
"\""
(gnc:html-string-sanitize "\""))
(test-equal "backslash is unchanged for html"
"\\"
(gnc:html-string-sanitize "\\"))
(test-end "gnc:html-string-sanitize"))
(define (test-gnc:list-flatten)
(test-equal "gnc:list-flatten null"
'()

17
libgnucash/scm/utilities.scm
View File

@ -172,6 +172,23 @@
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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-public (gnc:html-string-sanitize str)
(with-output-to-string
(lambda ()
(string-for-each
(lambda (c)
(display
(case c
((#\&) "&amp;")
((#\<) "&lt;")
((#\>) "&gt;")
(else c))))
str))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; avoid using strftime, still broken in guile-2.2. see explanation at
;; https://lists.gnu.org/archive/html/bug-guile/2019-05/msg00003.html