summaryrefslogtreecommitdiffstats
path: root/db2html.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:31 -0800
commit5145dd3aa0c02c9fc496d1432fc4410674206e1d (patch)
tree540afc30c51da085f5bd8ec3f4c89f6496e7900d /db2html.scm
parent8466d8cfa486fb30d1755c4261b781135083787b (diff)
downloadslib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.tar.gz
slib-5145dd3aa0c02c9fc496d1432fc4410674206e1d.zip
Import Upstream version 3a2upstream/3a2
Diffstat (limited to 'db2html.scm')
-rw-r--r--db2html.scm76
1 files changed, 50 insertions, 26 deletions
diff --git a/db2html.scm b/db2html.scm
index df34389..8ad97e1 100644
--- a/db2html.scm
+++ b/db2html.scm
@@ -52,10 +52,10 @@
;;@body Outputs a heading row for the currently-started table.
(define (html:heading columns)
- (sprintf #f " <TR VALIGN=\"TOP\">\\n%s </TR>\\n"
+ (sprintf #f " <TR VALIGN=\"TOP\">\\n%s\\n"
(apply string-append
(map (lambda (datum)
- (sprintf #f " <TH>%s</TH>\\n" (or datum "")))
+ (sprintf #f " <TH>%s\\n" (or datum "")))
columns))))
;;@body Outputs a heading row with column-names @1 linked to URIs @2.
@@ -92,11 +92,11 @@
(cond ((eqv? (string-index str #\newline) len)
(string-append "<TT>" (substring str 0 len) "</TT>"))
(else (html:pre str))))))
- (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (sprintf #f " <TR VALIGN=TOP>\\n%s\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
- #f " <TD>%s%s</TD>\\n"
+ #f " <TD>%s%s\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((not foreign) (present datum))
@@ -121,8 +121,9 @@
table-name))
;;@args caption db table-name match-key1 @dots{}
-;;Returns HTML string for @2 table @3. Every foreign-key value is
-;;linked to the page (of the table) defining that key.
+;;Returns HTML string for @2 table @3 chopped into 50-row HTML tables.
+;;Every foreign-key value is linked to the page (of the table)
+;;defining that key.
;;
;;The optional @4 @dots{} arguments restrict actions to a subset of
;;the table. @xref{Table Operations, match-key}.
@@ -132,19 +133,42 @@
(tags (map table-name->filename foreigns))
(names (table 'column-names))
(primlim (table 'primary-limit)))
- (apply html:table "CELLSPACING=0 BORDER=1"
- (html:caption caption 'BOTTOM)
- (html:href-heading
- names
- (append (make-list primlim
- (table-name->filename
- (table-name->column-table-name db table-name)))
- (make-list (- (length names) primlim) #f)))
- (html:heading (table 'column-domains))
- (html:href-heading foreigns tags)
- (html:heading (table 'column-types))
- (map (html:linked-row-converter primlim tags)
- (apply (table 'row:retrieve*) args)))))
+ (define tables '())
+ (define rows '())
+ (define cnt 0)
+ (define (make-table rows)
+ (apply html:table "CELLSPACING=0 BORDER=1"
+ (html:caption caption 'BOTTOM)
+ (html:href-heading
+ names
+ (append (make-list primlim
+ (table-name->filename
+ (table-name->column-table-name db table-name)))
+ (make-list (- (length names) primlim) #f)))
+ (html:heading (table 'column-domains))
+ (html:href-heading foreigns tags)
+ (html:heading (table 'column-types))
+ rows))
+ (apply (table 'for-each-row)
+ (lambda (row)
+ (set! cnt (+ 1 cnt))
+ (set! rows (cons row rows))
+ (cond ((<= 50 cnt)
+ (set! tables
+ (cons (make-table
+ (map (html:linked-row-converter primlim tags)
+ (reverse rows)))
+ tables))
+ (set! cnt 0)
+ (set! rows '()))))
+ args)
+ (apply string-append
+ (reverse (if (and (null? rows) (not (null? tables)))
+ tables
+ (cons (make-table
+ (map (html:linked-row-converter primlim tags)
+ (reverse rows)))
+ tables))))))
;;@body
;;Returns a complete HTML page. The string @3 names the page which
@@ -162,10 +186,10 @@
(html:body (apply table->linked-html table-name db table-name args))))
(define (html:catalog-row-converter row foreigns)
- (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (sprintf #f " <TR VALIGN=TOP>\\n%s\\n"
(apply string-append
(map (lambda (datum foreign)
- (sprintf #f " <TD>%s%s</TD>\\n"
+ (sprintf #f " <TD>%s%s\\n"
(html:anchor (sprintf #f "%s" datum))
(html:link (make-uri foreign #f #f) datum)))
row foreigns))))
@@ -384,7 +408,7 @@
(else (list fld))))
row arities)
foreign-choice-lists))
- (sprintf #f " <TR>\\n <TD>%s</TD>%s\\n </TR>\\n"
+ (sprintf #f " <TR>\\n <TD>%s%s\\n\\n"
(string-append
(html:hidden '*row-hash* (crc:hash-obj row))
(html:hidden '*keys* (uri:make-path (butnthcdr pkl row)))
@@ -394,7 +418,7 @@
;; (form:image "Modify Row" "/icons/bang.png")
)
(apply string-append
- (map (lambda (elt) (sprintf #f " <TD>%s</TD>\\n" elt))
+ (map (lambda (elt) (sprintf #f " <TD>%s\\n" elt))
(cdr elements))))))))
;;@args k names edit-point edit-converter
@@ -427,11 +451,11 @@
(else (html:pre str))))))))
(lambda (row)
(string-append
- (sprintf #f " <TR VALIGN=TOP>\\n%s </TR>\\n"
+ (sprintf #f " <TR VALIGN=TOP>\\n%s\\n"
(apply string-append
(map (lambda (idx datum foreign)
(sprintf
- #f " <TD>%s%s</TD>\\n"
+ #f " <TD>%s%s\\n"
(if (eqv? 1 idx) (row->anchor pkl row) "")
(cond ((or (not datum) (null? datum)) "")
((<= idx pkl)
@@ -487,7 +511,7 @@
(if (symbol? dir) (set! dir (symbol->string dir)))
(if (not (file-exists? dir)) (make-directory dir))
(db->html-files db dir index-filename dir)
- (path->uri (in-vicinity (sub-vicinity "" dir) index-filename)))
+ (path->uri (in-vicinity (sub-vicinity (user-vicinity) dir) index-filename)))
;;@args db dir index-filename
;;@args db dir