;;; "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 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. ; ;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 dly . uri) (if (null? uri) (sprintf #f "\\n" dly) (sprintf #f "\\n" dly (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://swiss.csail.mit.edu/~jaffer/SLIB")) (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 "