summaryrefslogtreecommitdiffstats
path: root/htmlform.scm
diff options
context:
space:
mode:
Diffstat (limited to 'htmlform.scm')
-rw-r--r--htmlform.scm74
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)