scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- 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
This commit is contained in:
vibr 2004-08-13 15:46:53 +00:00
parent 96f0ae41d5
commit 6969b80206
1 changed files with 41 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
scheme/lib/htmlout.scm
View File

@ -11,6 +11,34 @@
;;; HTML text representation -- surrounding it with single or double quotes, ;;; HTML text representation -- surrounding it with single or double quotes,
;;; as appropriate, etc. ;;; as appropriate, etc.
;;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))
;;; Printing HTML tags. ;;; Printing HTML tags.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; All the emit-foo procedures have the same basic calling conventions: ;;; All the emit-foo procedures have the same basic calling conventions:
@ -49,7 +77,7 @@
(format out "</~a>" tag)) (format out "</~a>" tag))
;;; <P> ;;; <p>
(define (emit-p . args) ; (emit-p [out attr1 ...]) (define (emit-p . args) ; (emit-p [out attr1 ...])
(receive (out attrs) (if (pair? args) (receive (out attrs) (if (pair? args)
@ -61,13 +89,13 @@
(apply emit-tag out 'p attrs))) (apply emit-tag out 'p attrs)))
;;; <TITLE> Make Money Fast!!! </TITLE> ;;; <title> Make Money Fast!!! </title>
(define (emit-title out title) ; Takes no attributes. (define (emit-title out title) ; Takes no attributes.
(format out "<title>~a~%</title>~%" title)) (format out "<title>~a~%</title>" title))
(define (emit-header out level text . attribs) (define (emit-header out level text . attribs)
(apply with-tag* out (string-append "H" (number->string level)) (apply with-tag* out (string-append "h" (number->string level))
(lambda () (display text (fmt->port out))) (lambda () (display text (fmt->port out)))
attribs)) attribs))
@ -90,11 +118,11 @@
;;; instead of (NAME VALUE). ;;; instead of (NAME VALUE).
;;; ;;;
;;; For example, ;;; For example,
;;; (let ((hp "http://clark.lcs.mit.edu/~shivers")) ; My home page. ;;; (let ((hp-url "http://clark.lcs.mit.edu/~shivers")) ; My home page.
;;; (with-tag port A ((href hp-url) (name "hp")) ;;; (with-tag port a ((href hp-url) (name "hp"))
;;; (display "home page" port))) ;;; (display "home page" port)))
;;; outputs ;;; outputs
;;; <A href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</A> ;;; <a href="http://clark.lcs.mit.edu/~shivers" name="hp">home page</a>
(define-syntax with-tag (define-syntax with-tag
(syntax-rules () (syntax-rules ()
@ -107,9 +135,11 @@
;;; Why can't this be a LET-SYNTAX inside of WITH-TAG? ;;; Why can't this be a LET-SYNTAX inside of WITH-TAG?
(define-syntax %hack-attr-elt (define-syntax %hack-attr-elt
(syntax-rules () ; Build attribute-list element: (syntax-rules (xmlnsdecl-attr) ; Build attribute-list element:
((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt) ((%hack-attr-elt (name val)) ; (name elt) => (cons 'name elt)
(cons 'name val)) (cons 'name val))
((%hack-attr-elt xmlnsdecl-attr)
xmlnsdecl-attr)
((%hack-attr-elt name) 'name))) ; name => 'name ((%hack-attr-elt name) 'name))) ; name => 'name
@ -118,8 +148,10 @@
(define (with-tag* out tag thunk . attrs) (define (with-tag* out tag thunk . attrs)
(apply emit-tag out tag attrs) (apply emit-tag out tag attrs)
(let ((out (fmt->port out))) (let ((out (fmt->port out)))
(newline out)
(call-with-values thunk (call-with-values thunk
(lambda results (lambda results
(newline out)
(emit-close-tag out tag) (emit-close-tag out tag)
(apply values results))))) (apply values results)))))
@ -191,3 +223,4 @@
(if (null? maybe-port) (if (null? maybe-port)
(write-string (escape-html s)) (write-string (escape-html s))
(write-string (escape-html s) (fmt->port (car maybe-port))))) (write-string (escape-html s) (fmt->port (car maybe-port)))))