diff options
Diffstat (limited to 'htmlform.scm')
| -rw-r--r-- | htmlform.scm | 74 |
1 files changed, 47 insertions, 27 deletions
diff --git a/htmlform.scm b/htmlform.scm index 935e006..d659aeb 100644 --- a/htmlform.scm +++ b/htmlform.scm @@ -8,7 +8,7 @@ ;1. Any copy made of this software must include this copyright notice ;in full. ; -;2. I have made no warrantee or representation that the operation of +;2. I have made no warranty or representation that the operation of ;this software will be error-free, and I am under no obligation to ;provide any services, by way of maintenance, update, or otherwise. ; @@ -22,11 +22,12 @@ (require 'parameters) (require 'object->string) (require 'string-search) -(require 'database-utilities) +(require 'databases) (require 'common-list-functions) ;;;;@code{(require 'html-form)} ;;@ftindex html-form + (define html:blank (string->symbol "")) ;;@body Returns a string with character substitutions appropriate to @@ -60,7 +61,7 @@ ;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description}, ;;@samp{date}, @samp{robots}, @dots{}. (define (html:meta name content) - (sprintf #f "\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) + (sprintf #f "\\n<META NAME=\"%s\" CONTENT=\"%s\">" name (html:atval content))) ;;@body Returns a tag of HTTP information suitable for passing as the ;;third argument to @code{html:head}. The tag produced is @samp{<META @@ -68,7 +69,7 @@ ;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type}, ;;@samp{Refresh}, @dots{}. (define (html:http-equiv name content) - (sprintf #f "\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" + (sprintf #f "\\n<META HTTP-EQUIV=\"%s\" CONTENT=\"%s\">" name (html:atval content))) ;;@args delay uri @@ -81,8 +82,8 @@ ;;this tag, Netscape or IE browsers will fetch and redisplay this page. (define (html:meta-refresh delay . uri) (if (null? uri) - (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) - (sprintf #f "\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" + (sprintf #f "\\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d\">" delay) + (sprintf #f "\\n<META HTTP-EQUIV=\"Refresh\" CONTENT=\"%d;URL=%s\">" delay (car uri)))) ;;@args title backlink tags ... @@ -101,10 +102,12 @@ (sprintf #f "<HTML>\\n") (sprintf #f "%s" (html:comment "HTML by SLIB" - "http://swissnet.ai.mit.edu/~jaffer/SLIB.html")) + "http://swissnet.ai.mit.edu/~jaffer/SLIB")) (sprintf #f " <HEAD>\\n <TITLE>%s</TITLE>\\n %s\\n </HEAD>\\n" (html:plain title) (apply string-append args)) - (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title))))) + (if (and backlink (substring-ci? "<H1>" backlink)) + backlink + (sprintf #f "<BODY><H1>%s</H1>\\n" (or backlink (html:plain title)))))) ;;@body Returns HTML string to end a page. (define (html:body . body) @@ -217,7 +220,7 @@ (let ((value-list (map car foreign-values)) (visibles (map cadr foreign-values))) (string-append - (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>" + (sprintf #f "<SELECT NAME=%#a SIZE=%d%s>\\n" (html:atval pname) (case arity ((single optional) 1) @@ -227,7 +230,7 @@ (else ""))) (apply string-append (map (lambda (value visible) - (sprintf #f "<OPTION VALUE=%#a%s>%s" + (sprintf #f "<OPTION VALUE=%#a%s>%s\\n" (html:atval value) (if (member value default-list) " SELECTED" "") (html:plain visible))) @@ -297,11 +300,6 @@ ;;@body Returns a string which generates a @dfn{reset} button. (define (form:reset) "<INPUT TYPE=RESET>") -(define (html:delimited-list . rows) - (apply string-append - "<DL>" - (append rows '("</DL>")))) - ;;@body Returns a string which generates an INPUT element for the field ;;named @1. The element appears in the created form with its ;;representation determined by its @2 and domain. For domains which @@ -363,11 +361,33 @@ (remove-if (lambda (s) (= 1 (string-length s))) (cdr aliat))) (set! longname (if (null? longname) #f (car longname))) (if longname - (string-append - "<DT>" (html:strong-doc longname doc) "<DD>" - (form:element pname arity default-list foreign-values)) + (sprintf #f "<DT>%s\\n<DD>%s\\n" + (html:strong-doc longname doc) + (form:element pname arity default-list foreign-values)) "")) +;;@body Wraps its arguments with delimited-list (@samp{DL} command. +(define (html:delimited-list . rows) + (apply string-append + "<DL>" + (append rows '("</DL>")))) + +;;;used by command:make-editable-table in db2html.scm; +;;; and by command->p-specs in htmlform.scm. +;;@body Returns a list of the @samp{visible-name} or first fields of +;;table @1. +(define (get-foreign-choices tab) + (define dlst ((tab 'get* 1))) + (do ((dlst dlst (cdr dlst)) + (vlst (if (memq 'visible-name (tab 'column-names)) + ((tab 'get* 'visible-name)) + dlst) + (cdr vlst)) + (out '() (if (member (car dlst) (cdr dlst)) + out + (cons (list (car dlst) (car vlst)) out)))) + ((null? dlst) out))) + ;;@body ;; ;;The symbol @2 names a command table in the @1 relational database. @@ -389,16 +409,16 @@ ;; (html:head 'commands) ;; (html:body ;; (sprintf #f "<H2>%s:</H2><BLOCKQUOTE>%s</BLOCKQUOTE>\\n" -;; (html:plain 'build) -;; (html:plain ((comtab 'get 'documentation) 'build))) +;; (html:plain 'build) +;; (html:plain ((comtab 'get 'documentation) 'build))) ;; (html:form -;; 'post -;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") -;; (apply html:delimited-list -;; (apply map form:delimited -;; (command->p-specs build '*commands* 'build))) -;; (form:submit 'build) -;; (form:reset)))) +;; 'post +;; (or "http://localhost:8081/buildscm" "/cgi-bin/build.cgi") +;; (apply html:delimited-list +;; (apply map form:delimited +;; (command->p-specs build '*commands* 'build))) +;; (form:submit 'build) +;; (form:reset)))) ;; port))) ;;@end example (define (command->p-specs rdb command-table command) |