Import Upstream version 3a2upstream/3a2

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