aherman
/
gnucash
mirror of https://github.com/Gnucash/gnucash
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Christopher Browne's updates to the reporting code.

Browse Source 
git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@2678 57a11ea4-9604-0410-9ed3-97b8803252fd
zzzoldreleases/1.6
Dave Peticolas 26 years ago
parent 83fcd68cdd
commit e4e32e95d0
3 changed files with 195 additions and 49 deletions
Show Stats Download Patch File Download Diff File

141
src/scm/html-generator.scm
Unescape View File

@ -20,7 +20,6 @@
;; Boston, MA 02111-1307, USA gnu@gnu.org
(gnc:support "html-generator.scm")
;; How this mechanism works:
;;
@ -50,7 +49,6 @@
;; to the spec list that sets html-proc to #f, but sets
;; total-html-proc and subtotal-html-proc. This way, subtotals really
;; stand out.
;;
;;
;; report-spec-structure
;; header: string describing the column
@ -66,6 +64,13 @@
;; style chosen.
;; subs-list-proc: a procedure that returns a list of subentry values
;; subentry-html-proc: converts a subentry value into html
(define NBSP " ") ;;; Non-breaking space
;;; <http://www.sightspecific.com/~mosh/WWW_FAQ/nbsp.html>
;;; Primarily "correctly" used in order to put _something_ into an
;;; otherwise blank table cell because some web browsers do not cope
;;; well with truly empty table cells
(define report-spec-structure
(make-record-type
"report-spec-structure"
@ -386,30 +391,41 @@
(define html-table-group-color "#f6ffdb")
(define (html-table-row-group row)
(if (string=? html-table-group-color "#f6ffdb")
(set! html-table-group-color "#ffffff")
(set! html-table-group-color "#f6ffdb"))
(set! html-table-group-color
(if (string=? html-table-group-color "#f6ffdb")
"#ffffff"
"#f6ffdb"))
row)
(define (html-strong html)
(define (string-html-strong html)
(if html
(string-append "<STRONG>" html "</STRONG>")
#f))
(define (html-strong html)
(if html
(list "<STRONG>" html "</STRONG>")
#f))
(define (html-make-strong proc)
(lambda (val)
(html-strong (proc val))))
(define (html-ital html)
(define (string-html-ital html)
(if html
(string-append "<i>" html "</i>")
#f))
(define (html-ital html)
(if html
(list "<I>" html "</I>")
#f))
(define (html-make-ital proc)
(lambda (val)
(html-ital (proc val))))
(define (html-currency amount)
(define (string-html-currency amount)
(if amount
(string-append
"<font face=\"Courier\""
@ -425,9 +441,36 @@
"</font>")
#f))
(define (html-font-and-color face color contents)
(list
"<font"
(if face
(list "face=\"" face "\"")
#f)
(if color
(list "color=#" color)
#f)
">"
contents
"</font>"))
(define (html-currency amount)
(if amount
(let*
((neg (< amount 0))
(absamt (if neg (- amount) amount))
(color (if neg "ff0000" #f))
(prefix (if neg "(" NBSP))
(suffix (if neg ")" NBSP))
(displayamt (gnc:amount->string absamt #f #t #f)))
(html-font-and-color "Courier" color
(list prefix displayamt suffix)))
#f))
(define (html-left-cell item)
(if item
(string-append "<TD>" item "</TD>")
(html-table-col-align item #f)
#f))
(define (html-make-left-cell proc)
@ -436,28 +479,34 @@
(define (html-right-cell item)
(if item
(string-append "<TD align=right>" item "</TD>")
(html-table-col-align item "right")
#f))
(define html-blank-cell
"<TD></TD>")
(list "<TD>" NBSP "</TD>"))
(define (html-make-right-cell proc)
(lambda (val)
(html-right-cell (proc val))))
(define (html-header-cell item)
(define (string-html-header-cell item)
(string-append "<TH justify=left>" item "</TH>"))
(define (html-header-cell item)
(html-table-headcol-justified item "left"))
(define (html-string string)
(if string string #f))
(define (html-number format number)
(if number (sprintf #f format number) #f))
(define (html-para text)
(define (string-html-para text)
(string-append "<P>" text "</P>\n"))
(define (html-para text)
(list "<P>" text "</P>\n"))
(define (html-start-document-title title color)
(list
"<HTML>"
@ -465,11 +514,11 @@
"<TITLE>" title "</TITLE>"
"</HEAD>"
(if color
(string-append "<BODY bgcolor=" color ">")
(list "<BODY bgcolor=" color ">")
"<BODY>")))
(define (html-start-document-color color)
(list
(list
"<HTML>"
"<BODY bgcolor=" color ">"))
@ -505,13 +554,21 @@
; Create a column entry
(define (html-table-col val)
(string-append "<TD align=right>" (tostring val) "</TD>"))
(html-table-col-align "right" val))
(define (html-table-col-align val align)
(define (string-html-table-col-align val align)
(string-append "<TD align=" align ">" (tostring val) "</TD>"))
(define (html-table-col-align val align)
(list "<TD"
(if align
(list "align=" align)
#f)
">"
(tostring val) "</TD>"))
; Create an html table row from a list of entries
(define (html-table-row lst)
(define (string-html-table-row lst)
(cond ((string? lst) lst)
(else
(string-append
@ -519,8 +576,15 @@
(apply string-append (map html-table-col lst))
"</TR>"))))
(define (html-table-row lst)
(if (string? lst)
lst
(list "<TR>"
(map html-table-col lst)
"</TR>")))
; Create an html table row from a list of entries
(define (html-table-row-align lst align-list)
(define (string-html-table-row-align lst align-list)
(cond ((string? lst) lst)
(else
(string-append
@ -528,18 +592,43 @@
(apply string-append (map html-table-col-align lst align-list))
"</TR>"))))
(define (html-table-row-align lst align-list)
(if (string? lst)
lst
(list "<TR>"
(map html-table-col-align lst align-list)
"</TR>")))
; Create an html table from a list of rows, each containing
; a list of column entries
(define (html-table caption hdrlst llst)
(define (string-html-table caption hdrlst llst)
(string-append
(html-table-header caption hdrlst)
(apply string-append (map html-table-row llst))
(html-table-footer)))
(define (html-table-headcol val)
(define (html-table caption hdrlst llst)
(list
(html-table-header caption hdrlst)
(map html-table-row llst)
(html-table-footer)))
(define (string-html-table-headcol val)
(string-append "<TH justify=center>" (tostring val) "</TH>"))
(define (html-table-header caption vec)
(define (html-table-headcol-justified val justification)
(list "<TH"
(if justification
(list "justify=" justification)
#f)
">"
(tostring val)
"</TH">))
(define (html-table-headcol val)
(html-table-headcol-justified val "center"))
(define (string-html-table-header caption vec)
(apply string-append
"<TABLE cellspacing=10 rules=\"rows\">\n"
(if caption
@ -547,5 +636,13 @@
"")
(map html-table-headcol vec)))
(define (html-table-header caption vec)
(list
"<TABLE cellspacing=10 rules=\"rows\">\n"
(if caption
(list "<caption><b>" caption "</b></caption>")
"")
(map html-table-headcol vec)))
(define (html-table-footer)
"</TABLE>")

62
src/scm/report.scm
Unescape View File

@ -45,23 +45,55 @@
item))
(else (gnc:warn "gnc:run-report - " item " is the wrong type."))))
(define (report-output->string lines)
(call-with-output-string
(lambda (port)
(for-each
(lambda (item) (display-report-list-item item port))
lines))))
(let ((report (hash-ref *gnc:_report-info_* report-name)))
(if report
(let* ((renderer (gnc:report-renderer report))
(lines (renderer options))
(output (report-output->string lines)))
output)
#f)))
;; Old version assumed flat lists
; (define (report-output->string lines)
; (call-with-output-string
; (lambda (port)
; (for-each
; (lambda (item) (display-report-list-item item port))
; lines))))
;; New version that processes a _tree_ rather than a flat list of
;; strings. This means that we can pass in somewhat "more structured"
;; data.
(define (output-tree-to-port tree port)
(cond
((pair? tree)
(output-tree-to-port (car tree) port)
(output-tree-to-port (cdr tree) port))
((string? tree)
(display-report-list-item tree port)
(newline port))
((null? tree)
#f) ;;; Do Nothing...
(tree ;;; If it's not #f
(display-report-list-item "<B> Error - Bad atom! </b>" port)
(display-report-list-item tree port)
(display "Err: (")
(write tree)
(display ")")
(newline)
(newline port))))
(define (report-output->string tree)
(display "(Report-Tree ")
(display tree)
(display ")")
(newline)
(call-with-output-string
(lambda (port)
(output-tree-to-port tree port))))
(let ((report (hash-ref *gnc:_report-info_* report-name)))
(if report
(let* ((renderer (gnc:report-renderer report))
(lines (renderer options))
(output (report-output->string lines)))
output)
#f)))
(define (gnc:report-menu-setup win)
(define menu (gnc:make-menu "_Reports" (list "_Accounts")))
(define menu-namer (gnc:new-menu-namer))

41
src/scm/report/balance-and-pnl.scm
Unescape View File

@ -1,8 +1,24 @@
;; -*-scheme-*-
;; $Id$
;; 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
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA gnu@gnu.org
;; Balance and Profit/Loss Reports
(gnc:support "report/balance-and-pnl.scm")
(gnc:depend "html-generator.scm")
(gnc:depend "text-export.scm")
(gnc:depend "report-utilities.scm")
(gnc:depend "options.scm")
@ -13,7 +29,7 @@
((l0-collector (make-stats-collector))
(l1-collector (make-stats-collector))
(l2-collector (make-stats-collector)))
(define string-db (gnc:make-string-database))
(define (balsht-options-generator)
@ -70,9 +86,9 @@
gnc:*pnl-report-options*)
(define (render-level-2-account level-2-account l2-value)
(let ((account-name (string-append "&nbsp;&nbsp;&nbsp;&nbsp;"
(gnc:account-get-full-name
level-2-account)))
(let ((account-name (list NBSP NBSP NBSP NBSP
(gnc:account-get-full-name
level-2-account)))
(type-name (gnc:account-get-type-string
(gnc:account-get-type level-2-account))))
(html-table-row-align
@ -84,17 +100,18 @@
(let ((name (gnc:account-get-full-name account))
(type (gnc:account-get-type-string (gnc:account-get-type account))))
(html-table-row-align
(list name type "&nbsp;"
(list name type NBSP
(gnc:amount->formatted-string l1-value #f)
"&nbsp;" "&nbsp;")
NBSP NBSP)
(list "left" "center" "right" "right" "right" "right"))))
(define (render-total l0-value)
(html-table-row-align
(list "&nbsp;" "&nbsp;" "&nbsp;"
(html-strong (string-db 'lookup 'net))
"&nbsp;"
(gnc:amount->formatted-string l0-value #f))
(list (html-strong (string-db 'lookup 'net))
NBSP NBSP
(gnc:amount->formatted-string l0-value #f)
NBSP NBSP
)
(list "left" "center" "right" "right" "right" "right")))
(define blank-line

Write Preview
Loading…
Cancel
Save