From bfc3c0b4844f9a89e514c94b820c1c2a03c8dc2d Mon Sep 17 00:00:00 2001 From: Christian Stimming Date: Wed, 29 Dec 2010 21:41:51 +0000 Subject: [PATCH] Revert r19993, "Add a new report..." - not yet working due to errors in the loading process. git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@19994 57a11ea4-9604-0410-9ed3-97b8803252fd --- src/report/business-reports/Makefile.am | 1 - .../business-reports/business-reports.scm | 1 - .../business-reports/customer-summary.scm | 1042 ----------------- 3 files changed, 1044 deletions(-) delete mode 100644 src/report/business-reports/customer-summary.scm diff --git a/src/report/business-reports/Makefile.am b/src/report/business-reports/Makefile.am index 3f67533709..e59b3f9e4d 100644 --- a/src/report/business-reports/Makefile.am +++ b/src/report/business-reports/Makefile.am @@ -2,7 +2,6 @@ gncscmmoddir = ${GNC_SHAREDIR}/guile-modules/gnucash/report gncscmmod_DATA = \ aging.scm \ business-reports.scm \ - customer-summary.scm \ easy-invoice.scm \ fancy-invoice.scm \ taxinvoice.scm \ diff --git a/src/report/business-reports/business-reports.scm b/src/report/business-reports/business-reports.scm index 6b55f671de..6d2ee84493 100644 --- a/src/report/business-reports/business-reports.scm +++ b/src/report/business-reports/business-reports.scm @@ -107,7 +107,6 @@ (use-modules (gnucash report job-report)) (use-modules (gnucash report payables)) (use-modules (gnucash report receivables)) -(use-modules (gnucash report customer-summary)) (define gnc:invoice-report-create gnc:invoice-report-create-internal) diff --git a/src/report/business-reports/customer-summary.scm b/src/report/business-reports/customer-summary.scm deleted file mode 100644 index dcecf9f723..0000000000 --- a/src/report/business-reports/customer-summary.scm +++ /dev/null @@ -1,1042 +0,0 @@ -;; -*-scheme-*- -;; customer-summary.scm -- Print a summary of profit per customer -;; -;; Created by: Christian Stimming -;; Copyright (c) 2010 Christian Stimming -;; Copyright (c) 2002, 2003 Derek Atkins -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2 of -;; the License, or (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; if not, contact: -;; -;; Free Software Foundation Voice: +1-617-542-5942 -;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652 -;; Boston, MA 02110-1301, USA gnu@gnu.org - -;; This report is based on the code in owner-report.scm, but it does -;; not only print a summary for one single owner (here: only -;; customers), but instead a table showing all customers. - -(define-module (gnucash report customer-summary)) - -(use-modules (srfi srfi-1)) -(use-modules (gnucash gnc-module)) -(use-modules (gnucash printf)) -(use-modules (gnucash main)) ; for gnc:debug - -(gnc:module-load "gnucash/report/report-system" 0) -(gnc:module-load "gnucash/business-utils" 0) - -(use-modules (gnucash report standard-reports)) -(use-modules (gnucash report business-reports)) - -;; Option names -(define optname-from-date (N_ "From")) -(define optname-to-date (N_ "To")) - -;; let's define a name for the report-guid's, much prettier -(define customer-report-guid "4166a20981985fd2b07ff8cb3b7d384e") - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define pagename-incomeaccounts (N_ "Income Accounts")) -(define optname-incomeaccounts (N_ "Income Accounts")) -(define opthelp-incomeaccounts - (N_ "The income accounts where the sales and income was recorded.")) -;(define optname-account-ar (N_ "A/R Account")) - -(define pagename-expenseaccounts (N_ "Expense Accounts")) -(define optname-expenseaccounts (N_ "Expense Accounts")) -;(define optname-account-ap (N_ "A/P Account")) -(define opthelp-expenseaccounts (N_ "The expense accounts where the expenses are recorded which are subtracted from the sales to give the profit.")) - -(define optname-show-column-expense (N_ "Show Expense Column")) -(define opthelp-show-column-expense (N_ "Show the column with the expenses per customer")) -(define optname-show-own-address (N_ "Show Company Address")) -(define opthelp-show-own-address (N_ "Show your own company's address and the date of printing")) - -(define pagename-columndisplay (N_ "Display Columns")) -(define date-header (N_ "Date")) -(define reference-header (N_ "Reference")) -(define type-header (N_ "Type")) -(define desc-header (N_ "Description")) -(define amount-header (N_ "Amount")) - -;;(define optname-invoicelines (N_ "Show Invoices")) -;;(define opthelp-invoicelines (N_ "Show Invoice Transactions and include them in the balance")) - -;(define optname-paymentlines (N_ "(Experimental) Show Payments")) -;(define opthelp-paymentlines (N_ "Show Payment Transactions and include them in the balance")) - -;(define optname-show-txn-table (N_ "(Experimental) Show Transaction Table")) -;(define opthelp-show-txn-table (N_ "Show the table with all transactions. If false, only show the total amount per customer.")) - -(define optname-show-zero-lines (N_ "Show Lines with All Zeros")) -(define opthelp-show-zero-lines (N_ "Show the table lines with customers which did not have any transactions in the reporting period, hence would show all zeros in the columns.")) - -(define optname-sortkey (N_ "Sort Column")) -(define opthelp-sortkey (N_ "Choose the column by which the result table is sorted")) -(define optname-sortascending (N_ "Sort Order")) -(define opthelp-sortascending (N_ "Choose the ordering of the column sort: Either ascending or descending")) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-macro (addto! alist element) - `(set! ,alist (cons ,element ,alist))) - -(define (set-last-row-style! table tag . rest) - (let ((arg-list - (cons table - (cons (- (gnc:html-table-num-rows table) 1) - (cons tag rest))))) - (apply gnc:html-table-set-row-style! arg-list))) - -(define (date-col columns-used) - (vector-ref columns-used 0)) -(define (num-col columns-used) - (vector-ref columns-used 2)) -(define (type-col columns-used) - (vector-ref columns-used 3)) -(define (memo-col columns-used) - (vector-ref columns-used 4)) -(define (value-col columns-used) - (vector-ref columns-used 5)) - -(define columns-used-size 6) - -(define (build-column-used options) - (define (opt-val section name) - (gnc:option-value - (gnc:lookup-option options section name))) - (define (make-set-col col-vector) - (let ((col 0)) - (lambda (used? index) - (if used? - (begin - (vector-set! col-vector index col) - (set! col (+ col 1))) - (vector-set! col-vector index #f))))) - - (let* ((col-vector (make-vector columns-used-size #f)) - (set-col (make-set-col col-vector))) - (set-col #t 0) ;;(opt-val pagename-columndisplay date-header) 0) - (set-col #t 2) ;;(opt-val pagename-columndisplay reference-header) 2) - (set-col #t 3) ;;(opt-val pagename-columndisplay type-header) 3) - (set-col #t 4) ;;(opt-val pagename-columndisplay desc-header) 4) - (set-col #t 5) ;;(opt-val pagename-columndisplay amount-header) 5) - col-vector)) - -(define (make-heading-list column-vector) - (let ((heading-list '())) - (if (date-col column-vector) - (addto! heading-list (_ date-header))) - (if (num-col column-vector) - (addto! heading-list (_ reference-header))) - (if (type-col column-vector) - (addto! heading-list (_ type-header))) - (if (memo-col column-vector) - (addto! heading-list (_ desc-header))) - (if (value-col column-vector) - (addto! heading-list (_ amount-header))) - (reverse heading-list))) - - - -;; -;; Make a row list based on the visible columns -;; -(define (make-row column-vector date due-date num type-str memo monetary) - (let ((row-contents '())) - (if (date-col column-vector) - (addto! row-contents (gnc-print-date date))) - (if (num-col column-vector) - (addto! row-contents num)) - (if (type-col column-vector) - (addto! row-contents type-str)) - (if (memo-col column-vector) - (addto! row-contents memo)) - (if (value-col column-vector) - (addto! row-contents - (gnc:make-html-table-cell/markup "number-cell" monetary))) - row-contents)) - -;; -;; Adds the 'Balance' row to the table if it has not been printed and -;; total is not zero -;; -;; Returns printed? -;; -(define (add-balance-row table column-vector txn odd-row? printed? start-date total) - (if (not printed?) - (begin - (set! printed? #t) - (if (not (gnc-numeric-zero-p total)) - (let ((row (make-row column-vector start-date #f "" (_ "Balance") "" - (gnc:make-gnc-monetary (xaccTransGetCurrency txn) total))) - (row-style (if odd-row? "normal-row" "alternate-row"))) - (gnc:html-table-append-row/markup! table row-style (reverse row)) - (set! odd-row? (not odd-row?)) - (set! row-style (if odd-row? "normal-row" "alternate-row"))) - ))) - printed?) - -;; -;; Make sure the caller checks the type first and only calls us with -;; invoice and payment transactions. we don't verify it here. -;; -;; Return a list of (printed? value odd-row?) -;; -(define (add-txn-row table txn acc column-vector odd-row? printed? - inv-str reverse? start-date total) - (let* ((type (xaccTransGetTxnType txn)) - (date (gnc-transaction-get-date-posted txn)) - (due-date #f) - (value (xaccTransGetAccountValue txn acc)) - (split (xaccTransGetSplit txn 0)) - (invoice (gncInvoiceGetInvoiceFromTxn txn)) - (currency (xaccTransGetCurrency txn)) - (type-str - (cond - ((equal? type TXN-TYPE-INVOICE) - (if (not (null? invoice)) - (gnc:make-html-text - (gnc:html-markup-anchor - (gnc:invoice-anchor-text invoice) - inv-str)) - inv-str)) - ((equal? type TXN-TYPE-PAYMENT) - (if (not (null? txn)) - (gnc:make-html-text - (gnc:html-markup-anchor - (gnc:transaction-anchor-text txn) - (_ "Payment"))) - (_ "Payment"))) - (else (_ "Unknown")))) - ) - - (if reverse? - (set! value (gnc-numeric-neg value))) - - (if (gnc:timepair-later start-date date) - (begin - - ;; Adds 'balance' row if needed - (set! printed? (add-balance-row table column-vector txn odd-row? printed? start-date total)) - - ;; Now print out the invoice row - (if (not (null? invoice)) - (set! due-date (gncInvoiceGetDateDue invoice))) - - (let ((row (make-row column-vector date due-date (xaccTransGetNum txn) - type-str (xaccSplitGetMemo split) - (gnc:make-gnc-monetary currency value))) - (row-style (if odd-row? "normal-row" "alternate-row"))) - - (gnc:html-table-append-row/markup! table row-style - (reverse row))) - - (set! odd-row? (not odd-row?)) - )) - - (list printed? value odd-row?) - )) - - -(define (make-txn-table options txns acc start-date end-date) - (define (opt-val pagename optname) - (gnc:option-value (gnc:lookup-option options pagename optname))) - (let ((used-columns (build-column-used options)) - (total (gnc-numeric-zero)) - (currency (xaccAccountGetCommodity acc)) - (table (gnc:make-html-table)) - (inv-str (opt-val "__reg" "inv-str")) - (reverse? (opt-val "__reg" "reverse?")) - (print-invoices? #t) ;;(opt-val gnc:pagename-general optname-invoicelines)) - (print-payments? #f) ;;(opt-val gnc:pagename-display optname-paymentlines)) - ) - - (define (should-print-txn? txn-type) - (or (and print-invoices? - (equal? txn-type TXN-TYPE-INVOICE)) - (and print-payments? - (equal? txn-type TXN-TYPE-PAYMENT)))) - - (gnc:html-table-set-col-headers! - table - (make-heading-list used-columns)) - - ;; Order the transactions properly - (set! txns (sort txns (lambda (a b) (> 0 (xaccTransOrder a b))))) - - (let ((printed? #f) - (odd-row? #t)) - (for-each - (lambda (txn) - (let ((type (xaccTransGetTxnType txn))) - (if - (should-print-txn? type) - (let ((result (add-txn-row table txn acc used-columns odd-row? printed? - inv-str reverse? start-date total))) - - (set! printed? (car result)) - (if printed? - (set! total (gnc-numeric-add-fixed total (cadr result)))) - (set! odd-row? (caddr result)) - )))) - txns) - ;; Balance row may not have been added if all transactions were before - ;; start-date (and no other rows would be added either) so add it now - (if (and (not (null? txns)) (and print-invoices? print-payments?)) - (add-balance-row table used-columns (car txns) odd-row? printed? start-date total) - )) - - (gnc:html-table-append-row/markup! - table - "grand-total" - (append (cons (gnc:make-html-table-cell/markup - "total-label-cell" - ;; (if (gnc-numeric-negative-p total) - ;; (_ "Total Credit") - ;; (_ "Total Due"))) - (_ "Total") - " " - ;; (xaccAccountGetName acc) - (gnc:html-account-anchor acc)) - '()) - (list (gnc:make-html-table-cell/size/markup - 1 (value-col used-columns) - "total-number-cell" - (gnc:make-gnc-monetary currency total))))) - - (list table total))) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (find-first-account acct-type-list) - (define (find-first account-list) - (if (null? account-list) - '() - (let* ((this-account (car account-list)) - (account-type (xaccAccountGetType this-account))) - (if (if (null? acct-type-list) - #t - (member account-type acct-type-list)) - this-account - (find-first (cdr account-list)))))) - - (let* ((current-root (gnc-get-current-root-account)) - (account-list (gnc-account-get-descendants-sorted current-root))) - (find-first account-list))) - - -(define (options-generator acct-type-list owner-type inv-str reverse?) - - (define options (gnc:new-options)) - - (define (add-option new-option) - (gnc:register-option options new-option)) - - (add-option - (gnc:make-internal-option "__reg" "inv-str" inv-str)) - - (add-option - (gnc:make-simple-boolean-option "__reg" "reverse?" "" "" reverse?)) - - (add-option - (gnc:make-internal-option "__reg" "owner-type" owner-type)) - - (gnc:options-add-date-interval! - options - gnc:pagename-general optname-from-date optname-to-date - "b") - -; (add-option -; (gnc:make-simple-boolean-option -; gnc:pagename-general optname-invoicelines -; "m" opthelp-invoicelines #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; gnc:pagename-display optname-paymentlines -; "n" opthelp-paymentlines #f)) - - -; (add-option -; (gnc:make-account-sel-limited-option -; pagename-incomeaccounts optname-account-ar -; "a" (N_ "The account to search for transactions") -; #f #f (list ACCT-TYPE-RECEIVABLE))) - - (add-option - (gnc:make-account-list-option - pagename-incomeaccounts optname-incomeaccounts - "b" - opthelp-incomeaccounts - ;; This default-getter finds the first account of this type. TODO: - ;; Find not only the first one, but all of them! - (lambda () - (gnc:filter-accountlist-type - (list ACCT-TYPE-INCOME) - (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))) - ;;(lambda () - ;;(list (find-first-account acct-type-list))) - #f #t)) - - -; (add-option -; (gnc:make-account-sel-limited-option -; pagename-expenseaccounts optname-account-ap -; "a" (N_ "The account to search for transactions") -; #f #f (list ACCT-TYPE-PAYABLE))) - - (add-option - (gnc:make-account-list-option - pagename-expenseaccounts optname-expenseaccounts - "b" - opthelp-expenseaccounts - ;; This default-getter finds the first account of this type. TODO: - ;; Find not only the first one, but all of them! - (lambda () - (gnc:filter-accountlist-type - (list ACCT-TYPE-EXPENSE) - (gnc-account-get-descendants-sorted (gnc-get-current-root-account)))) - ;;(lambda () - ;;(list (find-first-account acct-type-list))) - #f #t)) - - -; (add-option -; (gnc:make-simple-boolean-option -; pagename-columndisplay date-header -; "b" (N_ "Display the transaction date?") #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; pagename-columndisplay reference-header -; "d" (N_ "Display the transaction reference?") #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; pagename-columndisplay type-header -; "g" (N_ "Display the transaction type?") #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; pagename-columndisplay desc-header -; "h" (N_ "Display the transaction description?") #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; pagename-columndisplay amount-header -; "i" (N_ "Display the transaction amount?") #t)) - - (add-option - (gnc:make-multichoice-option - gnc:pagename-display optname-sortkey - "a" opthelp-sortkey - 'customername - (list - (vector 'customername - (N_ "Customer Name") - (N_ "Sort alphabetically by customer name")) - (vector 'profit - (N_ "Profit") - (N_ "Sort by profit amount")) - (vector 'markup - ;; Translators: "Markup" is profit amount divided by sales amount - (N_ "Markup") - (N_ "Sort by markup (which is profit amount divided by sales)")) - (vector 'sales - (N_ "Sales") - (N_ "Sort by sales amount")) - (vector 'expense - (N_ "Expense") - (N_ "Sort by expense amount"))))) - - (add-option - (gnc:make-multichoice-option - gnc:pagename-display optname-sortascending - "b" opthelp-sortascending - 'ascend - (list - (vector 'ascend - (N_ "Ascending") - (N_ "A to Z, smallest to largest")) - (vector 'descend - (N_ "Descending") - (N_ "Z to A, largest to smallest"))))) - - (add-option - (gnc:make-simple-boolean-option - gnc:pagename-display optname-show-own-address - "d" opthelp-show-own-address #t)) - - (add-option - (gnc:make-simple-boolean-option - gnc:pagename-display optname-show-zero-lines - "e" opthelp-show-zero-lines #f)) - - (add-option - (gnc:make-simple-boolean-option - gnc:pagename-display optname-show-column-expense - "f" opthelp-show-column-expense #t)) - -; (add-option -; (gnc:make-simple-boolean-option -; gnc:pagename-display optname-show-txn-table -; "f" opthelp-show-txn-table #f)) - - (gnc:options-set-default-section options gnc:pagename-general) - - options) - -(define (customer-options-generator) - (options-generator (list ACCT-TYPE-RECEIVABLE) GNC-OWNER-CUSTOMER - (_ "Invoice") #t)) ;; FIXME: reverse?=#t but originally #f - -(define (vendor-options-generator) - (options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-VENDOR - (_ "Bill") #t)) - -(define (employee-options-generator) - (options-generator (list ACCT-TYPE-PAYABLE) GNC-OWNER-EMPLOYEE - (_ "Expense Report") #t)) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (string-expand string character replace-string) - (define (car-line chars) - (take-while (lambda (c) (not (eqv? c character))) chars)) - (define (cdr-line chars) - (let ((rest (drop-while (lambda (c) (not (eqv? c character))) chars))) - (if (null? rest) - '() - (cdr rest)))) - (define (line-helper chars) - (if (null? chars) - "" - (let ((first (car-line chars)) - (rest (cdr-line chars))) - (string-append (list->string first) - (if (null? rest) "" replace-string) - (line-helper rest))))) - (line-helper (string->list string))) - -(define (query-toplevel-setup query account-list start-date end-date) - (xaccQueryAddAccountMatch query account-list QOF-GUID-MATCH-ANY QOF-QUERY-AND) - (xaccQueryAddDateMatchTS query #t start-date #t end-date QOF-QUERY-AND) - (qof-query-set-book query (gnc-get-current-book)) - query) - -(define (query-owner-setup q owner) - (let* ((guid (gncOwnerReturnGUID (gncOwnerGetEndOwner owner)))) - - (qof-query-add-guid-match - q - (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-OWNER - OWNER-PARENTG) - guid QOF-QUERY-OR) - (qof-query-add-guid-match - q - (list SPLIT-TRANS INVOICE-FROM-TXN INVOICE-BILLTO - OWNER-PARENTG) - guid QOF-QUERY-OR) -;; Apparently those query terms are unneeded because we never take -;; lots into account?!? -; (qof-query-add-guid-match -; q -; (list SPLIT-LOT OWNER-FROM-LOT OWNER-PARENTG) -; guid QOF-QUERY-OR) -; (qof-query-add-guid-match -; q -; (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-OWNER -; OWNER-PARENTG) -; guid QOF-QUERY-OR) -; (qof-query-add-guid-match -; q -; (list SPLIT-LOT INVOICE-FROM-LOT INVOICE-BILLTO -; OWNER-PARENTG) -; guid QOF-QUERY-OR) - (qof-query-set-book q (gnc-get-current-book)) - q)) - -(define (make-owner-table owner) - (let ((table (gnc:make-html-table))) - (gnc:html-table-set-style! - table "table" - 'attribute (list "border" 0) - 'attribute (list "cellspacing" 0) - 'attribute (list "cellpadding" 0)) - (gnc:html-table-append-row! - table - (list - (string-expand (gnc:owner-get-name-and-address-dep owner) #\newline "
"))) - (gnc:html-table-append-row! - table - (list "
")) - (set-last-row-style! - table "td" - 'attribute (list "valign" "top")) - table)) - -(define (make-date-row! table label date) - (gnc:html-table-append-row! - table - (list - (string-append label ": ") - (string-expand (gnc-print-date date) #\space " ")))) - -(define (make-date-table) - (let ((table (gnc:make-html-table))) - (gnc:html-table-set-style! - table "table" - 'attribute (list "border" 0) - 'attribute (list "cellpadding" 0)) - (set-last-row-style! - table "td" - 'attribute (list "valign" "top")) - table)) - -(define (make-myname-table book) - (let* ((table (gnc:make-html-table)) - (table-outer (gnc:make-html-table)) - (slots (qof-book-get-slots book)) - (name (kvp-frame-get-slot-path-gslist - slots (append gnc:*kvp-option-path* - (list gnc:*business-label* gnc:*company-name*)))) - (addy (kvp-frame-get-slot-path-gslist - slots (append gnc:*kvp-option-path* - (list gnc:*business-label* gnc:*company-addy*))))) - - (gnc:html-table-set-style! - table "table" - 'attribute (list "border" 0) - 'attribute (list "width" "") ;; this way we force the override of the "100%" below - 'attribute (list "align" "right") - 'attribute (list "valign" "top") - 'attribute (list "cellspacing" 0) - 'attribute (list "cellpadding" 0)) - - (gnc:html-table-append-row! table (list (if name name ""))) - (gnc:html-table-append-row! table (list (string-expand - (if addy addy "") - #\newline "
"))) - (gnc:html-table-append-row! table (list - (gnc-print-date (gnc:get-today)))) - - (gnc:html-table-set-style! - table-outer "table" - 'attribute (list "border" 0) - 'attribute (list "width" "100%") - 'attribute (list "valign" "top") - 'attribute (list "cellspacing" 0) - 'attribute (list "cellpadding" 0)) - - (gnc:html-table-append-row! table-outer (list table)) - - table-outer)) - -(define (make-break! document) - (gnc:html-document-add-object! - document - (gnc:make-html-text - (gnc:html-markup-br)))) - -(define (markup-percent profit sales) - (let ((m (gnc-numeric-div profit sales 1000 GNC-HOW-RND-ROUND))) - (* 100 (gnc-numeric-to-double m)))) - -(define (query-split-value sub-query toplevel-query) - (let ((splits (qof-query-run-subquery sub-query toplevel-query)) - (total (gnc-numeric-zero)) - ) - (for-each - (lambda (split) - (set! total (gnc-numeric-add-fixed total (xaccSplitGetValue split))) - ) - splits) ;; END for-each splits - total)) - -(define (single-query-split-value query) - (let ((splits (qof-query-run query)) - (total (gnc-numeric-zero)) - ) - (for-each - (lambda (split) - (set! total (gnc-numeric-add-fixed total (xaccSplitGetValue split))) - ) - splits) ;; END for-each splits - total)) - -;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (reg-renderer report-obj) - (define (opt-val section name) - (gnc:option-value - (gnc:lookup-option (gnc:report-options report-obj) section name))) - - (let* ((document (gnc:make-html-document)) - (report-title (opt-val gnc:pagename-general gnc:optname-reportname)) - (start-date (gnc:timepair-start-day-time - (gnc:date-option-absolute-time - (opt-val gnc:pagename-general optname-from-date)))) - (end-date (gnc:timepair-end-day-time - (gnc:date-option-absolute-time - (opt-val gnc:pagename-general optname-to-date)))) - (print-invoices? #t);;(opt-val gnc:pagename-general optname-invoicelines)) - (print-payments? #f) ;;(opt-val gnc:pagename-display optname-paymentlines)) -; (show-txn-table? (opt-val gnc:pagename-display optname-show-txn-table)) - (show-zero-lines? (opt-val gnc:pagename-display optname-show-zero-lines)) - (show-column-expense? (opt-val gnc:pagename-display optname-show-column-expense)) - (table-num-columns (if show-column-expense? 5 4)) - (show-own-address? (opt-val gnc:pagename-display optname-show-own-address)) - (expense-accounts (opt-val pagename-expenseaccounts optname-expenseaccounts)) - (income-accounts (opt-val pagename-incomeaccounts optname-incomeaccounts)) - (all-accounts (append income-accounts expense-accounts)) - (book (gnc-get-current-book)) ;XXX Grab this from elsewhere - (type (opt-val "__reg" "owner-type")) - (reverse? (opt-val "__reg" "reverse?")) - (ownerlist (gncBusinessGetOwnerList book (gncOwnerTypeToQofIdType type) #f)) - (toplevel-income-query (qof-query-create-for-splits)) - (toplevel-expense-query (qof-query-create-for-splits)) - (toplevel-total-income #f) - (toplevel-total-expense #f) - (owner-query (qof-query-create-for-splits)) - (any-valid-owner? #f) - (type-str "") - (notification-str "") - (currency (gnc-default-currency))) - - (cond - ((eqv? type GNC-OWNER-CUSTOMER) - (set! type-str (N_ "Customer"))) - ((eqv? type GNC-OWNER-VENDOR) - (set! type-str (N_ "Vendor"))) - ((eqv? type GNC-OWNER-EMPLOYEE) - (set! type-str (N_ "Employee")))) - - (gnc:html-document-set-title! - document (string-append (_ type-str) " " (_ "Report"))) - - ;; Set up the toplevel query - (query-toplevel-setup toplevel-income-query income-accounts start-date end-date) - - ;; Run the query to be able to use the results in a sub-query, and - ;; also use the amount as the actual grand total (both assigned - ;; and not assigned to customers) - (set! toplevel-total-income - (single-query-split-value toplevel-income-query)) - (if reverse? - (set! toplevel-total-income (gnc-numeric-neg toplevel-total-income))) - - ;; Total expenses as well - (query-toplevel-setup toplevel-expense-query expense-accounts start-date end-date) - (set! toplevel-total-expense - (single-query-split-value toplevel-expense-query)) - (if reverse? - (set! toplevel-total-expense (gnc-numeric-neg toplevel-total-expense))) - - ;; Continue if we have non-null accounts - (if (null? income-accounts) - - ;; error condition: no accounts specified - ;; is this *really* necessary?? i'd be fine with an all-zero - ;; account summary that would, technically, be correct.... - (gnc:html-document-add-object! - document - (gnc:html-make-no-account-warning - report-title (gnc:report-id report-obj))) - - ;; otherwise, generate the report... - - (let ((resulttable - ;; Loop over all owners - (map - (lambda (owner) - (if - (and (gncOwnerIsValid owner) - (> (length all-accounts) 0)) - - ;; Now create the line for one single owner - (let ((total-income (gnc-numeric-zero)) - (total-expense (gnc-numeric-zero))) - - (set! currency (xaccAccountGetCommodity (car all-accounts))) - (set! any-valid-owner? #t) - - ;; Run one query on all income accounts - (query-owner-setup owner-query owner) - - (set! total-income (query-split-value owner-query toplevel-income-query)) - (if reverse? - (set! total-income (gnc-numeric-neg total-income))) - - ;; Clean up the query - (qof-query-clear owner-query) - - ;; And run one query on all expense accounts - (query-owner-setup owner-query owner) - - (set! total-expense (query-split-value owner-query toplevel-expense-query)) - (if reverse? - (set! total-expense (gnc-numeric-neg total-expense))) - - ;; Clean up the query - (qof-query-clear owner-query) - - ;; We print the summary now - (let* ((profit (gnc-numeric-add-fixed total-income total-expense)) - (markupfloat (markup-percent profit total-income)) - ) - - ;; Result of this customer - (list owner profit markupfloat total-income total-expense) - - ) - - ) ;; END let - ) ;; END if owner-is-valid - ) - ownerlist) ;; END for-each all owners - - )) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; If asked for, we also print the company name - (if show-own-address? - (gnc:html-document-add-object! - document - (make-myname-table book))) - - ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; Now print the resulttable here: - (let ((table (gnc:make-html-table)) - (sort-descending? (eq? (opt-val gnc:pagename-display optname-sortascending) 'descend)) - (sort-key (opt-val gnc:pagename-display optname-sortkey)) - (total-profit (gnc-numeric-zero)) - (total-sales (gnc-numeric-zero)) - (total-expense (gnc-numeric-zero)) - (heading-list - ;; Translators: "Markup" is profit amount divided by sales amount - (list (_ "Customer") (_ "Profit") (_ "Markup") (_ "Sales")))) - - ;; helper for sorting an owner list - (define (owner-name <)) - (strcmp (if sort-descending? string>? string