Import Upstream version 2c7upstream/2c7

author: Bryan Newbold <bnewbold@robocracy.org> 2017-02-20 00:05:28 -0800
committer: Bryan Newbold <bnewbold@robocracy.org> 2017-02-20 00:05:28 -0800
commit: bd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree: 2c99dced547d48407ad44cb0e45e31bb4d02ce43 /htmlform.scm
parent: fa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
download: slib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz
slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip
1 files changed, 232 insertions, 46 deletions
diff --git a/htmlform.scm b/htmlform.scm
index f8656e2..c7ce1dc 100644
--- a/htmlform.scm
+++ b/htmlform.scm
@@ -1,5 +1,4 @@
-;;; "htmlform.scm" Generate HTML 2.0 forms and		-*-scheme-*-
-;;;  service CGI requests from RDB command table.
+;;; "htmlform.scm" Generate HTML 2.0 forms; service CGI requests. -*-scheme-*-
 ; Copyright 1997, 1998 Aubrey Jaffer
 ;
 ;Permission to copy this software, to redistribute it, and to use it
@@ -25,6 +24,8 @@
 (require 'parameters)
 (require 'fluid-let)
 (require 'dynamic-wind)
+(require 'pretty-print)
+(require 'object->string)
 (require 'string-case)
 (require 'string-port)
 (require 'string-search)
@@ -41,71 +42,267 @@
 
 ;;@body Returns a string with character substitutions appropriate to
 ;;send @1 as an @dfn{attribute-value}.
-(define (html:atval txt)		; attribute-value
+(define (make-atval txt)		; attribute-value
   (if (symbol? txt) (set! txt (symbol->string txt)))
-  (string-subst txt
-		"&" "&amp;"
-		"\"" "&quot;"
-		"<" "&lt;"
-		">" "&gt;"))
+  (if (number? txt)
+      (number->string txt)
+      (string-subst (if (string? txt) txt (object->string txt))
+		    "&" "&amp;"
+		    "\"" "&quot;"
+		    "<" "&lt;"
+		    ">" "&gt;")))
 
 ;;@body Returns a string with character substitutions appropriate to
 ;;send @1 as an @dfn{plain-text}.
-(define (html:plain txt)		; plain-text `Data Characters'
+(define (make-plain txt)		; plain-text `Data Characters'
   (if (symbol? txt) (set! txt (symbol->string txt)))
-  (string-subst txt
-		"&" "&amp;"
-		"<" "&lt;"
-		">" "&gt;"))
+  (if (number? txt)
+      (number->string txt)
+      (string-subst (if (string? txt) txt (object->string txt))
+		    "&" "&amp;"
+		    "<" "&lt;"
+		    ">" "&gt;")))
+
+;;@args title backlink tags ...
+;;@args title backlink
+;;@args title
+;;
+;;Outputs headers for an HTML page named @1.  If string arguments @2
+;;... are supplied they are printed verbatim within the @t{<HEAD>}
+;;section.
+(define (html:start-page title . args)
+  (define backlink (if (null? args) #f (car args)))
+  (if (not (null? args)) (set! args (cdr args)))
+  (html:printf "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">\\n")
+  (html:printf "<HTML>\\n")
+  (html:comment "HTML by SLIB"
+		"http://swissnet.ai.mit.edu/~jaffer/SLIB.html")
+  (html:printf "<HEAD>%s<TITLE>%s</TITLE></HEAD>\\n"
+	       (apply string-append args) (make-plain title))
+  (html:printf "<BODY><H1>%s</H1>\\n"
+	       (or backlink (make-plain title))))
+
+;;@body Outputs HTML codes to end a page.
+(define (html:end-page)
+  (html:printf "</BODY>\\n")
+  (html:printf "</HTML>\\n"))
+
+;;@body Writes (using @code{html:printf}) the strings @1, @2 as
+;;@dfn{PRE}formmated plain text (rendered in fixed-width font).
+;;Newlines are inserted between @1, @2.  HTML tags (@samp{<tag>})
+;;within @2 will be visible verbatim.
+(define (html:pre line1 . lines)
+  (html:printf "<PRE>\\n%s" (make-plain line1))
+  (for-each (lambda (line) (html:printf "\\n%s" (make-plain line))) lines)
+  (html:printf "</PRE>\\n"))
 
 ;;@body Writes (using @code{html:printf}) the strings @1 as HTML
 ;;comments.
-(define (html:comment . lines)
+(define (html:comment line1 . lines)
   (html:printf "<!")
+  (if (substring? "--" line1)
+      (slib:error 'html:comment "line contains --" line1)
+      (html:printf "--%s--" line1))
   (for-each (lambda (line)
 	      (if (substring? "--" line)
 		  (slib:error 'html:comment "line contains --" line)
-		  (html:printf "--%s--\\n" line)))
+		  (html:printf "\\n  --%s--" line)))
 	    lines)
   (html:printf ">\\n"))
 
+;;@section HTML Tables
+
+;;@body
+(define (html:start-table caption)
+  (html:printf "<TABLE BORDER WIDTH=\"100%%\">\\n")
+  (html:printf "<CAPTION ALIGN=BOTTOM>%s</CAPTION>\\n" (make-plain caption)))
+
+;;@body
+(define (html:end-table)
+  (html:printf "</TABLE>\\n"))
+
+;;@body Outputs a heading row for the currently-started table.
+(define (html:heading columns)
+  (html:printf "<TR VALIGN=\"TOP\">\\n")
+  (for-each (lambda (datum) (html:printf "<TH>%s\\n" (or datum ""))) columns))
+
+;;@body Outputs a heading row with column-names @1 linked to URLs @2.
+(define (html:href-heading columns urls)
+  (html:heading
+   (map (lambda (column url)
+	  (if url
+	      (sprintf #f "<A HREF=\"%s\">%s</A>" url column)
+	      column))
+	columns urls)))
+
+;;@args k foreigns
+;;
+;;The positive integer @1 is the primary-key-limit (number of
+;;primary-keys) of the table.  @2 is a list of the filenames of
+;;foreign-key field pages and #f for non foreign-key fields.
+;;
+;;@0 returns a procedure taking a row for its single argument.  This
+;;returned procedure prints the table row to @var{*html:output-port*}.
+(define (make-row-converter pkl foreigns)
+  (lambda (data-row)
+    (define anchored? #f)
+    (define (present datum)
+      (cond ((or (string? datum) (symbol? datum))
+	     (html:printf "%s" (make-plain datum)))
+	    (else
+	     (html:printf
+	      "<PRE>\\n%s</PRE>\\n"
+	      (make-plain (call-with-output-string
+			   (lambda (port)
+			     (pretty-print datum port))))))))
+    (html:printf "<TR VALIGN=\"TOP\">")
+    (for-each (lambda (datum foreign)
+		(html:printf "<TD>")
+		(cond ((not datum))
+		      ((null? datum))
+		      ((not anchored?)
+		       (html:printf "<A NAME=\"")
+		       (cond
+			((zero? pkl)
+			 (html:printf "%s" (make-atval datum)))
+			(else (html:printf
+			       "%s" (make-atval (car data-row)))
+			      (do ((idx 1 (+ 1 idx))
+				   (contents (cdr data-row) (cdr contents)))
+				  ((>= idx pkl))
+				(html:printf
+				 " %s" (make-atval (car contents))))))
+		       (html:printf "\">")
+		       (set! anchored? (not (zero? pkl)))))
+		(cond ((not datum)) ((null? datum))
+		      ((not foreign) (present datum))
+		      ((zero? pkl)
+		       (html:printf "<A HREF=\"%s\">" foreign)
+		       (present datum)
+		       (html:printf "</A>"))
+		      (else
+		       (html:printf "<A HREF=\"%s#%s\">"
+				    foreign (make-atval datum))
+		       (present datum)
+		       (html:printf "</A>"))))
+	      data-row foreigns)
+    (html:printf "\\n")))
+
+;;@body
+;;Returns the symbol @1 converted to a filename.
+(define (table-name->filename table-name)
+  (and table-name (string-append
+		   (string-subst (symbol->string table-name) "*" "" ":" "_")
+		   ".html")))
+
+(define (table-name->column-table-name db table-name)
+  ((((db 'open-table) '*catalog-data* #f) 'get 'coltab-name)
+   table-name))
+
+;;@args caption db table-name match-key1 @dots{}
+;;Writes HTML for @2 table @3 to @var{*html:output-port*}.
+;;
+;;The optional @4 @dots{} arguments restrict actions to a subset of
+;;the table.  @xref{Table Operations, match-key}.
+(define (table->html caption db table-name . args)
+  (let* ((table ((db 'open-table) table-name #f))
+	 (foreigns (table 'column-foreigns))
+	 (tags (map table-name->filename foreigns))
+	 (names (table 'column-names))
+	 (primlim (table 'primary-limit)))
+    (html:start-table caption)
+    (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))
+    (apply (table 'for-each-row) (make-row-converter primlim tags) args)
+    (html:end-table)))
+
+;;@body
+;;Writes a complete HTML page to @var{*html:output-port*}.  The string
+;;@3 names the page which refers to this one.
+(define (table->page db table-name index-filename)
+  (dynamic-wind
+      (lambda ()
+	(if index-filename
+	    (html:start-page
+	     table-name
+	     (sprintf #f "<A HREF=\"%s#%s\">%s</A>"
+		      index-filename
+		      (make-atval table-name)
+		      (make-plain table-name)))
+	    (html:start-page table-name)))
+      (lambda () (table->html table-name db table-name))
+      html:end-page))
+
+;;@body
+;;Writes HTML for the catalog table of @1 to @var{*html:output-port*}.
+(define	(catalog->html db caption)
+  (html:start-table caption)
+  (html:heading '(table columns))
+  ((((db 'open-table) '*catalog-data* #f) 'for-each-row)
+   (lambda (row)
+     (cond ((and (eq? '*columns* (caddr row))
+		 (not (eq? '*columns* (car row)))))
+	   (else ((make-row-converter
+		   0 (list (table-name->filename (car row))
+			   (table-name->filename (caddr row))))
+		  (list (car row) (caddr row))))))))
+
+;;@body
+;;Writes a complete HTML page for the catalog of @1 to
+;;@var{*html:output-port*}.
+(define (catalog->page db caption)
+  (dynamic-wind
+      (lambda () (html:start-page caption))
+      (lambda ()
+	(catalog->html db caption)
+	(html:end-table))
+      html:end-page))
+
+;;@section HTML Forms
+
 (define (html:dt-strong-doc name doc)
   (if (and (string? doc) (not (equal? "" doc)))
       (html:printf "<DT><STRONG>%s</STRONG> (%s)\\n"
-		   (html:plain name) (html:plain doc))
-      (html:printf "<DT><STRONG>%s</STRONG>\\n" (html:plain name))))
+		   (make-plain name) (make-plain doc))
+      (html:printf "<DT><STRONG>%s</STRONG>\\n" (make-plain name))))
 
 (define (html:checkbox name doc pname)
   (html:printf "<DT><INPUT TYPE=CHECKBOX NAME=%#a VALUE=T>\\n"
-	       (html:atval pname))
+	       (make-atval pname))
   (if (and (string? doc) (not (equal? "" doc)))
       (html:printf "<DD><STRONG>%s</STRONG> (%s)\\n"
-		   (html:plain name) (html:plain doc))
-      (html:printf "<DD><STRONG>%s</STRONG>\\n" (html:plain name))))
+		   (make-plain name) (make-plain doc))
+      (html:printf "<DD><STRONG>%s</STRONG>\\n" (make-plain name))))
 
 (define (html:text name doc pname default)
   (cond (default
 	  (html:dt-strong-doc name doc)
 	  (html:printf "<DD><INPUT NAME=%#a SIZE=%d VALUE=%#a>\\n"
-		       (html:atval pname)
+		       (make-atval pname)
 		       (max 20 (string-length
 				(if (symbol? default)
 				    (symbol->string default) default)))
-		       (html:atval default)))
+		       (make-atval default)))
 	(else
 	 (html:dt-strong-doc name doc)
-	 (html:printf "<DD><INPUT NAME=%#a>\\n" (html:atval pname)))))
+	 (html:printf "<DD><INPUT NAME=%#a>\\n" (make-atval pname)))))
 
 (define (html:text-area name doc pname default-list)
   (html:dt-strong-doc name doc)
   (html:printf "<DD><TEXTAREA NAME=%#a ROWS=%d COLS=%d>\\n"
-	       (html:atval pname) (max 2 (length default-list))
+	       (make-atval pname) (max 2 (length default-list))
 	       (apply max 32 (map (lambda (d) (string-length
 					       (if (symbol? d)
 						   (symbol->string d)
 						   d)))
 				  default-list)))
-  (for-each (lambda (line) (html:printf "%s\\n" (html:plain line))) default-list)
+  (for-each (lambda (line) (html:printf "%s\\n" (make-plain line))) default-list)
   (html:printf "</TEXTAREA>\\n"))
 
 (define (html:s<? s1 s2)
@@ -118,7 +315,7 @@
   (set! value-list (sort! value-list html:s<?))
   (html:dt-strong-doc name doc)
   (html:printf "<DD><SELECT NAME=%#a SIZE=%d%s>\\n"
-	       (html:atval pname)
+	       (make-atval pname)
 	       (case arity
 		 ((single optional) 1)
 		 ((nary nary1) 5))
@@ -127,10 +324,10 @@
 		 (else "")))
   (for-each (lambda (value)
 	      (html:printf "<OPTION VALUE=%#a%s>%s\\n"
-			   (html:atval value)
+			   (make-atval value)
 			   (if (member value default-list)
 			       " SELECTED" "")
-			   (html:plain value)))
+			   (make-plain value)))
 	    (case arity
 	      ((optional nary) (cons (string->symbol "") value-list))
 	      (else value-list)))
@@ -145,17 +342,17 @@
      (for-each (lambda (value)
 		 (html:printf
 		  "<LI><INPUT TYPE=RADIO NAME=%#a VALUE=%#a%s> %s\\n"
-		  (html:atval pname) (html:atval value)
+		  (make-atval pname) (make-atval value)
 		  (if (member value default-list) " CHECKED" "")
-		  (html:plain value)))
+		  (make-plain value)))
 	       value-list))
     ((nary nary1)
      (for-each (lambda (value)
 		 (html:printf
 		  "<LI><INPUT TYPE=CHECKBOX NAME=%#a VALUE=%#a%s> %s\\n"
-		  (html:atval pname) (html:atval value)
+		  (make-atval pname) (make-atval value)
 		  (if (member value default-list) " CHECKED" "")
-		  (html:plain value)))
+		  (make-plain value)))
 	       value-list)))
   (html:printf "</MENU>"))
 
@@ -166,7 +363,7 @@
   (cond ((not (memq method '(get head post put delete)))
 	 (slib:error 'html:start-form "method unknown:" method)))
   (html:printf "<FORM METHOD=%#a ACTION=%#a>\\n"
-	       (html:atval method) (html:atval action))
+	       (make-atval method) (make-atval action))
   (html:printf "<DL>\\n"))
 
 ;;@body @0 prints the footer for an HTML @dfn{form}.  The string @2
@@ -174,20 +371,9 @@
 (define (html:end-form pname submit-label)
   (html:printf "</DL>\\n")
   (html:printf "<INPUT TYPE=SUBMIT NAME=%#a VALUE=%#a> <INPUT TYPE=RESET>\\n"
-	       (html:atval '*command*) (html:atval submit-label))
+	       (make-atval '*command*) (make-atval submit-label))
   (html:printf "</FORM><HR>\\n"))
 
-;;@body Outputs headers for an HTML page named @1.
-(define (html:start-page title)
-  (html:printf "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\\n")
-  (html:comment)
-  (html:printf "<HEAD><TITLE>%s</TITLE></HEAD>\\n" (html:plain title))
-  (html:printf "<BODY><H1>%s</H1>\\n" (html:plain title)))
-
-;;@body Outputs HTML codes to end a page.
-(define (html:end-page)
-  (html:printf "</BODY>\\n"))
-
 (define (html:generate-form comname method action docu pnames docs aliases
 			    arities types default-lists value-lists)
   (define aliast (map list pnames))
@@ -198,7 +384,7 @@
   (dynamic-wind
    (lambda ()
      (html:printf "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n"
-		  (html:plain comname) (html:plain docu))
+		  (make-plain comname) (make-plain docu))
      (html:start-form 'post action))
    (lambda ()
      (for-each
author	Bryan Newbold <bnewbold@robocracy.org>	2017-02-20 00:05:28 -0800
committer	Bryan Newbold <bnewbold@robocracy.org>	2017-02-20 00:05:28 -0800
commit	bd9733926076885e3417b74de76e4c9c7bc56254 (patch)
tree	2c99dced547d48407ad44cb0e45e31bb4d02ce43 /htmlform.scm
parent	fa3f23105ddcf07c5900de47f19af43d1db1b597 (diff)
download	slib-bd9733926076885e3417b74de76e4c9c7bc56254.tar.gz slib-bd9733926076885e3417b74de76e4c9c7bc56254.zip