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

Handle reversed prices from gnc_pricedb_lookup*.

Browse Source 
In several cases replaces attempting to check both directions directly. This
had produced incorrect results because an older forward price would be preferred
over a reverse price.
This commit is contained in:
John Ralls 2015-10-29 14:13:37 -07:00
parent edefc9e57c
commit 7adc5e4451
10 changed files with 383 additions and 405 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/app-utils/gnc-sx-instance-model.c
View File

@ -1122,9 +1122,6 @@ create_each_transaction_helper(Transaction *template_txn, void *user_data)
price = gnc_pricedb_lookup_latest(price_db, first_cmdty, split_cmdty); price = gnc_pricedb_lookup_latest(price_db, first_cmdty, split_cmdty);
if (price == NULL) if (price == NULL)
{ {
price = gnc_pricedb_lookup_latest(price_db, split_cmdty, first_cmdty);
if (price == NULL)
{
GString *err = g_string_new(""); GString *err = g_string_new("");
g_string_printf(err, "could not find pricedb entry for commodity-pair (%s, %s).", g_string_printf(err, "could not find pricedb entry for commodity-pair (%s, %s).",
gnc_commodity_get_mnemonic(first_cmdty), gnc_commodity_get_mnemonic(first_cmdty),
@ -1135,7 +1132,9 @@ create_each_transaction_helper(Transaction *template_txn, void *user_data)
} }
else else
{ {
exchange = gnc_numeric_invert(gnc_price_get_value(price)); if (gnc_commodity_equiv(first_cmdty,
gnc_price_get_commodity(price)))
exchange = gnc_numeric_invert(gnc_price_get_value(price));
exchange = gnc_numeric_convert(exchange, 1000, exchange = gnc_numeric_convert(exchange, 1000,
GNC_HOW_RND_ROUND_HALF_UP); GNC_HOW_RND_ROUND_HALF_UP);
} }

24
src/gnome-utils/dialog-transfer.c
View File

@ -263,34 +263,18 @@ lookup_price(PriceReq *pr, PriceDate pd)
case SAME_DAY: case SAME_DAY:
prc = gnc_pricedb_lookup_day (pr->pricedb, pr->from, prc = gnc_pricedb_lookup_day (pr->pricedb, pr->from,
pr->to, pr->ts); pr->to, pr->ts);
if (!prc) break;
{
prc = gnc_pricedb_lookup_day (pr->pricedb, pr->to,
pr->from, pr->ts);
pr->reverse = TRUE;
}
break;
case NEAREST: case NEAREST:
prc = gnc_pricedb_lookup_nearest_in_time (pr->pricedb, pr->from, prc = gnc_pricedb_lookup_nearest_in_time (pr->pricedb, pr->from,
pr->to, pr->ts); pr->to, pr->ts);
if (!prc) break;
{
prc = gnc_pricedb_lookup_nearest_in_time (pr->pricedb, pr->to,
pr->from, pr->ts);
pr->reverse = TRUE;
}
break;
case LATEST: case LATEST:
prc = gnc_pricedb_lookup_latest (pr->pricedb, pr->from, pr->to); prc = gnc_pricedb_lookup_latest (pr->pricedb, pr->from, pr->to);
if (!prc)
{
prc = gnc_pricedb_lookup_latest (pr->pricedb, pr->to, pr->from);
pr->reverse = TRUE;
}
break; break;
} }
if (pr->reverse) if (gnc_commodity_equiv(gnc_price_get_currency(prc), pr->from))
{ {
pr->reverse = TRUE;
PINFO("Found reverse price: 1 %s = %f %s", PINFO("Found reverse price: 1 %s = %f %s",
gnc_commodity_get_mnemonic(pr->to), gnc_commodity_get_mnemonic(pr->to),
gnc_numeric_to_double(gnc_price_get_value(prc)), gnc_numeric_to_double(gnc_price_get_value(prc)),

32
src/gnome-utils/gnc-tree-util-split-reg.c
View File

@ -90,38 +90,16 @@ static gnc_numeric
gtu_sr_get_rate_from_db (gnc_commodity *from, gnc_commodity *to) gtu_sr_get_rate_from_db (gnc_commodity *from, gnc_commodity *to)
{ {
GNCPrice *prc; GNCPrice *prc;
gnc_numeric rate_split;
gboolean have_rate = FALSE;
QofBook *book = gnc_get_current_book (); QofBook *book = gnc_get_current_book ();
/* Do we have a rate allready */
prc = gnc_pricedb_lookup_latest (gnc_pricedb_get_db (book), from, to); prc = gnc_pricedb_lookup_latest (gnc_pricedb_get_db (book), from, to);
if (prc)
{
rate_split = gnc_price_get_value (prc);
gnc_price_unref (prc);
have_rate = TRUE;
}
/* Lets try reversing the commodities */ if (!prc)
if (!have_rate) return gnc_numeric_create (100, 100);
{
prc = gnc_pricedb_lookup_latest (gnc_pricedb_get_db (book), to, from);
if (prc)
{
rate_split = gnc_numeric_div (gnc_numeric_create (100, 100), gnc_price_get_value (prc),
GNC_DENOM_AUTO, GNC_HOW_DENOM_REDUCE);
gnc_price_unref (prc); if (gnc_commodity_equiv(from, gnc_price_get_currency(prc)))
have_rate = TRUE; return gnc_numeric_invert(gnc_price_get_value(prc));
} return gnc_price_get_value(prc);
}
/* No rate, set to 1/1 */
if (!have_rate)
rate_split = gnc_numeric_create (100, 100);
return rate_split;
} }

5
src/gnome/assistant-stock-split.c
View File

@ -231,7 +231,10 @@ refresh_details_page (StockSplitInfo *info)
if (prices) if (prices)
{ {
/* Use the first existing price */ /* Use the first existing price */
currency = gnc_price_get_currency(prices->data); if (gnc_commodity_equiv (commodity, gnc_price_get_currency(prices->data)))
currency = gnc_price_get_commodity(prices->data);
else
currency = gnc_price_get_currency(prices->data);
} }
else else
{ {

6
src/gnome/dialog-price-editor.c
View File

@ -347,7 +347,11 @@ pedit_commodity_changed_cb (GtkComboBox *cbwe, gpointer data)
(pedit_dialog->price_db, commodity); (pedit_dialog->price_db, commodity);
if (price_list) if (price_list)
{ {
currency = gnc_price_get_currency((GNCPrice *)price_list->data); GNCPrice * price = (GNCPrice*)price_list->data;
if (gnc_commodity_equiv(commodity, gnc_price_get_currency(price)))
currency = gnc_price_get_commodity((GNCPrice *)price);
else
currency = gnc_price_get_currency((GNCPrice *)price);
if (currency) if (currency)
gnc_currency_edit_set_currency gnc_currency_edit_set_currency

10
src/register/ledger-core/split-register.c
View File

@ -2067,15 +2067,9 @@ record_price (SplitRegister *reg, Account *account, gnc_numeric value,
return; return;
gnc_date_cell_get_date ((DateCell*)cell, &ts); gnc_date_cell_get_date ((DateCell*)cell, &ts);
price = gnc_pricedb_lookup_day (pricedb, comm, curr, ts); price = gnc_pricedb_lookup_day (pricedb, comm, curr, ts);
if (!price) if (gnc_commodity_equiv (comm, gnc_price_get_currency (price)))
{
price = gnc_pricedb_lookup_day (pricedb, curr, comm, ts);
if (price)
/* It might be better to raise an error here: We shouldn't be creating
* currency->commodity prices.
*/
swap = TRUE; swap = TRUE;
}
if (price) if (price)
{ {
price_value = gnc_price_get_value(price); price_value = gnc_price_get_value(price);

189
src/report/locale-specific/us/taxtxf.scm
View File

@ -1,5 +1,5 @@
;; -*-scheme-*- ;; -*-scheme-*-
;; by Richard -Gilligan- Uschold ;; by Richard -Gilligan- Uschold
;; ;;
;; updated by J. Alex Aycinena, July 2008, October 2009 ;; updated by J. Alex Aycinena, July 2008, October 2009
;; ;;
@ -46,7 +46,7 @@
;; Add support for Format 6 ;; Add support for Format 6
;; Use Form/Schedule line #'s to sort report. ;; Use Form/Schedule line #'s to sort report.
;; Update from "V037" to "V041" ;; Update from "V037" to "V041"
;; Add support for taxpayer types other than F1040 ;; Add support for taxpayer types other than F1040
;; ;;
;; September, 2010 Update: ;; September, 2010 Update:
;; ;;
@ -60,7 +60,7 @@
;; ;;
;; February, 2013 Update: ;; February, 2013 Update:
;; ;;
;; Fix beginning balance sign and signs for Transfer From/To amounts for ;; Fix beginning balance sign and signs for Transfer From/To amounts for
;; liability/equity accounts ;; liability/equity accounts
;; ;;
;; From prior version: ;; From prior version:
@ -142,7 +142,7 @@
;; returns a predicate that returns true only if a split is ;; returns a predicate that returns true only if a split is
;; between early-date and late-date ;; between early-date and late-date
(define (split-report-make-date-filter-predicate begin-date-tp end-date-tp) (define (split-report-make-date-filter-predicate begin-date-tp end-date-tp)
(lambda (split) (lambda (split)
(let ((tp (let ((tp
(gnc-transaction-get-date-posted (gnc-transaction-get-date-posted
(xaccSplitGetParent split)))) (xaccSplitGetParent split))))
@ -169,9 +169,9 @@
(define (gnc:register-tax-option new-option) (define (gnc:register-tax-option new-option)
(gnc:register-option options new-option)) (gnc:register-option options new-option))
;; date at which to report ;; date at which to report
(gnc:options-add-date-interval! (gnc:options-add-date-interval!
options gnc:pagename-general options gnc:pagename-general
(N_ "From") (N_ "To") "a") (N_ "From") (N_ "To") "a")
(gnc:register-tax-option (gnc:register-tax-option
@ -216,7 +216,7 @@
"d" (N_ "Select accounts.") "d" (N_ "Select accounts.")
(lambda () '()) (lambda () '())
#f #t)) #f #t))
(gnc:register-tax-option (gnc:register-tax-option
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
gnc:pagename-display (N_ "Suppress $0.00 values") gnc:pagename-display (N_ "Suppress $0.00 values")
@ -419,7 +419,7 @@
(define (render-header-row table heading-line-text) (define (render-header-row table heading-line-text)
(let ((heading (gnc:make-html-text))) (let ((heading (gnc:make-html-text)))
(gnc:html-text-append! heading (gnc:html-markup-b heading-line-text)) (gnc:html-text-append! heading (gnc:html-markup-b heading-line-text))
(let ((heading-cell (gnc:make-html-table-cell/markup (let ((heading-cell (gnc:make-html-table-cell/markup
"header-just-top" heading))) "header-just-top" heading)))
(gnc:html-table-cell-set-colspan! heading-cell 6) (gnc:html-table-cell-set-colspan! heading-cell 6)
@ -469,17 +469,17 @@
(let ((description (gnc:make-html-text)) (let ((description (gnc:make-html-text))
(total (gnc:make-html-text))) (total (gnc:make-html-text)))
(if (or tax_code? transaction-details?) (if (or tax_code? transaction-details?)
(gnc:html-text-append! description (gnc:html-markup-b (gnc:html-text-append! description (gnc:html-markup-b
(string-append "       " (string-append "       "
(if end-bal-text end-bal-text "Total For ")))) (if end-bal-text end-bal-text "Total For "))))
(if (not tax_code?) (if (not tax_code?)
(gnc:html-text-append! description (gnc:html-markup-b (gnc:html-text-append! description (gnc:html-markup-b
"       ")) "       "))
) )
) )
(gnc:html-text-append! description (gnc:html-markup-b (gnc:html-text-append! description (gnc:html-markup-b
total-line-text)) total-line-text))
(gnc:html-text-append! description (gnc:html-markup-b (gnc:html-text-append! description (gnc:html-markup-b
" ")) " "))
(gnc:html-text-append! total (gnc:html-markup-b (gnc:html-text-append! total (gnc:html-markup-b
total-amount)) total-amount))
@ -490,12 +490,12 @@
(amount-table (gnc:make-html-table)) ;; to line up totals to details (amount-table (gnc:make-html-table)) ;; to line up totals to details
(cap-gains-detail-table (gnc:make-html-table)) (cap-gains-detail-table (gnc:make-html-table))
) )
(gnc:html-table-set-style! amount-table "table" (gnc:html-table-set-style! amount-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
'attribute (list "width" "100%")) 'attribute (list "width" "100%"))
(gnc:html-table-set-style! cap-gains-detail-table "table" (gnc:html-table-set-style! cap-gains-detail-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
@ -580,10 +580,10 @@
"Equity" "Equity"
"")))))) ""))))))
(category-key (get-acct-txf-info 'cat-key type code)) (category-key (get-acct-txf-info 'cat-key type code))
(value-name (cond (value-name (cond
((string=? tax-entity-type "F1040") ((string=? tax-entity-type "F1040")
(if (equal? "ReinvD" action) (if (equal? "ReinvD" action)
(string-append (string-append
(xaccPrintAmount (xaccPrintAmount
(gnc-numeric-neg account-value) print-info) (gnc-numeric-neg account-value) print-info)
" " txf-account-name) " " txf-account-name)
@ -634,7 +634,7 @@
;; sub-lines of line 5 starting with 1 for first reported payer ;; sub-lines of line 5 starting with 1 for first reported payer
;; these apply if pns is either 'current or 'parent', but not ;; these apply if pns is either 'current or 'parent', but not
;; otherwise ;; otherwise
"L" (number->string txf-l-count) crlf "L" (number->string txf-l-count) crlf
(if (= format 4) (if (= format 4)
(if x? (if x?
(list "P" sold-desc crlf "D" crlf "D" date-str crlf (list "P" sold-desc crlf "D" crlf "D" date-str crlf
@ -656,11 +656,11 @@
'())) ;; not detail '())) ;; not detail
(else '())) (else '()))
(if x? (if x?
(cond (cond
((string=? tax-entity-type "F1040") ((string=? tax-entity-type "F1040")
(list "X" x-date-str " " (list "X" x-date-str " "
(fill-clamp-sp txf-account-name 31) (fill-clamp-sp txf-account-name 31)
(fill-clamp-sp action 7) (fill-clamp-sp action 7)
(fill-clamp-sp value-name 82) (fill-clamp-sp value-name 82)
(fill-clamp category-key 15) crlf)) (fill-clamp category-key 15) crlf))
((or (string=? tax-entity-type "F1065") ((or (string=? tax-entity-type "F1065")
@ -724,12 +724,15 @@
(begin ;; do so (begin ;; do so
(set! missing-pricedb-entry? #f) (set! missing-pricedb-entry? #f)
(set! pricedb-lookup-price (set! pricedb-lookup-price
(gnc-pricedb-lookup-nearest-in-time (let ((price (gnc-pricedb-lookup-nearest-in-time
pricedb pricedb
account-commodity account-commodity
USD-currency USD-currency
(timespecCanonicalDayTime (timespecCanonicalDayTime
lookup-date))) lookup-date))))
(if (gnc-commodity-equiv account-commodity (gnc-price-get-currency price))
(set! price (gnc-price-invert price)))
price))
(set! pricedb-lookup-price-value (set! pricedb-lookup-price-value
(gnc-price-get-value (gnc-price-get-value
pricedb-lookup-price)) pricedb-lookup-price))
@ -784,7 +787,7 @@
) )
" " " "
converted-qty converted-qty
(if (if
(and (not (gnc-commodity-equiv account-commodity (and (not (gnc-commodity-equiv account-commodity
USD-currency)) USD-currency))
(not (gnc-commodity-equiv trans-currency (not (gnc-commodity-equiv trans-currency
@ -827,7 +830,7 @@
) )
"")) ""))
) )
) )
(list amount conversion-text pricedb-lookup-price conversion-text2) (list amount conversion-text pricedb-lookup-price conversion-text2)
) )
) )
@ -850,16 +853,16 @@
) )
(if (= 4 format) (if (= 4 format)
(begin (begin
(gnc:html-table-set-style! cap-gains-detail-table "table" (gnc:html-table-set-style! cap-gains-detail-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "3") 'attribute (list "cellpadding" "3")
'attribute (list "width" "100%")) 'attribute (list "width" "100%"))
(gnc:html-table-set-style! trans-sub-heading-table "table" (gnc:html-table-set-style! trans-sub-heading-table "table"
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
'attribute (list "width" "100%")) 'attribute (list "width" "100%"))
(gnc:html-table-set-style! trans-sub-table "table" (gnc:html-table-set-style! trans-sub-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
@ -957,18 +960,18 @@
(if (and (= 4 format) (gnc-numeric-negative-p (if (and (= 4 format) (gnc-numeric-negative-p
(xaccSplitGetAmount tran-split))) (xaccSplitGetAmount tran-split)))
(begin (begin
(if tax-mode? (if tax-mode?
(gnc:html-table-append-row! (gnc:html-table-append-row!
cap-gains-detail-table cap-gains-detail-table
(append (list (gnc:make-html-table-cell (append (list (gnc:make-html-table-cell
(string-append (string-append
(xaccPrintAmount (xaccPrintAmount
(gnc-numeric-neg (gnc-numeric-neg
(xaccSplitGetAmount (xaccSplitGetAmount
tran-split)) tran-split))
print-info) print-info)
" " " "
(gnc-commodity-get-mnemonic (gnc-commodity-get-mnemonic
split-acct-commodity)))) split-acct-commodity))))
(list (gnc:make-html-table-cell/markup (list (gnc:make-html-table-cell/markup
"text-cell-center" "text-cell-center"
@ -1000,13 +1003,13 @@
tax-code tax-code
copy copy
tax-entity-type tax-entity-type
(string-append (string-append
(xaccPrintAmount (xaccPrintAmount
(gnc-numeric-neg (gnc-numeric-neg
(xaccSplitGetAmount (xaccSplitGetAmount
tran-split)) print-info) tran-split)) print-info)
" " " "
(gnc-commodity-get-mnemonic (gnc-commodity-get-mnemonic
split-acct-commodity)) split-acct-commodity))
))) )))
) )
@ -1135,7 +1138,7 @@
tax-mode? show-TXF-data? USD-currency account-type tax-mode? show-TXF-data? USD-currency account-type
tax-code acct-full-name acct-beg-bal-collector tax-code acct-full-name acct-beg-bal-collector
acct-end-bal-collector copy tax-entity-type) acct-end-bal-collector copy tax-entity-type)
(let* (let*
((account-commodity (xaccAccountGetCommodity account)) ((account-commodity (xaccAccountGetCommodity account))
(format (get-acct-txf-info 'format account-type tax-code)) (format (get-acct-txf-info 'format account-type tax-code))
@ -1296,7 +1299,7 @@
) )
#f) #f)
(gnc:html-table-cell-set-colspan! beg-bal-cell 5) (gnc:html-table-cell-set-colspan! beg-bal-cell 5)
(gnc:html-table-set-style! amount-table "table" (gnc:html-table-set-style! amount-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
@ -1343,12 +1346,12 @@
(if (and (> (length split-list) 0) (if (and (> (length split-list) 0)
(not (txf-beg-bal-only? tax-code))) (not (txf-beg-bal-only? tax-code)))
(set! output (set! output
(map (lambda (split) (map (lambda (split)
(let* ((parent (xaccSplitGetParent split)) (let* ((parent (xaccSplitGetParent split))
(trans-date (gnc-transaction-get-date-posted parent)) (trans-date (gnc-transaction-get-date-posted parent))
;; TurboTax 1999 and 2000 ignore dates after Dec 31 ;; TurboTax 1999 and 2000 ignore dates after Dec 31
(fudge-date (if splits-period (fudge-date (if splits-period
(if (and full-year? (if (and full-year?
(gnc:timepair-lt to-value trans-date)) (gnc:timepair-lt to-value trans-date))
to-value to-value
trans-date) trans-date)
@ -1379,7 +1382,7 @@
(eq? account-type ACCT-TYPE-LIABILITY) (eq? account-type ACCT-TYPE-LIABILITY)
(eq? account-type ACCT-TYPE-EQUITY)) (eq? account-type ACCT-TYPE-EQUITY))
(gnc-numeric-neg splt-amount) (gnc-numeric-neg splt-amount)
splt-amount)) splt-amount))
(curr-conv-note "") (curr-conv-note "")
(curr-conv-data (list splt-rpt-amount curr-conv-note #f "")) (curr-conv-data (list splt-rpt-amount curr-conv-note #f ""))
(curr-conv-data (if (and (gnc-commodity-equiv (curr-conv-data (if (and (gnc-commodity-equiv
@ -1437,7 +1440,7 @@
(eq? account-type ACCT-TYPE-LIABILITY) (eq? account-type ACCT-TYPE-LIABILITY)
(eq? account-type ACCT-TYPE-EQUITY)) (eq? account-type ACCT-TYPE-EQUITY))
(gnc-numeric-neg splt-amount) (gnc-numeric-neg splt-amount)
splt-amount)) splt-amount))
(acct-collector-as-dr 'add account-commodity splt-amount) (acct-collector-as-dr 'add account-commodity splt-amount)
(set! account-USD-total (gnc-numeric-add-fixed (set! account-USD-total (gnc-numeric-add-fixed
account-USD-total print-amnt)) account-USD-total print-amnt))
@ -1445,19 +1448,19 @@
;; transaction-multi-transfer-detail routine for TXF output and ;; transaction-multi-transfer-detail routine for TXF output and
;; to accumulate capital gains totals for account-, tax-code-, ;; to accumulate capital gains totals for account-, tax-code-,
;; and form-level totals even when not printing transaction ;; and form-level totals even when not printing transaction
;; details and/or Transfer To/From Accounts ;; details and/or Transfer To/From Accounts
(if (or (and transaction-details? tax-mode? (if (or (and transaction-details? tax-mode?
(null? other-account) split-details?) (null? other-account) split-details?)
(= 4 format) (= 4 format)
) )
(let ((cap-gain-data (let ((cap-gain-data
(process-transaction-multi-transfer-detail (process-transaction-multi-transfer-detail
split split
parent parent
USD-currency USD-currency
full-names? full-names?
trans-date trans-date
trans-currency trans-currency
account-type account-type
currency-conversion-date currency-conversion-date
to-value to-value
@ -1486,17 +1489,17 @@
)) ))
(if (and transaction-details? tax-mode?) (if (and transaction-details? tax-mode?)
(begin (begin
(gnc:html-table-set-style! date-table "table" (gnc:html-table-set-style! date-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0")) 'attribute (list "cellpadding" "0"))
(gnc:html-table-append-row! (gnc:html-table-append-row!
date-table date-table
(gnc:make-html-table-cell/markup (gnc:make-html-table-cell/markup
"date-cell" "date-cell"
(strftime "%Y-%b-%d" (strftime "%Y-%b-%d"
(localtime (car trans-date))))) (localtime (car trans-date)))))
(gnc:html-table-set-style! num-table "table" (gnc:html-table-set-style! num-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0")) 'attribute (list "cellpadding" "0"))
@ -1504,7 +1507,7 @@
num-table num-table
(gnc:make-html-table-cell (gnc-get-num-action (gnc:make-html-table-cell (gnc-get-num-action
parent split))) parent split)))
(gnc:html-table-set-style! desc-table "table" (gnc:html-table-set-style! desc-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0")) 'attribute (list "cellpadding" "0"))
@ -1512,14 +1515,14 @@
desc-table desc-table
(gnc:make-html-table-cell (gnc:make-html-table-cell
(xaccTransGetDescription parent))) (xaccTransGetDescription parent)))
(gnc:html-table-set-style! notes-table "table" (gnc:html-table-set-style! notes-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0")) 'attribute (list "cellpadding" "0"))
(gnc:html-table-append-row! (gnc:html-table-append-row!
notes-table notes-table
(gnc:make-html-table-cell notes-act-memo)) (gnc:make-html-table-cell notes-act-memo))
(gnc:html-table-set-style! transfer-table "table" (gnc:html-table-set-style! transfer-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
@ -1571,7 +1574,7 @@
) )
) )
) )
(gnc:html-table-set-style! amount-table "table" (gnc:html-table-set-style! amount-table "table"
'attribute (list "border" "0") 'attribute (list "border" "0")
'attribute (list "cellspacing" "0") 'attribute (list "cellspacing" "0")
'attribute (list "cellpadding" "0") 'attribute (list "cellpadding" "0")
@ -1744,7 +1747,7 @@
(define (get-option pagename optname) (define (get-option pagename optname)
(gnc:option-value (gnc:option-value
(gnc:lookup-option (gnc:lookup-option
(gnc:report-options report-obj) pagename optname))) (gnc:report-options report-obj) pagename optname)))
(define tax-entity-type (gnc-get-current-book-tax-type)) (define tax-entity-type (gnc-get-current-book-tax-type))
@ -1795,7 +1798,7 @@
#f #f
#t)) #t))
(let* ((form (if form form "")) ;; needed for "N000' (let* ((form (if form form "")) ;; needed for "N000'
(copy (number->string (copy (number->string
(xaccAccountGetTaxUSCopyNumber account))) (xaccAccountGetTaxUSCopyNumber account)))
(line (get-acct-txf-info 'line type tax-code-sym)) (line (get-acct-txf-info 'line type tax-code-sym))
(line (if line (line (if line
@ -1892,7 +1895,7 @@
"None" "None"
(list "Set as tax-related, no tax code assigned" (list "Set as tax-related, no tax code assigned"
account-name form account))) account-name form account)))
selected-accounts-sorted-by-form-line-acct) selected-accounts-sorted-by-form-line-acct)
(begin ;; not tax related - skip for report (begin ;; not tax related - skip for report
selected-accounts-sorted-by-form-line-acct) selected-accounts-sorted-by-form-line-acct)
) )
@ -1948,7 +1951,7 @@
(if prior-char-num? (if prior-char-num?
(begin (begin
(if (string=? string-part "") (if (string=? string-part "")
#f #f
(set! lst (append lst (list (set! lst (append lst (list
(string->number string-part))))) (string->number string-part)))))
(set! string-part (string char)) (set! string-part (string char))
@ -2040,14 +2043,14 @@
"USD")) "USD"))
(gnc:report-starting reportname) (gnc:report-starting reportname)
(let* ((from-value (gnc:date-option-absolute-time (let* ((from-value (gnc:date-option-absolute-time
(get-option gnc:pagename-general "From"))) (get-option gnc:pagename-general "From")))
(to-value (gnc:timepair-end-day-time (to-value (gnc:timepair-end-day-time
(gnc:date-option-absolute-time (gnc:date-option-absolute-time
(get-option gnc:pagename-general "To")))) (get-option gnc:pagename-general "To"))))
(alt-period (get-option gnc:pagename-general "Alternate Period")) (alt-period (get-option gnc:pagename-general "Alternate Period"))
(selected-style-sheet (get-option gnc:pagename-general "Stylesheet")) (selected-style-sheet (get-option gnc:pagename-general "Stylesheet"))
(suppress-0? (get-option gnc:pagename-display (suppress-0? (get-option gnc:pagename-display
"Suppress $0.00 values")) "Suppress $0.00 values"))
(full-names? (not (get-option gnc:pagename-display (full-names? (not (get-option gnc:pagename-display
"Do not print full account names"))) "Do not print full account names")))
@ -2063,13 +2066,13 @@
(gnc:report-options report-obj) (gnc:report-options report-obj)
gnc:pagename-display gnc:pagename-display
"Do not print Action:Memo data") "Do not print Action:Memo data")
(get-option gnc:pagename-display (get-option gnc:pagename-display
"Do not print Action:Memo data") "Do not print Action:Memo data")
(get-option gnc:pagename-display (get-option gnc:pagename-display
"Do not print T-Num:Memo data"))) "Do not print T-Num:Memo data")))
(shade-alternate-transactions? (if (gnc-html-engine-supports-css) (shade-alternate-transactions? (if (gnc-html-engine-supports-css)
#t #t
(get-option gnc:pagename-display (get-option gnc:pagename-display
"Shade alternate transactions"))) "Shade alternate transactions")))
(currency-conversion-date (get-option gnc:pagename-display (currency-conversion-date (get-option gnc:pagename-display
"Currency conversion date")) "Currency conversion date"))
@ -2079,7 +2082,7 @@
;; If no selected accounts, check all. ;; If no selected accounts, check all.
(selected-accounts (if (not (null? user-sel-accnts)) (selected-accounts (if (not (null? user-sel-accnts))
valid-user-sel-accnts valid-user-sel-accnts
(validate (reverse (validate (reverse
(gnc-account-get-children-sorted (gnc-account-get-children-sorted
(gnc-get-current-root-account)))))) (gnc-get-current-root-account))))))
@ -2090,13 +2093,13 @@
(from-date (gnc:timepair->date from-value)) (from-date (gnc:timepair->date from-value))
(from-value (gnc:timepair-start-day-time (from-value (gnc:timepair-start-day-time
(let ((bdtm from-date)) (let ((bdtm from-date))
(if (member alt-period (if (member alt-period
'(last-year 1st-last 2nd-last '(last-year 1st-last 2nd-last
3rd-last 4th-last)) 3rd-last 4th-last))
(set-tm:year bdtm (- (tm:year bdtm) 1))) (set-tm:year bdtm (- (tm:year bdtm) 1)))
(or (eq? alt-period 'from-to) (or (eq? alt-period 'from-to)
(set-tm:mday bdtm 1)) (set-tm:mday bdtm 1))
(if (< (gnc:date-get-year bdtm) (if (< (gnc:date-get-year bdtm)
tax-qtr-real-qtr-year) tax-qtr-real-qtr-year)
(case alt-period (case alt-period
((1st-est 1st-last last-year) ; Jan 1 ((1st-est 1st-last last-year) ; Jan 1
@ -2122,7 +2125,7 @@
(to-value (gnc:timepair-end-day-time (to-value (gnc:timepair-end-day-time
(let ((bdtm from-date)) (let ((bdtm from-date))
(if (member alt-period (if (member alt-period
'(last-year 1st-last 2nd-last '(last-year 1st-last 2nd-last
3rd-last 4th-last)) 3rd-last 4th-last))
(set-tm:year bdtm (- (tm:year bdtm) 1))) (set-tm:year bdtm (- (tm:year bdtm) 1)))
@ -2130,7 +2133,7 @@
;; The exact same code, in from-value, further above, ;; The exact same code, in from-value, further above,
;; only subtraces one! Go figure! ;; only subtraces one! Go figure!
;; So, we add one back below! ;; So, we add one back below!
(if (member alt-period (if (member alt-period
'(last-year 1st-last 2nd-last '(last-year 1st-last 2nd-last
3rd-last 4th-last)) 3rd-last 4th-last))
(set-tm:year bdtm (+ (tm:year bdtm) 1))) (set-tm:year bdtm (+ (tm:year bdtm) 1)))
@ -2159,7 +2162,7 @@
(set-tm:mon bdtm 8)) (set-tm:mon bdtm 8))
((4th-est 4th-last last-year) ; Dec 31 ((4th-est 4th-last last-year) ; Dec 31
(set-tm:mon bdtm 11)) (set-tm:mon bdtm 11))
(else (else
(set! bdtm (gnc:timepair->date to-value))))) (set! bdtm (gnc:timepair->date to-value)))))
(set-tm:isdst bdtm -1) (set-tm:isdst bdtm -1)
(cons (car (mktime bdtm)) 0)))) (cons (car (mktime bdtm)) 0))))
@ -2177,7 +2180,7 @@
(define (txf-special-splits-period account from-value to-value) (define (txf-special-splits-period account from-value to-value)
(if (and (xaccAccountGetTaxRelated account) (if (and (xaccAccountGetTaxRelated account)
(txf-special-date? (gnc:account-get-txf-code account))) (txf-special-date? (gnc:account-get-txf-code account)))
(let* (let*
((full-year? ((full-year?
(let ((bdto (localtime (car to-value))) (let ((bdto (localtime (car to-value)))
(bdfrom (localtime (car from-value)))) (bdfrom (localtime (car from-value))))
@ -2252,13 +2255,13 @@
(acct-beg-bal-collector (if (not (acct-beg-bal-collector (if (not
(or (eq? account-type ACCT-TYPE-INCOME) (or (eq? account-type ACCT-TYPE-INCOME)
(eq? account-type ACCT-TYPE-EXPENSE))) (eq? account-type ACCT-TYPE-EXPENSE)))
(gnc:account-get-comm-balance-at-date account (gnc:account-get-comm-balance-at-date account
(gnc:timepair-previous-day from-value) #f) (gnc:timepair-previous-day from-value) #f)
#f)) #f))
(acct-end-bal-collector (if (not (acct-end-bal-collector (if (not
(or (eq? account-type ACCT-TYPE-INCOME) (or (eq? account-type ACCT-TYPE-INCOME)
(eq? account-type ACCT-TYPE-EXPENSE))) (eq? account-type ACCT-TYPE-EXPENSE)))
(gnc:account-get-comm-balance-at-date account (gnc:account-get-comm-balance-at-date account
to-value #f) to-value #f)
#f)) #f))
(account-commodity (xaccAccountGetCommodity account)) (account-commodity (xaccAccountGetCommodity account))
@ -2395,8 +2398,8 @@
(let ((from-date (strftime "%Y-%b-%d" (localtime (car from-value)))) (let ((from-date (strftime "%Y-%b-%d" (localtime (car from-value))))
(to-date (strftime "%Y-%b-%d" (localtime (car to-value)))) (to-date (strftime "%Y-%b-%d" (localtime (car to-value))))
(today-date (strftime "D%m/%d/%Y" (today-date (strftime "D%m/%d/%Y"
(localtime (localtime
(car (timespecCanonicalDayTime (car (timespecCanonicalDayTime
(cons (current-time) 0)))))) (cons (current-time) 0))))))
(tax-year (strftime "%Y" (localtime (car from-value)))) (tax-year (strftime "%Y" (localtime (car from-value))))
@ -2496,7 +2499,7 @@
(xaccPrintAmount (xaccPrintAmount
tax-code-sub-item-USD-total tax-code-sub-item-USD-total
print-info)) print-info))
) )
;; print prior tax-code-sub-item ;; print prior tax-code-sub-item
;; total and reset accum ;; total and reset accum
(render-total-row (render-total-row
@ -2562,7 +2565,7 @@
) )
) )
;; process prior tax code break, if appropriate, before ;; process prior tax code break, if appropriate, before
;; processing current account ;; processing current account
(if (string=? prior-tax-code "") (if (string=? prior-tax-code "")
#t ;; do nothing #t ;; do nothing
(if tax-mode? (if tax-mode?
@ -2590,7 +2593,7 @@
(xaccPrintAmount (xaccPrintAmount
tax-code-cap-gain-basis-USD-total tax-code-cap-gain-basis-USD-total
print-info)) print-info))
) )
;; print prior tax-code total and ;; print prior tax-code total and
;; reset accum ;; reset accum
(render-total-row (render-total-row
@ -2711,7 +2714,7 @@
) )
) )
;; process prior form-schedule-line break, if appropriate, ;; process prior form-schedule-line break, if appropriate,
;; before processing current account ;; before processing current account
(if (string=? prior-form-sched-line "") (if (string=? prior-form-sched-line "")
(set! form-sched-line-USD-total (gnc-numeric-zero)) (set! form-sched-line-USD-total (gnc-numeric-zero))
(if tax-mode? (if tax-mode?
@ -2738,7 +2741,7 @@
(xaccPrintAmount (xaccPrintAmount
form-sched-line-cap-gain-sales-USD-total form-sched-line-cap-gain-sales-USD-total
print-info)) print-info))
) )
;; print prior form-schedule-line total ;; print prior form-schedule-line total
;; and reset accum ;; and reset accum
(render-total-row (render-total-row
@ -2835,7 +2838,7 @@
"" ""
(string-append "Line " (string-append "Line "
current-form-sched-line ": ")) current-form-sched-line ": "))
description " (" description " ("
(substring current-tax-code 1 (substring current-tax-code 1
(string-length current-tax-code)) (string-length current-tax-code))
(if show-TXF-data? (if show-TXF-data?
@ -2854,7 +2857,7 @@
"Y" "Y"
"N") "N")
", TXF Format " ", TXF Format "
(number->string (number->string
(get-acct-txf-info (get-acct-txf-info
'format 'format
type type
@ -2989,7 +2992,7 @@
)) ))
(if (not tax-mode?) ; Do Txf mode (if (not tax-mode?) ; Do Txf mode
(if tax-entity-type-valid? (if tax-entity-type-valid?
(if file-name ; cancel TXF if no file selected (if file-name ; cancel TXF if no file selected
(let ((port (catch #t ;;e.g., system-error (let ((port (catch #t ;;e.g., system-error
(lambda () (open-output-file file-name)) (lambda () (open-output-file file-name))
@ -3018,7 +3021,7 @@
today-date crlf today-date crlf
"^" crlf "^" crlf
output output
(if (or (if (or
(gnc-numeric-zero-p tax-code-USD-total) (gnc-numeric-zero-p tax-code-USD-total)
(not prior-account)) (not prior-account))
'() '()
@ -3050,7 +3053,7 @@
(if prior-account (if prior-account
(gnc:display-report-list-item output-txf port (gnc:display-report-list-item output-txf port
"taxtxf.scm - ") "taxtxf.scm - ")
#f) #f)
(close-output-port port) (close-output-port port)
#t #t
) ; end of let ) ; end of let
@ -3173,8 +3176,8 @@
(gnc:html-document-set-title! doc report-name) (gnc:html-document-set-title! doc report-name)
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc (gnc:make-html-text doc (gnc:make-html-text
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup (gnc:html-markup
"center" "center"
@ -3199,8 +3202,8 @@
(if (not (null? txf-invalid-alist)) (if (not (null? txf-invalid-alist))
(begin (begin
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc (gnc:make-html-text doc (gnc:make-html-text
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
"<BR>The following Account(s) have errors with their Income Tax code assignments (use 'Edit->Tax Report Options' to correct):")))) "<BR>The following Account(s) have errors with their Income Tax code assignments (use 'Edit->Tax Report Options' to correct):"))))
@ -3262,8 +3265,8 @@
) )
) )
txf-invalid-alist) txf-invalid-alist)
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc (gnc:make-html-text doc (gnc:make-html-text
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
" <BR> ")))) " <BR> "))))
@ -3272,7 +3275,7 @@
(gnc:html-document-add-object! doc table) (gnc:html-document-add-object! doc table)
(if tax-entity-type-valid? (if tax-entity-type-valid?
(map (lambda (form-line-acct) (handle-tax-code form-line-acct)) (map (lambda (form-line-acct) (handle-tax-code form-line-acct))
selected-accounts-sorted-by-form-line-acct)) selected-accounts-sorted-by-form-line-acct))
@ -3307,7 +3310,7 @@
(tax-code-sub-item-total-amount (tax-code-sub-item-total-amount
(xaccPrintAmount tax-code-sub-item-USD-total (xaccPrintAmount tax-code-sub-item-USD-total
print-info)) print-info))
) )
(render-total-row (render-total-row
table table
tax-code-sub-item-total-amount tax-code-sub-item-total-amount
@ -3360,7 +3363,7 @@
(xaccPrintAmount (xaccPrintAmount
tax-code-cap-gain-basis-USD-total tax-code-cap-gain-basis-USD-total
print-info)) print-info))
) )
(render-total-row table tax-code-total-amount (render-total-row table tax-code-total-amount
(string-append "Line (Code): " (string-append "Line (Code): "
saved-tax-code-text) saved-tax-code-text)
@ -3405,7 +3408,7 @@
(xaccPrintAmount (xaccPrintAmount
form-sched-line-cap-gain-basis-USD-total form-sched-line-cap-gain-basis-USD-total
print-info)) print-info))
) )
;; print prior form-schedule-line total; reset accum ;; print prior form-schedule-line total; reset accum
(render-total-row (render-total-row
table table
@ -3452,8 +3455,8 @@
"The Income Tax Report is only available for valid Income Tax Entity Types. Go to the Edit->Tax Report Options dialog to change your Income Tax Entity Type selection and set up tax-related accounts." "The Income Tax Report is only available for valid Income Tax Entity Types. Go to the Edit->Tax Report Options dialog to change your Income Tax Entity Type selection and set up tax-related accounts."
"No Tax Related accounts were found with your account selection. Change your selection or go to the Edit->Tax Report Options dialog to set up tax-related accounts.")))) "No Tax Related accounts were found with your account selection. Change your selection or go to the Edit->Tax Report Options dialog to set up tax-related accounts."))))
;; or print selected report options ;; or print selected report options
(gnc:html-document-add-object! (gnc:html-document-add-object!
doc (gnc:make-html-text doc (gnc:make-html-text
(gnc:html-markup-p (gnc:html-markup-p
(gnc:html-markup/format (gnc:html-markup/format
(string-append (string-append

344
src/report/standard-reports/advanced-portfolio.scm
View File

@ -6,16 +6,16 @@
;; Heavily based on portfolio.scm ;; Heavily based on portfolio.scm
;; by Robert Merkel (rgmerk@mira.net) ;; by Robert Merkel (rgmerk@mira.net)
;; ;;
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of ;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version. ;; the License, or (at your option) any later version.
;; ;;
;; This program is distributed in the hope that it will be useful, ;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details. ;; GNU General Public License for more details.
;; ;;
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact: ;; along with this program; if not, contact:
;; ;;
@ -54,34 +54,34 @@
(define units-denom 100000000) (define units-denom 100000000)
(define (options-generator) (define (options-generator)
(let* ((options (gnc:new-options)) (let* ((options (gnc:new-options))
;; This is just a helper function for making options. ;; This is just a helper function for making options.
;; See gnucash/src/scm/options.scm for details. ;; See gnucash/src/scm/options.scm for details.
(add-option (add-option
(lambda (new-option) (lambda (new-option)
(gnc:register-option options new-option)))) (gnc:register-option options new-option))))
;; General Tab ;; General Tab
;; date at which to report balance ;; date at which to report balance
(gnc:options-add-report-date! (gnc:options-add-report-date!
options gnc:pagename-general options gnc:pagename-general
(N_ "Date") "a") (N_ "Date") "a")
(gnc:options-add-currency! (gnc:options-add-currency!
options gnc:pagename-general (N_ "Report's currency") "c") options gnc:pagename-general (N_ "Report's currency") "c")
(add-option (add-option
(gnc:make-multichoice-option (gnc:make-multichoice-option
gnc:pagename-general optname-price-source gnc:pagename-general optname-price-source
"d" (N_ "The source of price information.") 'pricedb-nearest "d" (N_ "The source of price information.") 'pricedb-nearest
(list (vector 'pricedb-latest (list (vector 'pricedb-latest
(N_ "Most recent") (N_ "Most recent")
(N_ "The most recent recorded price.")) (N_ "The most recent recorded price."))
(vector 'pricedb-nearest (vector 'pricedb-nearest
(N_ "Nearest in time") (N_ "Nearest in time")
(N_ "The price recorded nearest in time to the report date.")) (N_ "The price recorded nearest in time to the report date."))
))) )))
(add-option (add-option
(gnc:make-multichoice-option (gnc:make-multichoice-option
gnc:pagename-general optname-basis-method gnc:pagename-general optname-basis-method
@ -99,7 +99,7 @@
(add-option (add-option
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
gnc:pagename-general optname-prefer-pricelist "f" gnc:pagename-general optname-prefer-pricelist "f"
(N_ "Prefer use of price editor pricing over transactions, where applicable.") (N_ "Prefer use of price editor pricing over transactions, where applicable.")
#t)) #t))
@ -117,7 +117,7 @@
(N_ "Ignore") (N_ "Ignore")
(N_ "Ignore brokerage fees entirely.")) (N_ "Ignore brokerage fees entirely."))
))) )))
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
@ -161,18 +161,18 @@
(lambda () (filter gnc:account-is-stock? (lambda () (filter gnc:account-is-stock?
(gnc-account-get-descendants-sorted (gnc-account-get-descendants-sorted
(gnc-get-current-root-account)))) (gnc-get-current-root-account))))
(lambda (accounts) (list #t (lambda (accounts) (list #t
(filter gnc:account-is-stock? accounts))) (filter gnc:account-is-stock? accounts)))
#t)) #t))
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
gnc:pagename-accounts optname-zero-shares "e" gnc:pagename-accounts optname-zero-shares "e"
(N_ "Include accounts that have a zero share balances.") (N_ "Include accounts that have a zero share balances.")
#f)) #f))
(gnc:options-set-default-section options gnc:pagename-general) (gnc:options-set-default-section options gnc:pagename-general)
options)) options))
;; This is the rendering function. It accepts a database of options ;; This is the rendering function. It accepts a database of options
@ -183,7 +183,7 @@
;; defined above. ;; defined above.
(define (advanced-portfolio-renderer report-obj) (define (advanced-portfolio-renderer report-obj)
(let ((work-done 0) (let ((work-done 0)
(work-to-do 0) (work-to-do 0)
(warn-no-price #f) (warn-no-price #f)
@ -192,10 +192,10 @@
;; These are some helper functions for looking up option values. ;; These are some helper functions for looking up option values.
(define (get-op section name) (define (get-op section name)
(gnc:lookup-option (gnc:report-options report-obj) section name)) (gnc:lookup-option (gnc:report-options report-obj) section name))
(define (get-option section name) (define (get-option section name)
(gnc:option-value (get-op section name))) (gnc:option-value (get-op section name)))
(define (split-account-type? split type) (define (split-account-type? split type)
(eq? type (xaccAccountGetType (xaccSplitGetAccount split)))) (eq? type (xaccAccountGetType (xaccSplitGetAccount split))))
@ -213,11 +213,11 @@
(gnc-numeric-zero) (gnc-numeric-zero)
) )
) )
;; sum up the total number of units in the b-list built by basis-builder below ;; sum up the total number of units in the b-list built by basis-builder below
(define (units-basis b-list) (define (units-basis b-list)
(if (not (eqv? b-list '())) (if (not (eqv? b-list '()))
(gnc-numeric-add (caar b-list) (units-basis (cdr b-list)) (gnc-numeric-add (caar b-list) (units-basis (cdr b-list))
units-denom GNC-RND-ROUND) units-denom GNC-RND-ROUND)
(gnc-numeric-zero) (gnc-numeric-zero)
) )
@ -231,42 +231,42 @@
(gnc-numeric-mul value-ratio (cdar b-list) price-denom GNC-RND-ROUND)) (gnc-numeric-mul value-ratio (cdar b-list) price-denom GNC-RND-ROUND))
(apply-basis-ratio (cdr b-list) units-ratio value-ratio)) (apply-basis-ratio (cdr b-list) units-ratio value-ratio))
'() '()
) )
) )
;; this builds a list for basis calculation and handles average, fifo and lifo methods ;; this builds a list for basis calculation and handles average, fifo and lifo methods
;; the list is cons cells of (units-of-stock . price-per-unit)... average method produces only one ;; the list is cons cells of (units-of-stock . price-per-unit)... average method produces only one
;; cell that mutates to the new average. Need to add a date checker so that we allow for prices ;; cell that mutates to the new average. Need to add a date checker so that we allow for prices
;; coming in out of order, such as a transfer with a price adjusted to carryover the basis. ;; coming in out of order, such as a transfer with a price adjusted to carryover the basis.
(define (basis-builder b-list b-units b-value b-method currency-frac) (define (basis-builder b-list b-units b-value b-method currency-frac)
(gnc:debug "actually in basis-builder") (gnc:debug "actually in basis-builder")
(gnc:debug "b-list is " b-list " b-units is " (gnc-numeric-to-string b-units) (gnc:debug "b-list is " b-list " b-units is " (gnc-numeric-to-string b-units)
" b-value is " (gnc-numeric-to-string b-value) " b-method is " b-method) " b-value is " (gnc-numeric-to-string b-value) " b-method is " b-method)
;; if there is no b-value, then this is a split/merger and needs special handling ;; if there is no b-value, then this is a split/merger and needs special handling
(cond (cond
;; we have value and positive units, add units to basis ;; we have value and positive units, add units to basis
((and (not (gnc-numeric-zero-p b-value)) ((and (not (gnc-numeric-zero-p b-value))
(gnc-numeric-positive-p b-units)) (gnc-numeric-positive-p b-units))
(case b-method (case b-method
((average-basis) ((average-basis)
(if (not (eqv? b-list '())) (if (not (eqv? b-list '()))
(list (cons (gnc-numeric-add b-units (list (cons (gnc-numeric-add b-units
(caar b-list) units-denom GNC-RND-ROUND) (caar b-list) units-denom GNC-RND-ROUND)
(gnc-numeric-div (gnc-numeric-div
(gnc-numeric-add b-value (gnc-numeric-add b-value
(gnc-numeric-mul (caar b-list) (gnc-numeric-mul (caar b-list)
(cdar b-list) (cdar b-list)
GNC-DENOM-AUTO GNC-DENOM-REDUCE) GNC-DENOM-AUTO GNC-DENOM-REDUCE)
GNC-DENOM-AUTO GNC-DENOM-REDUCE) GNC-DENOM-AUTO GNC-DENOM-REDUCE)
(gnc-numeric-add b-units (gnc-numeric-add b-units
(caar b-list) GNC-DENOM-AUTO GNC-DENOM-REDUCE) (caar b-list) GNC-DENOM-AUTO GNC-DENOM-REDUCE)
price-denom GNC-RND-ROUND))) price-denom GNC-RND-ROUND)))
(append b-list (append b-list
(list (cons b-units (gnc-numeric-div (list (cons b-units (gnc-numeric-div
b-value b-units price-denom GNC-RND-ROUND)))))) b-value b-units price-denom GNC-RND-ROUND))))))
(else (append b-list (else (append b-list
(list (cons b-units (gnc-numeric-div (list (cons b-units (gnc-numeric-div
b-value b-units price-denom GNC-RND-ROUND))))))) b-value b-units price-denom GNC-RND-ROUND)))))))
@ -275,7 +275,7 @@
(gnc-numeric-negative-p b-units)) (gnc-numeric-negative-p b-units))
(if (not (eqv? b-list '())) (if (not (eqv? b-list '()))
(case b-method (case b-method
((fifo-basis) ((fifo-basis)
(case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar b-list)) (case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar b-list))
((-1) ((-1)
;; Sold less than the first lot, create a new first lot from the remainder ;; Sold less than the first lot, create a new first lot from the remainder
@ -284,12 +284,12 @@
((0) ((0)
;; Sold all of the first lot ;; Sold all of the first lot
(cdr b-list)) (cdr b-list))
((1) ((1)
;; Sold more than the first lot, delete it and recurse ;; Sold more than the first lot, delete it and recurse
(basis-builder (cdr b-list) (gnc-numeric-add b-units (caar b-list) units-denom GNC-RND-ROUND) (basis-builder (cdr b-list) (gnc-numeric-add b-units (caar b-list) units-denom GNC-RND-ROUND)
b-value ;; Only the sign of b-value matters since the new b-units is negative b-value ;; Only the sign of b-value matters since the new b-units is negative
b-method currency-frac)))) b-method currency-frac))))
((filo-basis) ((filo-basis)
(let ((rev-b-list (reverse b-list))) (let ((rev-b-list (reverse b-list)))
(case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar rev-b-list)) (case (gnc-numeric-compare (gnc-numeric-abs b-units) (caar rev-b-list))
((-1) ((-1)
@ -305,29 +305,29 @@
(basis-builder (reverse (cdr rev-b-list)) (gnc-numeric-add b-units (caar rev-b-list) units-denom GNC-RND-ROUND) (basis-builder (reverse (cdr rev-b-list)) (gnc-numeric-add b-units (caar rev-b-list) units-denom GNC-RND-ROUND)
b-value b-method currency-frac) b-value b-method currency-frac)
)))) ))))
((average-basis) ((average-basis)
(list (cons (gnc-numeric-add (list (cons (gnc-numeric-add
(caar b-list) b-units units-denom GNC-RND-ROUND) (caar b-list) b-units units-denom GNC-RND-ROUND)
(cdar b-list))))) (cdar b-list)))))
'() '()
)) ))
;; no value, just units, this is a split/merge... ;; no value, just units, this is a split/merge...
((and (gnc-numeric-zero-p b-value) ((and (gnc-numeric-zero-p b-value)
(not (gnc-numeric-zero-p b-units))) (not (gnc-numeric-zero-p b-units)))
(let* ((current-units (units-basis b-list)) (let* ((current-units (units-basis b-list))
(units-ratio (gnc-numeric-div (gnc-numeric-add b-units current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE) (units-ratio (gnc-numeric-div (gnc-numeric-add b-units current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE)
current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE)) current-units GNC-DENOM-AUTO GNC-DENOM-REDUCE))
;; If the units ratio is zero the stock is worthless and the value should be zero too ;; If the units ratio is zero the stock is worthless and the value should be zero too
(value-ratio (if (gnc-numeric-zero-p units-ratio) (value-ratio (if (gnc-numeric-zero-p units-ratio)
(gnc-numeric-zero) (gnc-numeric-zero)
(gnc-numeric-div (gnc:make-gnc-numeric 1 1) units-ratio GNC-DENOM-AUTO GNC-DENOM-REDUCE)))) (gnc-numeric-div (gnc:make-gnc-numeric 1 1) units-ratio GNC-DENOM-AUTO GNC-DENOM-REDUCE))))
(gnc:debug "blist is " b-list " current units is " (gnc:debug "blist is " b-list " current units is "
(gnc-numeric-to-string current-units) (gnc-numeric-to-string current-units)
" value ratio is " (gnc-numeric-to-string value-ratio) " value ratio is " (gnc-numeric-to-string value-ratio)
" units ratio is " (gnc-numeric-to-string units-ratio)) " units ratio is " (gnc-numeric-to-string units-ratio))
(apply-basis-ratio b-list units-ratio value-ratio) (apply-basis-ratio b-list units-ratio value-ratio)
)) ))
;; If there are no units, just a value, then its a spin-off, ;; If there are no units, just a value, then its a spin-off,
@ -336,9 +336,9 @@
((and (gnc-numeric-zero-p b-units) ((and (gnc-numeric-zero-p b-units)
(not (gnc-numeric-zero-p b-value))) (not (gnc-numeric-zero-p b-value)))
(let* ((current-value (sum-basis b-list GNC-DENOM-AUTO)) (let* ((current-value (sum-basis b-list GNC-DENOM-AUTO))
(value-ratio (gnc-numeric-div (gnc-numeric-add b-value current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE) (value-ratio (gnc-numeric-div (gnc-numeric-add b-value current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE)
current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE))) current-value GNC-DENOM-AUTO GNC-DENOM-REDUCE)))
(gnc:debug "this is a spinoff") (gnc:debug "this is a spinoff")
(gnc:debug "blist is " b-list " value ratio is " (gnc-numeric-to-string value-ratio)) (gnc:debug "blist is " b-list " value ratio is " (gnc-numeric-to-string value-ratio))
(apply-basis-ratio b-list (gnc:make-gnc-numeric 1 1) value-ratio)) (apply-basis-ratio b-list (gnc:make-gnc-numeric 1 1) value-ratio))
@ -359,20 +359,22 @@
(for-each (for-each
(lambda (p) (lambda (p)
(if (gnc-commodity-equiv currency (gnc-price-get-currency p)) (if (gnc-commodity-equiv currency (gnc-price-get-currency p))
(set! price p))) (set! price p))
(if (gnc-commodity-equiv currency (gnc-price-get-commodity p))
(set! price (gnc-price-invert p))))
price-list) price-list)
(gnc-price-ref price) (gnc-price-ref price)
(gnc-price-list-destroy price-list) (gnc-price-list-destroy price-list)
price))) price)))
;; Return true if either account is the parent of the other or they are siblings ;; Return true if either account is the parent of the other or they are siblings
(define (parent-or-sibling? a1 a2) (define (parent-or-sibling? a1 a2)
(let ((a2parent (gnc-account-get-parent a2)) (let ((a2parent (gnc-account-get-parent a2))
(a1parent (gnc-account-get-parent a1))) (a1parent (gnc-account-get-parent a1)))
(or (same-account? a2parent a1) (or (same-account? a2parent a1)
(same-account? a1parent a2) (same-account? a1parent a2)
(same-account? a1parent a2parent)))) (same-account? a1parent a2parent))))
;; Test whether the given split is the source of a spin off transaction ;; Test whether the given split is the source of a spin off transaction
;; This will be a no-units split with only one other split. ;; This will be a no-units split with only one other split.
;; xaccSplitGetOtherSplit only returns on a two-split txn. It's not a spinoff ;; xaccSplitGetOtherSplit only returns on a two-split txn. It's not a spinoff
@ -384,21 +386,21 @@
(not (null? other-split)) (not (null? other-split))
(not (split-account-type? other-split ACCT-TYPE-EXPENSE)) (not (split-account-type? other-split ACCT-TYPE-EXPENSE))
(not (split-account-type? other-split ACCT-TYPE-INCOME))))) (not (split-account-type? other-split ACCT-TYPE-INCOME)))))
(define (table-add-stock-rows table accounts to-date (define (table-add-stock-rows table accounts to-date
currency price-fn exchange-fn price-source currency price-fn exchange-fn price-source
include-empty show-symbol show-listing show-shares show-price include-empty show-symbol show-listing show-shares show-price
basis-method prefer-pricelist handle-brokerage-fees basis-method prefer-pricelist handle-brokerage-fees
total-basis total-value total-basis total-value
total-moneyin total-moneyout total-income total-gain total-moneyin total-moneyout total-income total-gain
total-ugain total-brokerage) total-ugain total-brokerage)
(let ((share-print-info (let ((share-print-info
(gnc-share-print-info-places (gnc-share-print-info-places
(inexact->exact (get-option gnc:pagename-display (inexact->exact (get-option gnc:pagename-display
optname-shares-digits))))) optname-shares-digits)))))
(define (table-add-stock-rows-internal accounts odd-row?) (define (table-add-stock-rows-internal accounts odd-row?)
(if (null? accounts) total-value (if (null? accounts) total-value
(let* ((row-style (if odd-row? "normal-row" "alternate-row")) (let* ((row-style (if odd-row? "normal-row" "alternate-row"))
@ -447,7 +449,7 @@
(exchange-fn (exchange-fn
;; This currency will usually be the same as tocurrency so the ;; This currency will usually be the same as tocurrency so the
;; call to exchange-fn below will do nothing ;; call to exchange-fn below will do nothing
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
(if use-txn (if use-txn
(gnc:gnc-monetary-commodity price) (gnc:gnc-monetary-commodity price)
(gnc-price-get-currency price)) (gnc-price-get-currency price))
@ -458,30 +460,30 @@
currency-frac GNC-RND-ROUND)) currency-frac GNC-RND-ROUND))
tocurrency) tocurrency)
(exchange-fn fromunits tocurrency))) (exchange-fn fromunits tocurrency)))
(gnc:debug "Starting account " (xaccAccountGetName current) ", initial price: " (gnc:debug "Starting account " (xaccAccountGetName current) ", initial price: "
(if price (if price
(gnc-commodity-value->string (gnc-commodity-value->string
(list (gnc-price-get-currency price) (gnc-price-get-value price))) (list (gnc-price-get-currency price) (gnc-price-get-value price)))
#f)) #f))
;; If we have a price that can't be converted to the report currency ;; If we have a price that can't be converted to the report currency
;; don't use it ;; don't use it
(if (and price (gnc-numeric-zero-p (gnc:gnc-monetary-amount (if (and price (gnc-numeric-zero-p (gnc:gnc-monetary-amount
(exchange-fn (exchange-fn
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
(gnc-price-get-currency price) (gnc-price-get-currency price)
(gnc:make-gnc-numeric 100 1)) (gnc:make-gnc-numeric 100 1))
currency)))) currency))))
(set! price #f)) (set! price #f))
;; If we are told to use a pricing transaction, or if we don't have a price ;; If we are told to use a pricing transaction, or if we don't have a price
;; from the price DB, find a good transaction to use. ;; from the price DB, find a good transaction to use.
(if (and (not use-txn) (if (and (not use-txn)
(or (not price) (not prefer-pricelist))) (or (not price) (not prefer-pricelist)))
(let ((split-list (reverse (gnc:get-match-commodity-splits-sorted (let ((split-list (reverse (gnc:get-match-commodity-splits-sorted
(list current) (list current)
(case price-source (case price-source
((pricedb-latest) (gnc:get-today)) ((pricedb-latest) (gnc:get-today))
((pricedb-nearest) to-date) ((pricedb-nearest) to-date)
(else (gnc:get-today))) ;; error, but don't crash (else (gnc:get-today))) ;; error, but don't crash
@ -494,7 +496,7 @@
(let* ((trans (xaccSplitGetParent split)) (let* ((trans (xaccSplitGetParent split))
(trans-currency (xaccTransGetCurrency trans)) (trans-currency (xaccTransGetCurrency trans))
(trans-price (exchange-fn (gnc:make-gnc-monetary (trans-price (exchange-fn (gnc:make-gnc-monetary
trans-currency trans-currency
(xaccSplitGetSharePrice split)) (xaccSplitGetSharePrice split))
currency))) currency)))
(if (not (gnc-numeric-zero-p (gnc:gnc-monetary-amount trans-price))) (if (not (gnc-numeric-zero-p (gnc:gnc-monetary-amount trans-price)))
@ -517,13 +519,13 @@
(set! use-txn #t) (set! use-txn #t)
(set! pricing-txn #f) (set! pricing-txn #f)
) )
) )
;; Now that we have a pricing transaction if needed, set the value of the asset ;; Now that we have a pricing transaction if needed, set the value of the asset
(set! value (my-exchange-fn (gnc:make-gnc-monetary commodity units) currency)) (set! value (my-exchange-fn (gnc:make-gnc-monetary commodity units) currency))
(gnc:debug "Value " (gnc:monetary->string value) (gnc:debug "Value " (gnc:monetary->string value)
" from " (gnc-commodity-numeric->string commodity units)) " from " (gnc-commodity-numeric->string commodity units))
(for-each (for-each
;; we're looking at each split we find in the account. these splits ;; we're looking at each split we find in the account. these splits
;; could refer to the same transaction, so we have to examine each ;; could refer to the same transaction, so we have to examine each
@ -531,12 +533,12 @@
(lambda (split) (lambda (split)
(set! work-done (+ 1 work-done)) (set! work-done (+ 1 work-done))
(gnc:report-percent-done (* 100 (/ work-done work-to-do))) (gnc:report-percent-done (* 100 (/ work-done work-to-do)))
(let* ((parent (xaccSplitGetParent split)) (let* ((parent (xaccSplitGetParent split))
(txn-date (gnc-transaction-get-date-posted parent)) (txn-date (gnc-transaction-get-date-posted parent))
(commod-currency (xaccTransGetCurrency parent)) (commod-currency (xaccTransGetCurrency parent))
(commod-currency-frac (gnc-commodity-get-fraction commod-currency))) (commod-currency-frac (gnc-commodity-get-fraction commod-currency)))
(if (and (gnc:timepair-le txn-date to-date) (if (and (gnc:timepair-le txn-date to-date)
(not (assoc-ref seen_trans (gncTransGetGUID parent)))) (not (assoc-ref seen_trans (gncTransGetGUID parent))))
(let ((trans-income (gnc-numeric-zero)) (let ((trans-income (gnc-numeric-zero))
@ -553,30 +555,30 @@
;; Add this transaction to the list of processed transactions so we don't ;; Add this transaction to the list of processed transactions so we don't
;; do it again if there is another split in it for this account ;; do it again if there is another split in it for this account
(set! seen_trans (acons (gncTransGetGUID parent) #t seen_trans)) (set! seen_trans (acons (gncTransGetGUID parent) #t seen_trans))
;; Go through all the splits in the transaction to get an overall idea of ;; Go through all the splits in the transaction to get an overall idea of
;; what it does in terms of income, money in or out, shares bought or sold, etc. ;; what it does in terms of income, money in or out, shares bought or sold, etc.
(for-each (for-each
(lambda (s) (lambda (s)
(let ((split-units (xaccSplitGetAmount s)) (let ((split-units (xaccSplitGetAmount s))
(split-value (xaccSplitGetValue s))) (split-value (xaccSplitGetValue s)))
(gnc:debug "Pass 1: split units " (gnc-numeric-to-string split-units) " split-value " (gnc:debug "Pass 1: split units " (gnc-numeric-to-string split-units) " split-value "
(gnc-numeric-to-string split-value) " commod-currency " (gnc-numeric-to-string split-value) " commod-currency "
(gnc-commodity-get-printname commod-currency)) (gnc-commodity-get-printname commod-currency))
(cond (cond
((split-account-type? s ACCT-TYPE-EXPENSE) ((split-account-type? s ACCT-TYPE-EXPENSE)
;; Brokerage expense unless a two split transaction with other split ;; Brokerage expense unless a two split transaction with other split
;; in the stock account in which case it's a stock donation to charity. ;; in the stock account in which case it's a stock donation to charity.
(if (not (same-account? current (xaccSplitGetAccount (xaccSplitGetOtherSplit s)))) (if (not (same-account? current (xaccSplitGetAccount (xaccSplitGetOtherSplit s))))
(set! trans-brokerage (set! trans-brokerage
(gnc-numeric-add trans-brokerage split-value commod-currency-frac GNC-RND-ROUND)))) (gnc-numeric-add trans-brokerage split-value commod-currency-frac GNC-RND-ROUND))))
((split-account-type? s ACCT-TYPE-INCOME) ((split-account-type? s ACCT-TYPE-INCOME)
(set! trans-income (gnc-numeric-sub trans-income split-value (set! trans-income (gnc-numeric-sub trans-income split-value
commod-currency-frac GNC-RND-ROUND))) commod-currency-frac GNC-RND-ROUND)))
((same-account? current (xaccSplitGetAccount s)) ((same-account? current (xaccSplitGetAccount s))
(set! trans-shares (gnc-numeric-add trans-shares (gnc-numeric-abs split-units) (set! trans-shares (gnc-numeric-add trans-shares (gnc-numeric-abs split-units)
units-denom GNC-RND-ROUND)) units-denom GNC-RND-ROUND))
@ -590,7 +592,7 @@
;; Gain/loss split (amount zero, value non-zero, and not spinoff). There will be ;; Gain/loss split (amount zero, value non-zero, and not spinoff). There will be
;; a corresponding income split that will incorrectly be added to trans-income ;; a corresponding income split that will incorrectly be added to trans-income
;; Fix that by subtracting it here ;; Fix that by subtracting it here
(set! trans-income (gnc-numeric-sub trans-income split-value (set! trans-income (gnc-numeric-sub trans-income split-value
commod-currency-frac GNC-RND-ROUND)))) commod-currency-frac GNC-RND-ROUND))))
;; Non-zero amount, add the value to the sale or purchase total. ;; Non-zero amount, add the value to the sale or purchase total.
(if (gnc-numeric-positive-p split-value) (if (gnc-numeric-positive-p split-value)
@ -601,9 +603,9 @@
(gnc-numeric-add shares-bought split-units units-denom GNC-RND-ROUND))) (gnc-numeric-add shares-bought split-units units-denom GNC-RND-ROUND)))
(set! trans-sold (set! trans-sold
(gnc-numeric-sub trans-sold split-value commod-currency-frac GNC-RND-ROUND))))) (gnc-numeric-sub trans-sold split-value commod-currency-frac GNC-RND-ROUND)))))
((split-account-type? s ACCT-TYPE-ASSET) ((split-account-type? s ACCT-TYPE-ASSET)
;; If all the asset accounts mentioned in the transaction are siblings of each other ;; If all the asset accounts mentioned in the transaction are siblings of each other
;; keep track of the money transfered to them if it is in the correct currency ;; keep track of the money transfered to them if it is in the correct currency
(if (not trans-drp-account) (if (not trans-drp-account)
(begin (begin
@ -619,7 +621,7 @@
)) ))
(xaccTransGetSplitList parent) (xaccTransGetSplitList parent)
) )
(gnc:debug "Income: " (gnc-numeric-to-string trans-income) (gnc:debug "Income: " (gnc-numeric-to-string trans-income)
" Brokerage: " (gnc-numeric-to-string trans-brokerage) " Brokerage: " (gnc-numeric-to-string trans-brokerage)
" Shares traded: " (gnc-numeric-to-string trans-shares) " Shares traded: " (gnc-numeric-to-string trans-shares)
@ -628,10 +630,10 @@
" Value purchased: " (gnc-numeric-to-string trans-bought) " Value purchased: " (gnc-numeric-to-string trans-bought)
" Spinoff value " (gnc-numeric-to-string trans-spinoff) " Spinoff value " (gnc-numeric-to-string trans-spinoff)
" Trans DRP residual: " (gnc-numeric-to-string trans-drp-residual)) " Trans DRP residual: " (gnc-numeric-to-string trans-drp-residual))
;; We need to calculate several things for this transaction: ;; We need to calculate several things for this transaction:
;; 1. Total income: this is already in trans-income ;; 1. Total income: this is already in trans-income
;; 2. Change in basis: calculated by loop below that looks at every ;; 2. Change in basis: calculated by loop below that looks at every
;; that acquires or disposes of shares ;; that acquires or disposes of shares
;; 3. Realized gain: also calculated below while calculating basis ;; 3. Realized gain: also calculated below while calculating basis
;; 4. Money in to the account: this is the value of shares bought ;; 4. Money in to the account: this is the value of shares bought
@ -639,22 +641,22 @@
;; 5. Money out: the money received by disposing of shares. This ;; 5. Money out: the money received by disposing of shares. This
;; is in trans-sold plus trans-spinoff ;; is in trans-sold plus trans-spinoff
;; 6. Brokerage fees: this is in trans-brokerage ;; 6. Brokerage fees: this is in trans-brokerage
;; Income ;; Income
(dividendcoll 'add commod-currency trans-income) (dividendcoll 'add commod-currency trans-income)
;; Brokerage fees. May be either ignored or part of basis, but that ;; Brokerage fees. May be either ignored or part of basis, but that
;; will be dealt with elsewhere. ;; will be dealt with elsewhere.
(brokeragecoll 'add commod-currency trans-brokerage) (brokeragecoll 'add commod-currency trans-brokerage)
;; Add brokerage fees to trans-bought if not ignoring them and there are any ;; Add brokerage fees to trans-bought if not ignoring them and there are any
(if (and (not (eq? handle-brokerage-fees 'ignore-brokerage)) (if (and (not (eq? handle-brokerage-fees 'ignore-brokerage))
(gnc-numeric-positive-p trans-brokerage) (gnc-numeric-positive-p trans-brokerage)
(gnc-numeric-positive-p trans-shares)) (gnc-numeric-positive-p trans-shares))
(let* ((fee-frac (gnc-numeric-div shares-bought trans-shares GNC-DENOM-AUTO GNC-DENOM-REDUCE)) (let* ((fee-frac (gnc-numeric-div shares-bought trans-shares GNC-DENOM-AUTO GNC-DENOM-REDUCE))
(fees (gnc-numeric-mul trans-brokerage fee-frac commod-currency-frac GNC-RND-ROUND))) (fees (gnc-numeric-mul trans-brokerage fee-frac commod-currency-frac GNC-RND-ROUND)))
(set! trans-bought (gnc-numeric-add trans-bought fees commod-currency-frac GNC-RND-ROUND)))) (set! trans-bought (gnc-numeric-add trans-bought fees commod-currency-frac GNC-RND-ROUND))))
;; Update the running total of the money in the DRP residual account. This is relevant ;; Update the running total of the money in the DRP residual account. This is relevant
;; if this is a reinvestment transaction (both income and purchase) and there seems to ;; if this is a reinvestment transaction (both income and purchase) and there seems to
;; asset accounts used to hold excess income. ;; asset accounts used to hold excess income.
@ -670,12 +672,12 @@
(parent-or-sibling? trans-drp-account drp-holding-account)) (parent-or-sibling? trans-drp-account drp-holding-account))
(set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-drp-residual (set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-drp-residual
commod-currency-frac GNC-RND-ROUND)) commod-currency-frac GNC-RND-ROUND))
(begin (begin
;; Wrong account (or no account), assume there isn't a DRP holding account ;; Wrong account (or no account), assume there isn't a DRP holding account
(set! drp-holding-account 'none) (set! drp-holding-account 'none)
(set trans-drp-residual (gnc-numeric-zero)) (set trans-drp-residual (gnc-numeric-zero))
(set! drp-holding-amount (gnc-numeric-zero)))))) (set! drp-holding-amount (gnc-numeric-zero))))))
;; Set trans-bought to the amount of money moved in to the account which was used to ;; Set trans-bought to the amount of money moved in to the account which was used to
;; purchase more shares. If this is not a DRP transaction then all money used to purchase ;; purchase more shares. If this is not a DRP transaction then all money used to purchase
;; shares is money in. ;; shares is money in.
@ -691,21 +693,21 @@
;; If the DRP holding account balance is negative, adjust it by the amount ;; If the DRP holding account balance is negative, adjust it by the amount
;; used in this transaction ;; used in this transaction
(if (and (gnc-numeric-negative-p drp-holding-amount) (if (and (gnc-numeric-negative-p drp-holding-amount)
(gnc-numeric-positive-p trans-bought)) (gnc-numeric-positive-p trans-bought))
(set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-bought (set! drp-holding-amount (gnc-numeric-add drp-holding-amount trans-bought
commod-currency-frac GNC-RND-ROUND))) commod-currency-frac GNC-RND-ROUND)))
;; Money in is never more than amount spent to purchase shares ;; Money in is never more than amount spent to purchase shares
(if (gnc-numeric-negative-p trans-bought) (if (gnc-numeric-negative-p trans-bought)
(set! trans-bought (gnc-numeric-zero))))) (set! trans-bought (gnc-numeric-zero)))))
(gnc:debug "Adjusted trans-bought " (gnc-numeric-to-string trans-bought) (gnc:debug "Adjusted trans-bought " (gnc-numeric-to-string trans-bought)
" DRP holding account " (gnc-numeric-to-string drp-holding-amount)) " DRP holding account " (gnc-numeric-to-string drp-holding-amount))
(moneyincoll 'add commod-currency trans-bought) (moneyincoll 'add commod-currency trans-bought)
(moneyoutcoll 'add commod-currency trans-sold) (moneyoutcoll 'add commod-currency trans-sold)
(moneyoutcoll 'add commod-currency trans-spinoff) (moneyoutcoll 'add commod-currency trans-spinoff)
;; Look at splits again to handle changes in basis and realized gains ;; Look at splits again to handle changes in basis and realized gains
(for-each (for-each
(lambda (s) (lambda (s)
(let (let
@ -713,30 +715,30 @@
((split-units (xaccSplitGetAmount s)) ((split-units (xaccSplitGetAmount s))
(split-value (xaccSplitGetValue s))) (split-value (xaccSplitGetValue s)))
(gnc:debug "Pass 2: split units " (gnc-numeric-to-string split-units) " split-value " (gnc:debug "Pass 2: split units " (gnc-numeric-to-string split-units) " split-value "
(gnc-numeric-to-string split-value) " commod-currency " (gnc-numeric-to-string split-value) " commod-currency "
(gnc-commodity-get-printname commod-currency)) (gnc-commodity-get-printname commod-currency))
(cond (cond
((and (not (gnc-numeric-zero-p split-units)) ((and (not (gnc-numeric-zero-p split-units))
(same-account? current (xaccSplitGetAccount s))) (same-account? current (xaccSplitGetAccount s)))
;; Split into subject account with non-zero amount. This is a purchase ;; Split into subject account with non-zero amount. This is a purchase
;; or a sale, adjust the basis ;; or a sale, adjust the basis
(let* ((split-value-currency (gnc:gnc-monetary-amount (let* ((split-value-currency (gnc:gnc-monetary-amount
(my-exchange-fn (gnc:make-gnc-monetary (my-exchange-fn (gnc:make-gnc-monetary
commod-currency split-value) currency))) commod-currency split-value) currency)))
(orig-basis (sum-basis basis-list currency-frac)) (orig-basis (sum-basis basis-list currency-frac))
;; proportion of the fees attributable to this split ;; proportion of the fees attributable to this split
(fee-ratio (gnc-numeric-div (gnc-numeric-abs split-units) trans-shares (fee-ratio (gnc-numeric-div (gnc-numeric-abs split-units) trans-shares
GNC-DENOM-AUTO GNC-DENOM-REDUCE)) GNC-DENOM-AUTO GNC-DENOM-REDUCE))
;; Fees for this split in report currency ;; Fees for this split in report currency
(fees-currency (gnc:gnc-monetary-amount (my-exchange-fn (fees-currency (gnc:gnc-monetary-amount (my-exchange-fn
(gnc:make-gnc-monetary commod-currency (gnc:make-gnc-monetary commod-currency
(gnc-numeric-mul fee-ratio trans-brokerage (gnc-numeric-mul fee-ratio trans-brokerage
commod-currency-frac GNC-RND-ROUND)) commod-currency-frac GNC-RND-ROUND))
currency))) currency)))
(split-value-with-fees (if (eq? handle-brokerage-fees 'include-in-basis) (split-value-with-fees (if (eq? handle-brokerage-fees 'include-in-basis)
;; Include brokerage fees in basis ;; Include brokerage fees in basis
(gnc-numeric-add split-value-currency fees-currency (gnc-numeric-add split-value-currency fees-currency
currency-frac GNC-RND-ROUND) currency-frac GNC-RND-ROUND)
split-value-currency))) split-value-currency)))
@ -744,10 +746,10 @@
(gnc-numeric-to-string split-value-with-fees)) (gnc-numeric-to-string split-value-with-fees))
;; adjust the basis ;; adjust the basis
(set! basis-list (basis-builder basis-list split-units split-value-with-fees (set! basis-list (basis-builder basis-list split-units split-value-with-fees
basis-method currency-frac)) basis-method currency-frac))
(gnc:debug "coming out of basis list " basis-list) (gnc:debug "coming out of basis list " basis-list)
;; If it's a sale or the stock is worthless, calculate the gain ;; If it's a sale or the stock is worthless, calculate the gain
(if (not (gnc-numeric-positive-p split-value)) (if (not (gnc-numeric-positive-p split-value))
;; Split value is zero or negative. If it's zero it's either a stock split/merge ;; Split value is zero or negative. If it's zero it's either a stock split/merge
@ -756,7 +758,7 @@
(let ((new-basis (sum-basis basis-list currency-frac))) (let ((new-basis (sum-basis basis-list currency-frac)))
(if (or (gnc-numeric-zero-p new-basis) (if (or (gnc-numeric-zero-p new-basis)
(gnc-numeric-negative-p split-value)) (gnc-numeric-negative-p split-value))
;; Split value is negative or new basis is zero (stock is worthless), ;; Split value is negative or new basis is zero (stock is worthless),
;; Capital gain is money out minus change in basis ;; Capital gain is money out minus change in basis
(let ((gain (gnc-numeric-sub (gnc-numeric-abs split-value-with-fees) (let ((gain (gnc-numeric-sub (gnc-numeric-abs split-value-with-fees)
(gnc-numeric-sub orig-basis new-basis (gnc-numeric-sub orig-basis new-basis
@ -773,30 +775,30 @@
;; in an income or expense account. ;; in an income or expense account.
((spin-off? s current) ((spin-off? s current)
(gnc:debug "before spin-off basis list " basis-list) (gnc:debug "before spin-off basis list " basis-list)
(set! basis-list (basis-builder basis-list split-units (gnc:gnc-monetary-amount (set! basis-list (basis-builder basis-list split-units (gnc:gnc-monetary-amount
(my-exchange-fn (gnc:make-gnc-monetary (my-exchange-fn (gnc:make-gnc-monetary
commod-currency split-value) commod-currency split-value)
currency)) currency))
basis-method basis-method
currency-frac)) currency-frac))
(gnc:debug "after spin-off basis list " basis-list)) (gnc:debug "after spin-off basis list " basis-list))
) )
)) ))
(xaccTransGetSplitList parent) (xaccTransGetSplitList parent)
) )
) )
) )
) )
) )
(xaccAccountGetSplitList current) (xaccAccountGetSplitList current)
) )
;; Look for income and expense transactions that don't have a split in the ;; Look for income and expense transactions that don't have a split in the
;; the account we're processing. We do this as follow ;; the account we're processing. We do this as follow
;; 1. Make sure the parent account is a currency-valued asset or bank account ;; 1. Make sure the parent account is a currency-valued asset or bank account
;; 2. If so go through all the splits in that account ;; 2. If so go through all the splits in that account
;; 3. If a split is part of a two split transaction where the other split is ;; 3. If a split is part of a two split transaction where the other split is
;; to an income or expense account and the leaf name of that account is the ;; to an income or expense account and the leaf name of that account is the
;; same as the leaf name of the account we're processing, add it to the ;; same as the leaf name of the account we're processing, add it to the
;; income or expense accumulator ;; income or expense accumulator
;; ;;
@ -809,20 +811,20 @@
;; Dividends (type INCOME) ;; Dividends (type INCOME)
;; Widget Stock (type INCOME) ;; Widget Stock (type INCOME)
;; ;;
;; If you are producing a report on "Assets:Broker:Widget Stock" a ;; If you are producing a report on "Assets:Broker:Widget Stock" a
;; transaction that debits the Assets:Broker account and credits the ;; transaction that debits the Assets:Broker account and credits the
;; "Income:Dividends:Widget Stock" account will count as income in ;; "Income:Dividends:Widget Stock" account will count as income in
;; the report even though it doesn't have a split in the account ;; the report even though it doesn't have a split in the account
;; being reported on. ;; being reported on.
(let ((parent-account (gnc-account-get-parent current)) (let ((parent-account (gnc-account-get-parent current))
(account-name (xaccAccountGetName current))) (account-name (xaccAccountGetName current)))
(if (and (not (null? parent-account)) (if (and (not (null? parent-account))
(member (xaccAccountGetType parent-account) (list ACCT-TYPE-ASSET ACCT-TYPE-BANK)) (member (xaccAccountGetType parent-account) (list ACCT-TYPE-ASSET ACCT-TYPE-BANK))
(gnc-commodity-is-currency (xaccAccountGetCommodity parent-account))) (gnc-commodity-is-currency (xaccAccountGetCommodity parent-account)))
(for-each (for-each
(lambda (split) (lambda (split)
(let* ((other-split (xaccSplitGetOtherSplit split)) (let* ((other-split (xaccSplitGetOtherSplit split))
;; This is safe because xaccSplitGetAccount returns null for a null split ;; This is safe because xaccSplitGetAccount returns null for a null split
(other-acct (xaccSplitGetAccount other-split)) (other-acct (xaccSplitGetAccount other-split))
(parent (xaccSplitGetParent split)) (parent (xaccSplitGetParent split))
@ -831,7 +833,7 @@
(gnc:timepair-le txn-date to-date) (gnc:timepair-le txn-date to-date)
(string=? (xaccAccountGetName other-acct) account-name) (string=? (xaccAccountGetName other-acct) account-name)
(gnc-commodity-is-currency (xaccAccountGetCommodity other-acct))) (gnc-commodity-is-currency (xaccAccountGetCommodity other-acct)))
;; This is a two split transaction where the other split is to an ;; This is a two split transaction where the other split is to an
;; account with the same name as the current account. If it's an ;; account with the same name as the current account. If it's an
;; income or expense account accumulate the value of the transaction ;; income or expense account accumulate the value of the transaction
(let ((val (xaccSplitGetValue split)) (let ((val (xaccSplitGetValue split))
@ -840,13 +842,13 @@
(gnc:debug "More income " (gnc-numeric-to-string val)) (gnc:debug "More income " (gnc-numeric-to-string val))
(dividendcoll 'add curr val)) (dividendcoll 'add curr val))
((split-account-type? other-split ACCT-TYPE-EXPENSE) ((split-account-type? other-split ACCT-TYPE-EXPENSE)
(gnc:debug "More expense " (gnc-numeric-to-string (gnc:debug "More expense " (gnc-numeric-to-string
(gnc-numeric-neg val))) (gnc-numeric-neg val)))
(brokeragecoll 'add curr (gnc-numeric-neg val))) (brokeragecoll 'add curr (gnc-numeric-neg val)))
) )
) )
) )
) )
) )
(xaccAccountGetSplitList parent-account) (xaccAccountGetSplitList parent-account)
) )
@ -858,7 +860,7 @@
(gnc:debug "prefer-pricelist is " prefer-pricelist) (gnc:debug "prefer-pricelist is " prefer-pricelist)
(gnc:debug "price is " price) (gnc:debug "price is " price)
(gnc:debug "basis we're using to build rows is " (gnc-numeric-to-string (sum-basis basis-list (gnc:debug "basis we're using to build rows is " (gnc-numeric-to-string (sum-basis basis-list
currency-frac))) currency-frac)))
(gnc:debug "but the actual basis list is " basis-list) (gnc:debug "but the actual basis list is " basis-list)
@ -872,9 +874,9 @@
(income (gnc:sum-collector-commodity dividendcoll currency my-exchange-fn)) (income (gnc:sum-collector-commodity dividendcoll currency my-exchange-fn))
;; just so you know, gain == realized gain, ugain == un-realized gain, bothgain, well.. ;; just so you know, gain == realized gain, ugain == un-realized gain, bothgain, well..
(gain (gnc:sum-collector-commodity gaincoll currency my-exchange-fn)) (gain (gnc:sum-collector-commodity gaincoll currency my-exchange-fn))
(ugain (gnc:make-gnc-monetary currency (ugain (gnc:make-gnc-monetary currency
(gnc-numeric-sub (gnc:gnc-monetary-amount (my-exchange-fn value currency)) (gnc-numeric-sub (gnc:gnc-monetary-amount (my-exchange-fn value currency))
(sum-basis basis-list (gnc-commodity-get-fraction currency)) (sum-basis basis-list (gnc-commodity-get-fraction currency))
currency-frac GNC-RND-ROUND))) currency-frac GNC-RND-ROUND)))
(bothgain (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount gain) (bothgain (gnc:make-gnc-monetary currency (gnc-numeric-add (gnc:gnc-monetary-amount gain)
(gnc:gnc-monetary-amount ugain) (gnc:gnc-monetary-amount ugain)
@ -916,7 +918,7 @@
price price
) )
price price
) )
(gnc:html-price-anchor (gnc:html-price-anchor
price price
(gnc:make-gnc-monetary (gnc:make-gnc-monetary
@ -924,7 +926,7 @@
(gnc-price-get-value price))) (gnc-price-get-value price)))
))))) )))))
(append! activecols (list (if use-txn (if pricing-txn "*" "**") " ") (append! activecols (list (if use-txn (if pricing-txn "*" "**") " ")
(gnc:make-html-table-header-cell/markup (gnc:make-html-table-header-cell/markup
"number-cell" (gnc:make-gnc-monetary currency (sum-basis basis-list "number-cell" (gnc:make-gnc-monetary currency (sum-basis basis-list
currency-frac))) currency-frac)))
(gnc:make-html-table-header-cell/markup "number-cell" value) (gnc:make-html-table-header-cell/markup "number-cell" value)
@ -947,7 +949,7 @@
(if (not (eq? handle-brokerage-fees 'ignore-brokerage)) (if (not (eq? handle-brokerage-fees 'ignore-brokerage))
(append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" brokerage)))) (append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" brokerage))))
(append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" totalreturn) (append! activecols (list (gnc:make-html-table-header-cell/markup "number-cell" totalreturn)
(gnc:make-html-table-header-cell/markup "number-cell" (gnc:make-html-table-header-cell/markup "number-cell"
(let* ((moneyinvalue (gnc-numeric-to-double (let* ((moneyinvalue (gnc-numeric-to-double
(gnc:gnc-monetary-amount moneyin))) (gnc:gnc-monetary-amount moneyin)))
(totalreturnvalue (gnc-numeric-to-double (totalreturnvalue (gnc-numeric-to-double
@ -958,12 +960,12 @@
(sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue moneyinvalue)))))) (sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue moneyinvalue))))))
) )
) )
(gnc:html-table-append-row/markup! (gnc:html-table-append-row/markup!
table table
row-style row-style
activecols) activecols)
(if (and (not use-txn) price) (gnc-price-unref price)) (if (and (not use-txn) price) (gnc-price-unref price))
(table-add-stock-rows-internal rest (not odd-row?)) (table-add-stock-rows-internal rest (not odd-row?))
) )
@ -976,7 +978,7 @@
(set! work-to-do (gnc:accounts-count-splits accounts)) (set! work-to-do (gnc:accounts-count-splits accounts))
(table-add-stock-rows-internal accounts #t))) (table-add-stock-rows-internal accounts #t)))
;; Tell the user that we're starting. ;; Tell the user that we're starting.
(gnc:report-starting reportname) (gnc:report-starting reportname)
@ -989,7 +991,7 @@
(currency (get-option gnc:pagename-general "Report's currency")) (currency (get-option gnc:pagename-general "Report's currency"))
(price-source (get-option gnc:pagename-general (price-source (get-option gnc:pagename-general
optname-price-source)) optname-price-source))
(report-title (get-option gnc:pagename-general (report-title (get-option gnc:pagename-general
gnc:optname-reportname)) gnc:optname-reportname))
(include-empty (get-option gnc:pagename-accounts (include-empty (get-option gnc:pagename-accounts
optname-zero-shares)) optname-zero-shares))
@ -1021,7 +1023,7 @@
(document (gnc:make-html-document))) (document (gnc:make-html-document)))
(gnc:html-document-set-title! (gnc:html-document-set-title!
document (string-append document (string-append
report-title report-title
(sprintf #f " %s" (gnc-print-date to-date)))) (sprintf #f " %s" (gnc-print-date to-date))))
@ -1031,12 +1033,12 @@
(pricedb (gnc-pricedb-get-db (gnc-get-current-book))) (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
(price-fn (price-fn
(case price-source (case price-source
((pricedb-latest) ((pricedb-latest)
(lambda (foreign domestic date) (lambda (foreign domestic date)
(find-price (gnc-pricedb-lookup-latest-any-currency pricedb foreign) (find-price (gnc-pricedb-lookup-latest-any-currency pricedb foreign)
domestic))) domestic)))
((pricedb-nearest) ((pricedb-nearest)
(lambda (foreign domestic date) (lambda (foreign domestic date)
(find-price (gnc-pricedb-lookup-nearest-in-time-any-currency (find-price (gnc-pricedb-lookup-nearest-in-time-any-currency
pricedb foreign (timespecCanonicalDayTime date)) domestic))))) pricedb foreign (timespecCanonicalDayTime date)) domestic)))))
(headercols (list (_ "Account"))) (headercols (list (_ "Account")))
@ -1047,22 +1049,22 @@
(sum-total-gain (gnc-numeric-zero)) (sum-total-gain (gnc-numeric-zero))
(sum-total-ugain (gnc-numeric-zero)) (sum-total-ugain (gnc-numeric-zero))
(sum-total-brokerage (gnc-numeric-zero)) (sum-total-brokerage (gnc-numeric-zero))
(sum-total-totalreturn (gnc-numeric-zero))) (sum-total-totalreturn (gnc-numeric-zero))) ;;end of let
;;begin building lists for which columns to display ;;begin building lists for which columns to display
(if show-symbol (if show-symbol
(begin (append! headercols (list (_ "Symbol"))) (begin (append! headercols (list (_ "Symbol")))
(append! totalscols (list " ")))) (append! totalscols (list " "))))
(if show-listing (if show-listing
(begin (append! headercols (list (_ "Listing"))) (begin (append! headercols (list (_ "Listing")))
(append! totalscols (list " ")))) (append! totalscols (list " "))))
(if show-shares (if show-shares
(begin (append! headercols (list (_ "Shares"))) (begin (append! headercols (list (_ "Shares")))
(append! totalscols (list " ")))) (append! totalscols (list " "))))
(if show-price (if show-price
(begin (append! headercols (list (_ "Price"))) (begin (append! headercols (list (_ "Price")))
(append! totalscols (list " ")))) (append! totalscols (list " "))))
@ -1088,14 +1090,14 @@
(gnc:html-table-set-col-headers! (gnc:html-table-set-col-headers!
table table
headercols) headercols)
(table-add-stock-rows (table-add-stock-rows
table accounts to-date currency price-fn exchange-fn price-source table accounts to-date currency price-fn exchange-fn price-source
include-empty show-symbol show-listing show-shares show-price basis-method include-empty show-symbol show-listing show-shares show-price basis-method
prefer-pricelist handle-brokerage-fees prefer-pricelist handle-brokerage-fees
total-basis total-value total-moneyin total-moneyout total-basis total-value total-moneyin total-moneyout
total-income total-gain total-ugain total-brokerage) total-income total-gain total-ugain total-brokerage)
(set! sum-total-moneyin (gnc:sum-collector-commodity total-moneyin currency exchange-fn)) (set! sum-total-moneyin (gnc:sum-collector-commodity total-moneyin currency exchange-fn))
(set! sum-total-income (gnc:sum-collector-commodity total-income currency exchange-fn)) (set! sum-total-income (gnc:sum-collector-commodity total-income currency exchange-fn))
@ -1152,17 +1154,17 @@
(gnc:make-html-table-cell/markup (gnc:make-html-table-cell/markup
"total-number-cell" sum-total-totalreturn) "total-number-cell" sum-total-totalreturn)
(gnc:make-html-table-cell/markup (gnc:make-html-table-cell/markup
"total-number-cell" "total-number-cell"
(let* ((totalinvalue (gnc-numeric-to-double (let* ((totalinvalue (gnc-numeric-to-double
(gnc:gnc-monetary-amount sum-total-moneyin))) (gnc:gnc-monetary-amount sum-total-moneyin)))
(totalreturnvalue (gnc-numeric-to-double (totalreturnvalue (gnc-numeric-to-double
(gnc:gnc-monetary-amount sum-total-totalreturn))) (gnc:gnc-monetary-amount sum-total-totalreturn)))
) )
(if (= 0.0 totalinvalue) (if (= 0.0 totalinvalue)
"" ""
(sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue totalinvalue)))))) (sprintf #f "%.2f%%" (* 100 (/ totalreturnvalue totalinvalue))))))
)) ))
(gnc:html-table-append-row/markup! (gnc:html-table-append-row/markup!
table table
@ -1171,24 +1173,24 @@
) )
(gnc:html-document-add-object! document table) (gnc:html-document-add-object! document table)
(if warn-price-dirty (if warn-price-dirty
(gnc:html-document-append-objects! document (gnc:html-document-append-objects! document
(list (gnc:make-html-text (_ "* this commodity data was built using transaction pricing instead of the price list.")) (list (gnc:make-html-text (_ "* this commodity data was built using transaction pricing instead of the price list."))
(gnc:make-html-text (gnc:html-markup-br)) (gnc:make-html-text (gnc:html-markup-br))
(gnc:make-html-text (_ "If you are in a multi-currency situation, the exchanges may not be correct."))))) (gnc:make-html-text (_ "If you are in a multi-currency situation, the exchanges may not be correct.")))))
(if warn-no-price (if warn-no-price
(gnc:html-document-append-objects! document (gnc:html-document-append-objects! document
(list (gnc:make-html-text (if warn-price-dirty (gnc:html-markup-br) "")) (list (gnc:make-html-text (if warn-price-dirty (gnc:html-markup-br) ""))
(gnc:make-html-text (_ "** this commodity has no price and a price of 1 has been used."))))) (gnc:make-html-text (_ "** this commodity has no price and a price of 1 has been used.")))))
) )
;if no accounts selected. ;if no accounts selected.
(gnc:html-document-add-object! (gnc:html-document-add-object!
document document
(gnc:html-make-no-account-warning (gnc:html-make-no-account-warning
report-title (gnc:report-id report-obj)))) report-title (gnc:report-id report-obj))))
(gnc:report-finished) (gnc:report-finished)
document))) document)))

112
src/report/standard-reports/portfolio.scm
View File

@ -2,16 +2,16 @@
;; portfolio.scm ;; portfolio.scm
;; by Robert Merkel (rgmerk@mira.net) ;; by Robert Merkel (rgmerk@mira.net)
;; ;;
;; This program is free software; you can redistribute it and/or ;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as ;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of ;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version. ;; the License, or (at your option) any later version.
;; ;;
;; This program is distributed in the hope that it will be useful, ;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details. ;; GNU General Public License for more details.
;; ;;
;; You should have received a copy of the GNU General Public License ;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact: ;; along with this program; if not, contact:
;; ;;
@ -39,23 +39,23 @@
(define optname-zero-shares (N_ "Include accounts with no shares")) (define optname-zero-shares (N_ "Include accounts with no shares"))
(define (options-generator) (define (options-generator)
(let* ((options (gnc:new-options)) (let* ((options (gnc:new-options))
;; This is just a helper function for making options. ;; This is just a helper function for making options.
;; See gnucash/src/scm/options.scm for details. ;; See gnucash/src/scm/options.scm for details.
(add-option (add-option
(lambda (new-option) (lambda (new-option)
(gnc:register-option options new-option)))) (gnc:register-option options new-option))))
;; General Tab ;; General Tab
;; date at which to report balance ;; date at which to report balance
(gnc:options-add-report-date! (gnc:options-add-report-date!
options gnc:pagename-general options gnc:pagename-general
(N_ "Date") "a") (N_ "Date") "a")
(gnc:options-add-currency! (gnc:options-add-currency!
options gnc:pagename-general (N_ "Report's currency") "c") options gnc:pagename-general (N_ "Report's currency") "c")
(gnc:options-add-price-source! (gnc:options-add-price-source!
options gnc:pagename-general options gnc:pagename-general
optname-price-source "d" 'pricedb-latest) optname-price-source "d" 'pricedb-latest)
@ -74,18 +74,18 @@
(lambda () (filter gnc:account-is-stock? (lambda () (filter gnc:account-is-stock?
(gnc-account-get-descendants-sorted (gnc-account-get-descendants-sorted
(gnc-get-current-root-account)))) (gnc-get-current-root-account))))
(lambda (accounts) (list #t (lambda (accounts) (list #t
(filter gnc:account-is-stock? accounts))) (filter gnc:account-is-stock? accounts)))
#t)) #t))
(gnc:register-option (gnc:register-option
options options
(gnc:make-simple-boolean-option (gnc:make-simple-boolean-option
gnc:pagename-accounts optname-zero-shares "e" gnc:pagename-accounts optname-zero-shares "e"
(N_ "Include accounts that have a zero share balances.") (N_ "Include accounts that have a zero share balances.")
#f)) #f))
(gnc:options-set-default-section options gnc:pagename-general) (gnc:options-set-default-section options gnc:pagename-general)
options)) options))
;; This is the rendering function. It accepts a database of options ;; This is the rendering function. It accepts a database of options
@ -98,14 +98,14 @@
(let ((work-done 0) (let ((work-done 0)
(work-to-do 0)) (work-to-do 0))
;; These are some helper functions for looking up option values. ;; These are some helper functions for looking up option values.
(define (get-op section name) (define (get-op section name)
(gnc:lookup-option (gnc:report-options report-obj) section name)) (gnc:lookup-option (gnc:report-options report-obj) section name))
(define (get-option section name) (define (get-option section name)
(gnc:option-value (get-op section name))) (gnc:option-value (get-op section name)))
(define (table-add-stock-rows table accounts to-date currency (define (table-add-stock-rows table accounts to-date currency
exchange-fn price-fn include-empty collector) exchange-fn price-fn include-empty collector)
@ -149,7 +149,7 @@
(gnc:make-html-table-header-cell/markup "text-cell" ticker-symbol) (gnc:make-html-table-header-cell/markup "text-cell" ticker-symbol)
(gnc:make-html-table-header-cell/markup "text-cell" listing) (gnc:make-html-table-header-cell/markup "text-cell" listing)
(gnc:make-html-table-header-cell/markup (gnc:make-html-table-header-cell/markup
"number-cell" "number-cell"
(xaccPrintAmount units share-print-info)) (xaccPrintAmount units share-print-info))
(gnc:make-html-table-header-cell/markup (gnc:make-html-table-header-cell/markup
"number-cell" "number-cell"
@ -176,7 +176,7 @@
(get-option gnc:pagename-general "Date"))) (get-option gnc:pagename-general "Date")))
(accounts (get-option gnc:pagename-accounts "Accounts")) (accounts (get-option gnc:pagename-accounts "Accounts"))
(currency (get-option gnc:pagename-general "Report's currency")) (currency (get-option gnc:pagename-general "Report's currency"))
(report-title (get-option gnc:pagename-general (report-title (get-option gnc:pagename-general
gnc:optname-reportname)) gnc:optname-reportname))
(price-source (get-option gnc:pagename-general (price-source (get-option gnc:pagename-general
optname-price-source)) optname-price-source))
@ -189,55 +189,67 @@
(document (gnc:make-html-document))) (document (gnc:make-html-document)))
(gnc:html-document-set-title! (gnc:html-document-set-title!
document (string-append document (string-append
report-title report-title
(sprintf #f " %s" (gnc-print-date to-date)))) (sprintf #f " %s" (gnc-print-date to-date))))
;(gnc:debug "accounts" accounts) ;(gnc:debug "accounts" accounts)
(if (not (null? accounts)) (if (not (null? accounts))
(let* ((commodity-list (gnc:accounts-get-commodities (let* ((commodity-list (gnc:accounts-get-commodities
(append (append
(gnc:acccounts-get-all-subaccounts (gnc:acccounts-get-all-subaccounts
accounts) accounts) currency)) accounts) accounts) currency))
(pricedb (gnc-pricedb-get-db (gnc-get-current-book))) (pricedb (gnc-pricedb-get-db (gnc-get-current-book)))
(exchange-fn (gnc:case-exchange-fn price-source currency to-date)) (exchange-fn (gnc:case-exchange-fn price-source currency to-date))
(price-fn (price-fn
(case price-source (case price-source
((weighted-average average-cost) ((weighted-average average-cost)
(lambda (foreign date) (lambda (foreign date)
(cons #f (gnc-numeric-div (cons #f (gnc-numeric-div
(gnc:gnc-monetary-amount (gnc:gnc-monetary-amount
(exchange-fn (gnc:make-gnc-monetary foreign (exchange-fn (gnc:make-gnc-monetary foreign
(gnc-numeric-create 10000 1)) (gnc-numeric-create 10000 1))
currency)) currency))
(gnc-numeric-create 10000 1) (gnc-numeric-create 10000 1)
GNC-DENOM-AUTO GNC-DENOM-AUTO
(logior (GNC-DENOM-SIGFIGS 5) GNC-RND-ROUND))))) (logior (GNC-DENOM-SIGFIGS 5) GNC-RND-ROUND)))))
((pricedb-latest) ((pricedb-latest)
(lambda (foreign date) (lambda (foreign date)
(let* ((price (let* ((price
(gnc-pricedb-lookup-latest-any-currency (gnc-pricedb-lookup-latest-any-currency
pricedb foreign)) pricedb foreign))
(fn (if (and price (> (length price) 0)) (fn (if (and price (> (length price) 0))
(let ((v (gnc-price-get-value (car price)))) (let* ((the_price
(if (gnc-commodity-equiv
foreign
(gnc-price-get-commodity (car price)))
(car price)
(gnc-price-invert (car price))))
(v (gnc-price-get-value the_price)))
(gnc-price-ref (car price)) (gnc-price-ref (car price))
(cons (car price) v)) (cons (car price) v))
(cons #f (gnc-numeric-zero))))) (cons #f (gnc-numeric-zero)))))
(if price (gnc-price-list-destroy price)) (if price (gnc-price-list-destroy price))
fn))) fn)))
((pricedb-nearest) ((pricedb-nearest)
(lambda (foreign date) (lambda (foreign date)
(let* ((price (let* ((price
(gnc-pricedb-lookup-nearest-in-time-any-currency (gnc-pricedb-lookup-nearest-in-time-any-currency
pricedb foreign (timespecCanonicalDayTime date))) pricedb foreign (timespecCanonicalDayTime date)))
(fn (if (and price (> (length price) 0)) (fn (if (and price (> (length price) 0))
(let ((v (gnc-price-get-value (car price)))) (let* ((the_price
(if (gnc-commodity-equiv
foreign
(gnc-price-get-commodity (car price)))
(car price)
(gnc-price-invert (car price))))
(v (gnc-price-get-value (car price))))
(gnc-price-ref (car price)) (gnc-price-ref (car price))
(cons (car price) v)) (cons (car price) v))
(cons #f (gnc-numeric-zero))))) (cons #f (gnc-numeric-zero)))))
(if price (gnc-price-list-destroy price)) (if price (gnc-price-list-destroy price))
fn)))))) fn))))))
(gnc:html-table-set-col-headers! (gnc:html-table-set-col-headers!
table table
(list (_ "Account") (list (_ "Account")
@ -246,22 +258,22 @@
(_ "Units") (_ "Units")
(_ "Price") (_ "Price")
(_ "Value"))) (_ "Value")))
(table-add-stock-rows (table-add-stock-rows
table accounts to-date currency table accounts to-date currency
exchange-fn price-fn include-empty collector) exchange-fn price-fn include-empty collector)
(gnc:html-table-append-row/markup! (gnc:html-table-append-row/markup!
table table
"grand-total" "grand-total"
(list (list
(gnc:make-html-table-cell/size (gnc:make-html-table-cell/size
1 6 (gnc:make-html-text (gnc:html-markup-hr))))) 1 6 (gnc:make-html-text (gnc:html-markup-hr)))))
(collector (collector
'format 'format
(lambda (currency amount) (lambda (currency amount)
(gnc:html-table-append-row/markup! (gnc:html-table-append-row/markup!
table table
"grand-total" "grand-total"
(list (gnc:make-html-table-cell/markup (list (gnc:make-html-table-cell/markup
@ -270,15 +282,15 @@
1 5 "total-number-cell" 1 5 "total-number-cell"
(gnc:make-gnc-monetary currency amount))))) (gnc:make-gnc-monetary currency amount)))))
#f) #f)
(gnc:html-document-add-object! document table)) (gnc:html-document-add-object! document table))
;if no accounts selected. ;if no accounts selected.
(gnc:html-document-add-object! (gnc:html-document-add-object!
document document
(gnc:html-make-no-account-warning (gnc:html-make-no-account-warning
report-title (gnc:report-id report-obj)))) report-title (gnc:report-id report-obj))))
(gnc:report-finished) (gnc:report-finished)
document))) document)))

59
src/scm/price-quotes.scm
View File

@ -419,38 +419,37 @@
(set! saved-price (gnc-pricedb-lookup-day pricedb (set! saved-price (gnc-pricedb-lookup-day pricedb
commodity currency commodity currency
gnc-time)) gnc-time))
(if (null? saved-price) ;;See if there's a reversed price.
(begin
(set! saved-price (gnc-pricedb-lookup-day pricedb currency
commodity gnc-time))
(if (not (null? saved-price))
(set! price (gnc-numeric-invert price)))))
(if (not (null? saved-price)) (if (not (null? saved-price))
(if (> (gnc-price-get-source saved-price) PRICE-SOURCE-FQ) (begin
(begin (if (gnc-commodity-equiv (gnc-price-get-currency saved-price)
(gnc-price-begin-edit saved-price) commodity)
(gnc-price-set-time saved-price gnc-time) (set! price (gnc-numeric-invert price)))
(gnc-price-set-source saved-price PRICE-SOURCE-FQ) (if (> (gnc-price-get-source saved-price) PRICE-SOURCE-FQ)
(gnc-price-set-typestr saved-price price-type) (begin
(gnc-price-set-value saved-price price) (gnc-price-begin-edit saved-price)
(gnc-price-commit-edit saved-price) (gnc-price-set-time saved-price gnc-time)
(gnc-price-set-source saved-price PRICE-SOURCE-FQ)
(gnc-price-set-typestr saved-price price-type)
(gnc-price-set-value saved-price price)
(gnc-price-commit-edit saved-price)
#f)
#f) #f)
#f) (let ((gnc-price (gnc-price-create book)))
(let ((gnc-price (gnc-price-create book))) (if (not gnc-price)
(if (not gnc-price) (string-append
(string-append currency-str ":" (gnc-commodity-get-mnemonic commodity))
currency-str ":" (gnc-commodity-get-mnemonic commodity)) (begin
(begin (gnc-price-begin-edit gnc-price)
(gnc-price-begin-edit gnc-price) (gnc-price-set-commodity gnc-price commodity)
(gnc-price-set-commodity gnc-price commodity) (gnc-price-set-currency gnc-price currency)
(gnc-price-set-currency gnc-price currency) (gnc-price-set-time gnc-price gnc-time)
(gnc-price-set-time gnc-price gnc-time) (gnc-price-set-source gnc-price PRICE-SOURCE-FQ)
(gnc-price-set-source gnc-price PRICE-SOURCE-FQ) (gnc-price-set-typestr gnc-price price-type)
(gnc-price-set-typestr gnc-price price-type) (gnc-price-set-value gnc-price price)
(gnc-price-set-value gnc-price price) (gnc-price-commit-edit gnc-price)
(gnc-price-commit-edit gnc-price) gnc-price)))))
gnc-price))))) ))
))) ))
(define (book-add-prices! book prices) (define (book-add-prices! book prices)
(let ((pricedb (gnc-pricedb-get-db book))) (let ((pricedb (gnc-pricedb-get-db book)))