After installing still-some-further-dev-packages that came available
this week in Helix Gnome, GnuCash again became buildable and runnable.
With the next result that I have done some testing of the "new
reporting code" that uses lists rather than appending strings
together.
Attached are the three files that have changed lately...
1. report.scm
;; 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 [EMAIL PROTECTED]
(require 'hash-table)
(require 'record)
(gnc:support "report.scm")
;; We use a hash to store the report info so that whenever a report
;; is requested, we'll look up the action to take dynamically. That
;; makes it easier for us to allow changing the report definitions
;; on the fly later, and it should have no appreciable performance
;; effect.
(define *gnc:_report-info_* (make-hash-table 23))
;; This hash should contain all the reports available and will be used
;; to generate the reports menu whenever a new window opens and to
;; figure out what to do when a report needs to be generated.
;;
;; The key is the string naming the report and the value is the report
;; structure.
(define (gnc:run-report report-name options)
;; Return a string consisting of the contents of the report.
(define (display-report-list-item item port)
(cond
((string? item) (display item port))
((null? item) #t)
((list? item) (map (lambda (item) (display-report-list-item item port))
item))
(else (gnc:warn "gnc:run-report - " item " is the wrong type."))))
;; 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))
(define (add-report-menu-item name report)
(let* ((report-string "Report")
(title (string-append (gnc:_ report-string) ": " (gnc:_ name)))
(item #f))
(if (gnc:debugging?)
(let ((options (false-if-exception (gnc:report-new-options report))))
(if options
(gnc:options-register-translatable-strings options))
(gnc:register-translatable-strings report-string name)))
(set! item
(gnc:make-menu-item
((menu-namer 'add-name) name)
(string-append "Display the " name " report.")
(list "_Reports" "")
(lambda ()
(let ((options (false-if-exception
(gnc:report-new-options report))))
(gnc:report-window title
(lambda () (gnc:run-report name options))
options)))))
(gnc:add-extension item)))
(gnc:add-extension menu)
(hash-for-each add-report-menu-item *gnc:_report-info_*))
(define report-record-structure
(make-record-type "report-record-structure"
; The data items in a report record
'(version name options-generator renderer)))
(define (gnc:define-report . args)
;; For now the version is ignored, but in the future it'll let us
;; change behaviors without breaking older reports.
;;
;; The renderer should be a function that accepts one argument,
;; a set of options, and generates the report.
;;
;; This code must return as its final value a collection of strings in
;; the form of a list of elements where each element (recursively) is
;; either a string, or a list containing nothing more than strings and
;; lists of strings. Any null lists will be ignored. The final html
;; output will be produced by an in-order traversal of the tree
;; represented by the list. i.e. ("a" (("b" "c") "d") "e") produces
;; "abcde" in the output.
;;
;; For those who speak BNF-ish the output should look like
;;
;; report -> string-list
;; string-list -> ( items ) | ()
;; items -> item items | item
;; item -> string | string-list
;;
;; Valid examples:
;;
;; ("<html>" "</html>")
;; ("<html>" " some text " "</html>")
;; ("<html>" ("some" ("other" " text")) "</html>")
(define (blank-report)
;; Number of #f's == Number of data members
((record-constructor report-record-structure) #f #f #f #f))
(define (args-to-defn in-report-rec args)
(let ((report-rec (if in-report-rec
in-report-rec
(blank-report))))
(if (null? args)
in-report-rec
(let ((id (car args))
(value (cadr args))
(remainder (cddr args)))
((record-modifier report-record-structure id) report-rec value)
(args-to-defn report-rec remainder)))))
(let ((report-rec (args-to-defn #f args)))
(if (and report-rec
(gnc:report-name report-rec))
(hash-set! *gnc:_report-info_*
(gnc:report-name report-rec) report-rec)
(gnc:warn "gnc:define-report: bad report"))))
(define gnc:report-version
(record-accessor report-record-structure 'version))
(define gnc:report-name
(record-accessor report-record-structure 'name))
(define gnc:report-options-generator
(record-accessor report-record-structure 'options-generator))
(define gnc:report-renderer
(record-accessor report-record-structure 'renderer))
(define (gnc:report-new-options report)
(let ((generator (gnc:report-options-generator report)))
(if (procedure? generator)
(generator)
#f)))
(gnc:hook-add-dangler gnc:*main-window-opened-hook* gnc:report-menu-setup)
2. html-generator.scm
;; html-generator.scm -- HTML Support functions
;; Bryan Larsen ([EMAIL PROTECTED]) with help from
;; pretty much everybody involved with reports.
;;
;; 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 [EMAIL PROTECTED]
(gnc:support "html-generator.scm")
;; How this mechanism works:
;;
;; To do a report, first collect all of your results into a list.
;; Each item in the list corresponds to one entry. One entry may
;; correspond to more than one line in the report, though.
;;
;; Assemble a list of report-spec-structure's. Each entry in the
;; report-spec-structure corresponds to one column in the HTML report.
;; Perhaps the most important parameter in the structure is
;; get-value-proc, which extracts the value to print in the column
;; from the entry.
;;
;; If total-proc and total-html-proc are defined, the column is totalled.
;;
;; Subentries are handled several different ways, depending on what
;; function is used to convert the results into an html table. If
;; subs-list-proc and subentry-html-proc are #f, there are no
;; subentries in this column.
;;
;; Subsections (which are not yet implemented) are defined in the
;; report-sort-spec-structure. Define subtotal-html-proc to allow
;; this column to be totalled.
;;
;; Note that pretty much every parameter may be set to #f. For
;; example, to define a "total column", you may wish to add an entry
;; 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
;; get-value-proc: given the entry, finds the value
;; html-proc: converts the value into html
;; total-proc: usually + or #f
;; subtotal-html-proc: converts the subtotal into html
;; total-html-proc: converts the total into html
;; first-last-preference: #t if, for this column, entries should be
;; displayed before subentries. #f is
;; subentries before entries. This parameter
;; may be ignored, depending on the report
;; 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"
'(header get-value-proc html-proc total-proc
subtotal-html-proc total-html-proc
first-last-preference subs-list-proc subentry-html-proc)))
;; The proposed sorting mechanism. Of course, if you just wanted it
;; sorted, you could sort the list before converting it into HTML.
;; However, by doing it this way, we can divide things into
;; subsections as well.
;;
;; To sort, collect a list of report-sort-spec-structure's. The first
;; item in the list is the primary sort, and so on down.
;;
;; Optionally, one can divide the report into subsections. To do so,
;; set the subsection-pred. subsection-pred returns true if two
;; values are in the same subsection. All values in the subsection
;; must be adjacent for the sort-pred. For example, one could sort by
;; date, and then supply a subsection-pred that determines whether two
;; dates are within the same month.
;;
;; report-sort-spec-structure
;; get-value-proc: given the entry, finds the value. Required.
;; sort-pred: usually <. Required.
;; equal-pred: usually =. Required. This is used during sorting for
;; multi-key sorting.
;; subsection-pred: often = or #f. Returns #t if both values are in
;; the same subsection
;; subsection-title-proc: returns the title of the subsection given a
;; value. #f indicates no title.
(define report-sort-spec-structure
(make-record-type
"report-sort-spec-structure"
'(get-value-proc sort-pred equal-pred subsection-pred
subsection-title-proc)))
(define make-report-sort-spec
(record-constructor report-sort-spec-structure))
(define report-sort-spec-get-get-value-proc
(record-accessor report-sort-spec-structure 'get-value-proc))
(define report-sort-spec-get-sort-pred
(record-accessor report-sort-spec-structure 'sort-pred))
(define report-sort-spec-get-equal-pred
(record-accessor report-sort-spec-structure 'equal-pred))
(define report-sort-spec-get-subsection-pred
(record-accessor report-sort-spec-structure 'subsection-pred))
(define report-sort-spec-get-subsection-title-proc
(record-accessor report-sort-spec-structure 'subsection-title-proc))
(define report-spec-constructor
(record-constructor report-spec-structure))
(define (make-report-spec . args)
(let ((spec (apply report-spec-constructor args)))
(gnc:register-translatable-strings (report-spec-get-header spec))
spec))
(define report-spec-get-header
(record-accessor report-spec-structure 'header))
(define report-spec-get-get-value-proc
(record-accessor report-spec-structure 'get-value-proc))
(define report-spec-get-html-proc
(record-accessor report-spec-structure 'html-proc))
(define report-spec-get-total-proc
(record-accessor report-spec-structure 'total-proc))
(define report-spec-get-subtotal-html-proc
(record-accessor report-spec-structure 'subtotal-html-proc))
(define report-spec-get-total-html-proc
(record-accessor report-spec-structure 'total-html-proc))
(define report-spec-get-subs-list-proc
(record-accessor report-spec-structure 'subs-list-proc))
(define report-spec-get-subentry-html-proc
(record-accessor report-spec-structure 'subentry-html-proc))
(define report-spec-get-first-last-preference
(record-accessor report-spec-structure 'first-last-preference))
;; convert a list of entries into html
(define (html-table-render-entries entry-list specs sort-specs
line-render-proc count-subentries-proc)
(html-table-do-subsection
(html-table-sort entry-list sort-specs)
specs sort-specs line-render-proc count-subentries-proc 1))
;; the next 3 functions can be passed to html-table-render-entries
;; convert an entry into html. subentries follow entries
(define (html-table-entry-render-entries-first line specs
count-subentries-proc)
(html-table-row-group
(cons
(html-table-row-manual (html-table-do-entry line specs))
(map
html-table-row-manual
(html-table-collect-subentries line specs count-subentries-proc)))))
;; convert an entry into html. first subentry is merged with the entry
(define (html-table-entry-render-subentries-merged line specs
count-subentries-proc)
(let ((subs-lines (html-table-collect-subentries line specs
count-subentries-proc)))
(html-table-row-group
(if (null? subs-lines)
(html-table-row-manual (html-table-do-entry line specs))
(list
(html-table-row-manual
(map
(lambda (entry sub)
(if (not sub) entry sub))
(html-table-do-entry line specs)
(car subs-lines)))
(map html-table-row-manual (cdr subs-lines)))))))
;; convert an entry into html. ignore sub entries
(define (html-table-entry-render-entries-only line specs count-subentries-proc)
(html-table-row-group
(html-table-row-manual (html-table-do-entry line specs))))
;; convert totals to html
(define (html-table-totals lst specs)
(html-table-totals-row
(map
(lambda (spec)
(cond ((report-spec-get-total-html-proc spec)
((report-spec-get-total-html-proc spec)
(apply
(report-spec-get-total-proc spec)
(map (report-spec-get-get-value-proc spec) lst))))
(else #f)))
specs)))
;; convert headers to html
(define (html-table-headers specs)
(html-table-headers-row
(map
(lambda (spec)
(html-header-cell
(gnc:_ (report-spec-get-header spec))))
specs)))
;;;;;;;;;;;;;;;;
;; the rest are just helper functions
;; convert subtotals to html
(define (html-table-subtotals lst sort-spec specs depth)
(html-table-subtotals-row
depth
(map
(lambda (spec)
(cond ((report-spec-get-subtotal-html-proc spec)
((report-spec-get-subtotal-html-proc spec)
(apply
(report-spec-get-total-proc spec)
(map (report-spec-get-get-value-proc spec) lst))))
(else #f)))
specs)))
(define (html-table-sort lst sort-specs)
(sort lst (html-table-make-sort-pred sort-specs)))
(define (html-table-do-subsection lst specs sort-specs line-render-proc
count-subentries-proc depth)
(cond
((null? sort-specs)
(map
(lambda (line) (line-render-proc line specs count-subentries-proc))
lst))
(else
(let loop ((lst2 lst))
(cond
((null? lst2) '())
(else
(let* ((front '())
(back '())
(sort-spec (car sort-specs))
(subsection-pred (report-sort-spec-get-subsection-pred
sort-spec))
(get-value-proc (report-sort-spec-get-get-value-proc sort-spec))
(value1 (get-value-proc (car lst2))))
(cond
(subsection-pred
(set! front
(remove-if-not
(lambda (line)
(subsection-pred value1 (get-value-proc line)))
lst2))
(set! back (set-difference lst2 front)))
(else
(set! front lst2)
(set! back '())))
(list
(cond ((report-sort-spec-get-subsection-title-proc sort-spec)
(html-table-subsection-title
((report-sort-spec-get-subsection-title-proc sort-spec)
(get-value-proc (car front)))
depth))
(else '()))
(html-table-do-subsection
front specs (cdr sort-specs) line-render-proc
count-subentries-proc (+ depth 1))
(cond (subsection-pred
(html-table-subtotals front sort-spec specs depth))
(else '()))
(loop back)))))))))
(define (html-table-make-sort-pred sort-specs)
(lambda (entry1 entry2)
(let loop ((specs sort-specs))
(cond ((null? specs) #f)
(else
(let* ((spec (car specs))
(gv-proc (report-sort-spec-get-get-value-proc spec))
(value1 (gv-proc entry1))
(value2 (gv-proc entry2)))
(cond (((report-sort-spec-get-sort-pred spec) value1 value2) #t)
(((report-sort-spec-get-equal-pred spec) value1 value2)
(loop (cdr specs)))
(else #f))))))))
;; converts from col order to row order.
;; ex. ((a b) (c d) (e f)) -> ((a c e) (b d f))
(define (col-list->row-list lst)
(apply map list lst))
;; converts subentries into html and collects into a list of lists of
;; html cells.
(define (html-table-collect-subentries line specs count-subentries-proc)
(col-list->row-list
(map
(lambda (spec)
(cond ((report-spec-get-subs-list-proc spec)
(map
(report-spec-get-subentry-html-proc spec)
((report-spec-get-subs-list-proc spec) line)))
(else (gnc:map-for
(lambda (n) #f)
0 (count-subentries-proc line) 1))))
specs)))
;; converts entry into a list of html cells.
(define (html-table-do-entry line specs)
(map
(lambda (spec)
(cond ((and (report-spec-get-get-value-proc spec)
(report-spec-get-html-proc spec))
((report-spec-get-html-proc spec)
((report-spec-get-get-value-proc spec) line)))
(else #f)))
specs))
(define (html-table-headers-row headers)
(list
"<TR bgcolor=#96b284 cellspacing=10 rules=\"rows\">"
headers
"</TR>\n"))
(define (html-table-totals-row cells)
(list
"<TR bgcolor=#bfdeba cellspacing=10 rules=\"rows\">"
(map
(lambda (cell)
(cond (cell cell)
(else html-blank-cell)))
cells)
"</TR>\n"))
(define (html-table-subtotals-row depth cells)
(list
"<TR bgcolor="
(number->string (+ #xf6ffdb (* depth #x8)) 16)
"cellspacing=10 rules=\"rows\">"
(map
(lambda (cell)
(cond (cell cell)
(else html-blank-cell)))
cells)
"</TR>\n"))
(define (html-table-row-manual items)
(list
"<TR bgcolor=" html-table-group-color ">"
(map
(lambda (cell)
(cond (cell cell)
(else html-blank-cell)))
items)
"</TR>\n"))
(define (html-table-subsection-title title depth)
(list "<TR bgcolor=#"
(number->string (+ #x96b284 (* depth #x8)) 16)
"><TH>" title "</TH></TR>"))
;; help! this doesn't work! I want something to group several rows
;; together so that an "entry" is noticably one unit.
;; netscape & our html widget do not support tbody.
;;(define (html-table-row-group rows)
;; (list "</TR><TBODY>" rows "</TBODY>"))
(define html-table-group-color "#f6ffdb")
(define (html-table-row-group row)
(set! html-table-group-color
(if (string=? html-table-group-color "#f6ffdb")
"#ffffff"
"#f6ffdb"))
row)
(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 (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 (string-html-currency amount)
(if amount
(string-append
"<font face=\"Courier\""
(if (< amount 0)
(string-append
"color=#ff0000>("
(gnc:amount->string (- amount) #f #t #f)
")")
(string-append
"> "
(gnc:amount->string amount #f #t #f)
" "))
"</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
(html-table-col-align item #f)
#f))
(define (html-make-left-cell proc)
(lambda (val)
(html-left-cell (proc val))))
(define (html-right-cell item)
(if item
(html-table-col-align item "right")
#f))
(define html-blank-cell
(list "<TD>" NBSP "</TD>"))
(define (html-make-right-cell proc)
(lambda (val)
(html-right-cell (proc val))))
(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 (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>"
"<HEAD>"
"<TITLE>" title "</TITLE>"
"</HEAD>"
(if color
(list "<BODY bgcolor=" color ">")
"<BODY>")))
(define (html-start-document-color color)
(list
"<HTML>"
"<BODY bgcolor=" color ">"))
(define (html-start-document)
(list
"<HTML>"
"<BODY bgcolor=#99ccff>"))
(define (html-end-document)
(list
"</BODY>"
"</HTML>"))
(define (html-start-table)
(list "<TABLE>")) ;; border=2 rules=\"groups\"
(define (html-end-table)
(list "</table>"))
;;;;;;;;;;;;;;;;;;;;
;; HTML Table
;; This is used by balance-and-pnl.
;;;;;;;;;;;;;;;;;;;;
; Convert to string
(define (tostring val)
(if (number? val)
(sprintf #f "%.2f" val)
(call-with-output-string
(lambda (p)
(display val p)))))
; Create a column entry
(define (html-table-col val)
(html-table-col-align "right" val))
(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 (string-html-table-row lst)
(cond ((string? lst) lst)
(else
(string-append
"<TR>"
(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 (string-html-table-row-align lst align-list)
(cond ((string? lst) lst)
(else
(string-append
"<TR>"
(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 (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 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-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
(string-append "<caption><b>" caption "</b></caption>")
"")
(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>")
3. balance-and-pnl.scm
;; -*-scheme-*-
;; $Id: balance-and-pnl.scm,v 1.20 2000/06/09 23:59:40 peticolas Exp $
;; 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")
;; Just a private scope.
(let
((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)
(define gnc:*balsht-report-options* (gnc:new-options))
(define (gnc:register-balsht-option new-option)
(gnc:register-option gnc:*balsht-report-options* new-option))
(gnc:register-balsht-option
(gnc:make-date-option
"Report Options" "To"
"a" "Calculate balance sheet up to this date"
(lambda ()
(let ((bdtime (localtime (current-time))))
(set-tm:sec bdtime 59)
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
gnc:*balsht-report-options*)
(define (pnl-options-generator)
(define gnc:*pnl-report-options* (gnc:new-options))
(define (gnc:register-pnl-option new-option)
(gnc:register-option gnc:*pnl-report-options* new-option))
(gnc:register-pnl-option
(gnc:make-date-option
"Report Options" "From"
"a" "Start of reporting period"
(lambda ()
(let ((bdtime (localtime (current-time))))
(set-tm:sec bdtime 0)
(set-tm:min bdtime 0)
(set-tm:hour bdtime 0)
(set-tm:mday bdtime 1)
(set-tm:mon bdtime 0)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
(gnc:register-pnl-option
(gnc:make-date-option
"Report Options" "To"
"b" "End of reporting period"
(lambda ()
(let ((bdtime (localtime (current-time))))
(set-tm:sec bdtime 59)
(set-tm:min bdtime 59)
(set-tm:hour bdtime 23)
(let ((time (car (mktime bdtime))))
(cons time 0))))
#f))
gnc:*pnl-report-options*)
(define (render-level-2-account level-2-account l2-value)
(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
(list
account-name type-name (gnc:amount->formatted-string l2-value #f))
(list "left" "center" "right"))))
(define (render-level-1-account account l1-value)
(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
(gnc:amount->formatted-string l1-value #f)
NBSP NBSP)
(list "left" "center" "right" "right" "right" "right"))))
(define (render-total l0-value)
(html-table-row-align
(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
(html-table-row '()))
(define (is-it-on-balance-sheet? type balance?)
(eq?
(not (member type '(INCOME EXPENSE)))
(not balance?)))
(define (generate-balance-sheet-or-pnl report-name
report-description
options
balance-sheet?)
(let* ((from-option (gnc:lookup-option options "Report Options" "From"))
(from-value (if from-option (gnc:option-value from-option) #f))
(to-value (gnc:timepair-end-day-time
(gnc:option-value
(gnc:lookup-option options "Report Options" "To")))))
(define (handle-level-1-account account options)
(let ((type (gnc:account-type->symbol (gnc:account-get-type account))))
(if (is-it-on-balance-sheet? type balance-sheet?)
;; Ignore
'()
(let* ((children (gnc:account-get-children account))
(num-children (gnc:group-get-num-accounts children))
(childrens-output (gnc:group-map-accounts
(lambda (x)
(handle-level-2-account x options))
children))
(account-balance (if balance-sheet?
(gnc:account-get-balance-at-date
account
to-value #f)
(gnc:account-get-balance-interval
account
from-value
to-value #f))))
(if (not balance-sheet?)
(set! account-balance (- account-balance)))
(l1-collector 'add account-balance)
(l1-collector 'add (l2-collector 'total #f))
(l0-collector 'add (l1-collector 'total #f))
(let ((level-1-output
(render-level-1-account account
(l1-collector 'total #f))))
(l1-collector 'reset #f)
(l2-collector 'reset #f)
(if (null? childrens-output)
level-1-output
(list blank-line
level-1-output
childrens-output
blank-line)))))))
(define (handle-level-2-account account options)
(let
((type (gnc:account-type->symbol (gnc:account-get-type account)))
(balance (make-stats-collector))
(rawbal
(if balance-sheet?
(gnc:account-get-balance-at-date account to-value #f)
(gnc:account-get-balance-interval
account
from-value
to-value #f))))
(balance 'add
(if balance-sheet?
rawbal
(- rawbal)))
(if (is-it-on-balance-sheet? type balance-sheet?)
;; Ignore
'()
;; add in balances for any sub-sub groups
(let ((grandchildren (gnc:account-get-children account)))
(if (not (pointer-token-null? grandchildren))
(balance 'add
((if balance-sheet? + -)
0
(if balance-sheet?
(gnc:group-get-balance-at-date grandchildren
to-value)
(gnc:group-get-balance-interval grandchildren
from-value
to-value)))))
(l2-collector 'add (balance 'total #f))
(render-level-2-account account (balance 'total #f))))))
(let
((current-group (gnc:get-current-group))
(output '()))
;; Now, the main body
;; Reset all the balance collectors
(l0-collector 'reset #f)
(l1-collector 'reset #f)
(l2-collector 'reset #f)
(if (not (pointer-token-null? current-group))
(set! output
(list
(gnc:group-map-accounts
(lambda (x) (handle-level-1-account x options))
current-group)
(render-total (l0-collector 'total #f)))))
(list
"<html>"
"<head>"
"<title>" report-name "</title>"
"</head>"
(if balance-sheet?
"<body bgcolor=#fffde6>"
"<body bgcolor=#f6ffdb>")
"<table cellpadding=1>"
"<caption><b>" report-name "</b></caption>"
"<tr>"
"<th>" (string-db 'lookup 'account-name) "</th>"
"<th align=center>" (string-db 'lookup 'type) "</th>"
"<th align=right>" (string-db 'lookup 'subaccounts) "</th>"
"<th align=right>" (string-db 'lookup 'balance) "</th>"
"</tr>"
output
"</table>"
"</body>"
"</html>"))))
(string-db 'store 'net "Net")
(string-db 'store 'type "Type")
(string-db 'store 'account-name "Account Name")
(string-db 'store 'subaccounts "(subaccounts)")
(string-db 'store 'balance "Balance")
(string-db 'store 'bal-title "Balance Sheet")
(string-db 'store 'bal-desc "This page shows your net worth.")
(string-db 'store 'pnl-title "Profit and Loss")
(string-db 'store 'pnl-desc "This page shows your profits and losses.")
(gnc:define-report
'version 1
'name "Balance sheet"
'options-generator balsht-options-generator
'renderer (lambda (options)
(generate-balance-sheet-or-pnl
(string-db 'lookup 'bal-title)
(string-db 'lookup 'bal-desc)
options
#t)))
(gnc:define-report
'version 1
'name "Profit and Loss"
'options-generator pnl-options-generator
'renderer (lambda (options)
(generate-balance-sheet-or-pnl
(string-db 'lookup 'pnl-title)
(string-db 'lookup 'pnl-desc)
options
#f))))
--
[EMAIL PROTECTED] - <http://www.hex.net/~cbbrowne/linux.html>
"I don't well know whether to go back and strike him, or--what's
that?--down here on my knees and pray for him? Yes, that was the
thought coming up in me; but it would be the first time I ever *did*
pray. It's queer; very queer [...]" -- Moby Dick, Ch 29
_______________________________________________
gnucash-devel mailing list
[EMAIL PROTECTED]
http://www.gnumatic.com/cgi-bin/mailman/listinfo/gnucash-devel
