;;; "htmlform.scm" Generate HTML 2.0 forms. -*-scheme-*-
; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;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
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
(require 'sort)
(require 'printf)
(require 'parameters)
(require 'object->string)
(require 'string-search)
(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
;;send @1 as an @dfn{attribute-value}.
(define (html:atval txt) ; attribute-value
(if (symbol? txt) (set! txt (symbol->string 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'
(cond ((eq? html:blank txt) " ")
(else
(if (symbol? txt) (set! txt (symbol->string txt)))
(if (number? txt)
(number->string txt)
(string-subst (if (string? txt) txt (object->string txt))
"&" "&"
"<" "<"
">" ">")))))
;;@body Returns a tag of meta-information suitable for passing as the
;;third argument to @code{html:head}. The tag produced is @samp{}. The string or symbol @1 can be
;;@samp{author}, @samp{copyright}, @samp{keywords}, @samp{description},
;;@samp{date}, @samp{robots}, @dots{}.
(define (html:meta name content)
(sprintf #f "\\n" 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{}. The string or symbol @1 can be
;;@samp{Expires}, @samp{PICS-Label}, @samp{Content-Type},
;;@samp{Refresh}, @dots{}.
(define (html:http-equiv name content)
(sprintf #f "\\n"
name (html:atval content)))
;;@args delay uri
;;@args delay
;;
;;Returns a tag suitable for passing as the third argument to
;;@code{html:head}. If @2 argument is supplied, then @1 seconds after
;;displaying the page with this tag, Netscape or IE browsers will fetch
;;and display @2. Otherwise, @1 seconds after displaying the page with
;;this tag, Netscape or IE browsers will fetch and redisplay this page.
(define (html:meta-refresh delay . uri)
(if (null? uri)
(sprintf #f "\\n" delay)
(sprintf #f "\\n"
delay (car uri))))
;;@args title backlink tags ...
;;@args title backlink
;;@args title
;;
;;Returns header string for an HTML page named @1. If @2 is a string,
;;it is used verbatim between the @samp{H1} tags; otherwise @1 is
;;used. If string arguments @3 ... are supplied, then they are
;;included verbatim within the @t{} section.
(define (html:head title . args)
(define backlink (if (null? args) #f (car args)))
(if (not (null? args)) (set! args (cdr args)))
(string-append
(sprintf #f "\\n")
(sprintf #f "\\n")
(sprintf #f "%s"
(html:comment "HTML by SLIB"
"http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
(sprintf #f " \\n %s\\n %s\\n \\n"
(html:plain title) (apply string-append args))
(if (and backlink (substring-ci? "" backlink))
backlink
(sprintf #f "%s
\\n" (or backlink (html:plain title))))))
;;@body Returns HTML string to end a page.
(define (html:body . body)
(apply string-append
(append body (list (sprintf #f "\\n\\n")))))
;;@body Returns the strings @1, @2 as @dfn{PRE}formmated plain text
;;(rendered in fixed-width font). Newlines are inserted between @1,
;;@2. HTML tags (@samp{}) within @2 will be visible verbatim.
(define (html:pre line1 . lines)
(sprintf #f "\\n%s%s
"
(html:plain line1)
(string-append
(apply string-append
(map (lambda (line) (sprintf #f "\\n%s" (html:plain line)))
lines)))))
;;@body Returns the strings @1 as HTML comments.
(define (html:comment line1 . lines)
(string-append
(apply string-append
(if (substring? "--" line1)
(slib:error 'html:comment "line contains --" line1)
(sprintf #f "