summaryrefslogtreecommitdiffstats
path: root/report.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /report.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'report.scm')
-rw-r--r--report.scm116
1 files changed, 116 insertions, 0 deletions
diff --git a/report.scm b/report.scm
new file mode 100644
index 0000000..64f4d46
--- /dev/null
+++ b/report.scm
@@ -0,0 +1,116 @@
+;;; "report.scm" relational-database-utility
+; Copyright 1995 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, and to use it
+;for any purpose is granted, subject to the following restrictions and
+;understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;;;; Considerations for report generation:
+; * columnar vs. fixed-multi-line vs. variable-multi-line
+; * overflow lines within column boundaries.
+; * break overflow across page?
+; * Page headers and footers (need to know current/previous record-number
+; and next record-number).
+; * Force page break on general expression (needs next row as arg).
+; * Hierachical reports.
+
+;================================================================
+
+(require 'format)
+(require 'database-utilities)
+
+(define (dbutil:database arg)
+ (cond ((procedure? arg) arg)
+ ((string? arg) (dbutil:open-database arg))
+ ((symbol? arg) (slib:eval arg))
+ (else (slib:error "can't coerce to database: " arg))))
+
+(define (dbutil:table arg)
+ (cond ((procedure? arg) arg)
+ ((and (list? arg) (= 2 (length arg)))
+ (((dbutil:database (car arg)) 'open-table) (cadr arg) #f))))
+
+(define (dbutil:print-report table header reporter footer . args)
+ (define output-port (and (pair? args) (car args)))
+ (define page-height (and (pair? args) (pair? (cdr args)) (cadr args)))
+ (define minimum-break
+ (and (pair? args) (pair? (cdr args)) (pair? (cddr args)) (caddr args)))
+ (set! table (dbutil:table table))
+ ((lambda (fun)
+ (cond ((output-port? output-port)
+ (fun output-port))
+ ((string? output-port)
+ (call-with-output-file output-port fun))
+ ((or (boolean? output-port) (null? output-port))
+ (fun (current-output-port)))
+ (else (slib:error "can't coerce to output-port: " arg))))
+ (lambda (output-port)
+ (set! page-height (or page-height (output-port-height output-port)))
+ (set! minimum-break (or minimum-break 0))
+ (let ((output-page 0)
+ (output-line 0)
+ (nth-newline-index
+ (lambda (str n)
+ (define len (string-length str))
+ (do ((i 0 (+ i 1)))
+ ((or (zero? n) (> i len)) (+ -1 i))
+ (cond ((char=? #\newline (string-ref str i))
+ (set! n (+ -1 n)))))))
+ (count-newlines
+ (lambda (str)
+ (define cnt 0)
+ (do ((i (+ -1 (string-length str)) (+ -1 i)))
+ ((negative? i) cnt)
+ (cond ((char=? #\newline (string-ref str i))
+ (set! cnt (+ 1 cnt)))))))
+ (format (let ((oformat format))
+ (lambda (dest fmt arg)
+ (cond ((not (procedure? fmt)) (oformat dest fmt arg))
+ ((output-port? dest) (fmt dest arg))
+ ((eq? #t dest) (fmt (current-output-port) arg))
+ ((eq? #f dest) (call-with-output-string
+ (lambda (port) (fmt port arg))))
+ (else (oformat dest fmt arg)))))))
+ (define column-names (table 'column-names))
+ (define (do-header)
+ (let ((str (format #f header column-names)))
+ (display str output-port)
+ (set! output-line (count-newlines str))))
+ (define (do-lines str inc)
+ (cond
+ ((< (+ output-line inc) page-height)
+ (display str output-port)
+ (set! output-line (+ output-line inc)))
+ (else ;outputting footer
+ (cond ((and (not (zero? minimum-break))
+ (> cnt (* 2 minimum-break))
+ (> (- page-height output-line) minimum-break))
+ (let ((break (nth-newline-index
+ str (- page-height output-line))))
+ (display (substring str 0 (+ 1 break) output-port))
+ (set! str (substring str (+ 1 break) (string-length str)))
+ (set! inc (- inc (- page-height output-line))))))
+ (format output-port footer column-names)
+ (display slib:form-feed output-port)
+ (set! output-page (+ 1 output-page))
+ (do-header)
+ (do-lines str inc))))
+
+ (do-header)
+ ((table 'for-each-row)
+ (lambda (row)
+ (let ((str (format #f reporter row)))
+ (do-lines str (count-newlines str)))))
+ output-page))))