scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
sunet/scheme/lib/htmlout.scm

225 lines
6.7 KiB
Scheme
Raw Normal View History

Moved from top-level directory.
2002-06-08 11:07:01 -04:00
;;; Simple code for doing structured html output. -*- Scheme -*-
Add copyright notice.
2002-08-27 05:03:22 -04:00
;;; This file is part of the Scheme Untergrund Networking package.
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
;;; Copyright (c) 1995 by Olin Shivers.
Add copyright notice.
2002-08-27 05:03:22 -04:00
;;; Copyright (c) 1996 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
;;; - An attribute-quoter, that will map an attribute value to its
;;; HTML text representation -- surrounding it with single or double quotes,
;;; as appropriate, etc.
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
;;XHTML 1.0 Strict
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a well-formed XML document begins with a prolog;
;; this is the prolog for an XHTML 1.0 strict document:
(define XMLdecl
"<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>")
(define doctypedecl
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
(define (emit-prolog out)
(display XMLdecl out)
(newline out)
(display doctypedecl out)
(newline out))
;; the root element html must contain an xmlns declaration for the
;; XHTML namespace, which ist defined to be
;; http://www.w3.org/1999/xhtml
(define xmlnsval "http://www.w3.org/1999/xhtml")
;; for use with emit-tag and with-tag:
(define xmlnsdecl-attr (cons 'xmlns xmlnsval))
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
;;; Printing HTML tags.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All the emit-foo procedures have the same basic calling conventions:
;;; (emit-foo out <required values> ... [<extra attributes> ...])
;;; - OUT is either a port or #t for the current input port.
;;; - Each attribute is either a (name . value) pair, which is printed as
;;; name="value"
;;; or a single symbol or string, which is simply printed as-is
;;; (this is useful for attributes that don't have values, such as the
;;; ISMAP attribute in <img> tags).
;;; <tag name1="val1" name2="val2" ...>
(define (emit-tag out tag . attrs)
(let ((out (fmt->port out)))
(display "<" out)
(display tag out)
(for-each (lambda (attr)
(display #\space out)
(cond ((pair? attr) ; name="val"
(display (car attr) out)
(display "=\"" out) ; Should check for
(display (cdr attr) out) ; internal double-quote
(display #\" out)) ; etc.
(else
(display attr out)))) ; name
attrs)
(display #\> out)))
;;; </tag>
(define (emit-close-tag out tag)
(format out "</~a>" tag))
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
;;; <p>
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
(define (emit-p . args) ; (emit-p [out attr1 ...])
(receive (out attrs) (if (pair? args)
(let* ((out (car args)))
(values (if (eq? out #t) (current-output-port) out)
(cdr args)))
(values (current-output-port) args))
Elide some potentially harmful newlines.
2002-08-26 05:33:36 -04:00
(apply emit-tag out 'p attrs)))
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
;;; <title> Make Money Fast!!! </title>
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
(define (emit-title out title) ; Takes no attributes.
emit less newlines
2004-08-15 08:40:06 -04:00
(format out "<title>~a</title>" title))
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
(define (emit-header out level text . attribs)
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
(apply with-tag* out (string-append "h" (number->string level))
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
(lambda () (display text (fmt->port out)))
attribs))
;;; ...and so forth. Could stand to define a bunch of little emitters for the
;;; various tags. (define-tag-emitter ...)
;;; Printing out balanced <tag> ... </tag> pairs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; (with-tag out tag (attr-elt ...) body ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Execute the body forms between a <tag attrs> ... </tag> pair.
;;; The (ATTR-ELT ...) list specifies the attributes for the <tag>.
;;; It is rather like a LET-list, having the form
;;; ((name val) ...)
;;; Each NAME must be a symbol, and each VAL must be a Scheme expression
;;; whose value is the string to use as attribute NAME's value. Attributes
;;; that have no value (e.g., ISMAP) can be specified as attr-elt NAME,
;;; instead of (NAME VALUE).
;;;
;;; For example,
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
;;; (let ((hp-url "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port a ((href hp-url) (name "hp"))
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
;;; (display "home page" port)))
;;; outputs
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
;;; <a href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</a>
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
(define-syntax with-tag
(syntax-rules ()
((with-tag out tag (attr-elt ...) body ...)
(with-tag* out 'tag (lambda () body ...)
(%hack-attr-elt attr-elt)
...))))
;;; Why does this have to be top-level?
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
(define-syntax %hack-attr-elt
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
(syntax-rules (xmlnsdecl-attr) ; Build attribute-list element:
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
(cons 'name val))
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00
((%hack-attr-elt xmlnsdecl-attr)
xmlnsdecl-attr)
Moved from top-level directory.
2002-06-08 11:07:01 -04:00
((%hack-attr-elt name) 'name))) ; name => 'name
;;; Execute THUNK between a <tag attrs> ... </tag> pair.
(define (with-tag* out tag thunk . attrs)
(apply emit-tag out tag attrs)
(let ((out (fmt->port out)))
(call-with-values thunk
(lambda results
(emit-close-tag out tag)
(apply values results)))))
(define (fmt->port x)
(if (eq? x #t) (current-output-port) x))
;;; Translate text to HTML, mapping special chars such as <, >, &, and
;;; double-quote to their HTML escape sequences.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Note iso8859-1 above 127 is perfectly OK
(define *html-entity-alist*
(list
(cons (ascii->char 60) "&lt;")
(cons (ascii->char 62) "&gt;")
(cons (ascii->char 38) "&amp;")
(cons (ascii->char 34) "&quot;")))
(define *html-entities*
(list->char-set (map car *html-entity-alist*)))
(define *html-entity-table*
(let ((v (make-vector 256 #f)))
(for-each (lambda (entry)
(vector-set! v
(char->ascii (car entry))
(cdr entry)))
*html-entity-alist*)
v))
(define (string-set-substring! t start s)
(let* ((l (string-length s))
(end (+ l start)))
(do ((i start (+ 1 i)))
((= i end) t)
(string-set! t i (string-ref s (- i start))))))
(define (escape-html s)
(let ((target-length
(string-fold (lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(string-length
(vector-ref *html-entity-table*
(char->ascii c)))
1)))
0
s)))
(if (= target-length (string-length s))
s
(let ((target (make-string target-length)))
(string-fold
(lambda (c i)
(+ i
(if (char-set-contains? *html-entities* c)
(let ((entity (vector-ref *html-entity-table* (char->ascii c))))
(string-set-substring! target i entity)
(string-length entity))
(begin
(string-set! target i c)
1))))
0
s)
target))))
(define (emit-text s . maybe-port)
(if (null? maybe-port)
(write-string (escape-html s))
(write-string (escape-html s) (fmt->port (car maybe-port)))))
- move XHTML stuff from responses.scm to htmlout.scm - new function EMIT-PROLOG - define XML namespace declaration - adapt macro %hack-attr-elt: special treatment of xmlnsdecl-attr (this is not nice, but the only alternative was hard-coding the XML namespace declaration into the various handlers) - element names -> lower case
2004-08-13 11:46:53 -04:00