diff options
Diffstat (limited to 'htmlform.scm')
| -rw-r--r-- | htmlform.scm | 294 |
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 - "&" "&" - "\"" """ - "<" "<" - ">" ">")) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "\"" """ + "<" "<" + ">" ">"))) ;;@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 - "&" "&" - "<" "<" - ">" ">")) + (if (number? txt) + (number->string txt) + (string-subst (if (string? txt) txt (object->string txt)) + "&" "&" + "<" "<" + ">" ">"))) + +;;@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))))) |