summaryrefslogtreecommitdiffstats
path: root/htmlform.scm
diff options
context:
space:
mode:
Diffstat (limited to 'htmlform.scm')
-rw-r--r--htmlform.scm294
1 files changed, 240 insertions, 54 deletions
diff --git a/htmlform.scm b/htmlform.scm
index f8656e2..02dc63a 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
- "&" "&"
- "\"" """
- "<" "&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
@@ -303,7 +489,7 @@
(define len (string-length str))
(define (sub str)
(cond
- ((string-index str #\%)
+ ((strsrch:string-index str #\%)
=> (lambda (idx)
(if (and (< (+ 2 idx) len)
(string->number (substring str (+ 1 idx) (+ 2 idx)) 16)
@@ -319,7 +505,7 @@
(sub str))
(define (form:split-lines txt)
- (let ((idx (string-index txt #\newline))
+ (let ((idx (strsrch:string-index txt #\newline))
(carriage-return (integer->char #xd)))
(if idx
(cons (substring txt 0
@@ -336,11 +522,11 @@
(if (symbol? txt) (set! txt (symbol->string txt)))
(set! txt (string-subst txt " " "" "+" " "))
(do ((lst '())
- (edx (string-index txt #\=)
- (string-index txt #\=)))
+ (edx (strsrch:string-index txt #\=)
+ (strsrch:string-index txt #\=)))
((not edx) lst)
(let* ((rxt (substring txt (+ 1 edx) (string-length txt)))
- (adx (string-index rxt #\&))
+ (adx (strsrch:string-index rxt #\&))
(name (cgi:process-% (substring txt 0 edx))))
(set!
lst (append
@@ -484,7 +670,7 @@
(set! http:crlf (string (string-ref line 0) #\newline)))
(if (eof-object? line) line alist))
(let ((len (string-length line))
- (idx (string-index line #\:)))
+ (idx (strsrch:string-index line #\:)))
(if (char-whitespace? (string-ref line (+ -1 len)))
(set! len (+ -1 len)))
(and idx (do ((idx2 (+ idx 1) (+ idx2 1)))
@@ -505,9 +691,9 @@
(let* ((request-uri (cadr request-line))
(len (string-length request-uri)))
(and (> len 3)
- (string-index request-uri #\?)
+ (strsrch:string-index request-uri #\?)
(substring request-uri
- (+ 1 (string-index request-uri #\?))
+ (+ 1 (strsrch:string-index request-uri #\?))
(if (eqv? #\/ (string-ref request-uri (+ -1 len)))
(+ -1 len)
len)))))