#| -*-Scheme-*-
-$Id: xml-output.scm,v 1.15 2003/03/01 16:52:53 cph Exp $
+$Id: xml-output.scm,v 1.16 2003/03/05 01:14:40 cph Exp $
Copyright 2001,2002,2003 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (write-xml-file xml pathname)
+(define (write-xml xml port . options)
+ (write-xml-1 xml port options))
+
+(define (write-xml-file xml pathname . options)
(call-with-output-file pathname
(lambda (port)
- (write-xml xml port))))
+ (write-xml-1 xml port options))))
-(define (xml->string xml)
+(define (xml->string xml . options)
(call-with-output-string
(lambda (port)
- (write-xml xml port))))
+ (write-xml-1 xml port options))))
+
+(define (xml->wide-string xml . options)
+ (call-with-wide-output-string
+ (lambda (port)
+ (write-xml-1 xml port options))))
+
+(define (write-xml-1 xml port options)
+ (%write-xml xml (make-ctx port options)))
+
+(define-structure (ctx (type-descriptor ctx-rtd)
+ (keyword-constructor %make-ctx)
+ (print-procedure
+ (standard-unparser-method 'XML-OUTPUT-CONTEXT #f)))
+ (port #f read-only #t)
+ ;; Either a non-negative integer (# of columns) or #f.
+ (start-indent #f read-only #t))
+
+(define (make-ctx port options)
+ (apply %make-ctx 'PORT port options))
+
+(define (emit-char char ctx)
+ (write-char char (ctx-port ctx)))
-(define-generic write-xml (object port))
+(define (emit-string string ctx)
+ (write-string string (ctx-port ctx)))
-(define-method write-xml ((document xml-document-rtd) port)
+(define (emit-newline ctx)
+ (newline (ctx-port ctx)))
+
+(define (ctx-start-col ctx)
+ (let ((indent (ctx-start-indent ctx))
+ (col (output-port/column (ctx-port ctx))))
+ (and indent
+ col
+ (+ indent col))))
+
+(define (ctx-x-size ctx)
+ (output-port/x-size (ctx-port ctx)))
+\f
+(define-generic %write-xml (object ctx))
+
+(define-method %write-xml ((document xml-document-rtd) ctx)
(if (xml-document-declaration document)
- (write-xml (xml-document-declaration document) port))
- (for-each (lambda (object) (write-xml object port))
+ (%write-xml (xml-document-declaration document) ctx))
+ (for-each (lambda (object) (%write-xml object ctx))
(xml-document-misc-1 document))
(if (xml-document-dtd document)
- (write-xml (xml-document-dtd document) port))
- (for-each (lambda (object) (write-xml object port))
+ (%write-xml (xml-document-dtd document) ctx))
+ (for-each (lambda (object) (%write-xml object ctx))
(xml-document-misc-2 document))
- (write-xml (xml-document-root document) port)
- (for-each (lambda (object) (write-xml object port))
+ (%write-xml (xml-document-root document) ctx)
+ (for-each (lambda (object) (%write-xml object ctx))
(xml-document-misc-3 document)))
-(define-method write-xml ((declaration xml-declaration-rtd) port)
- (write-string "<?xml version=\"" port)
- (write-string (xml-declaration-version declaration) port)
- (write-string "\"" port)
+(define-method %write-xml ((declaration xml-declaration-rtd) ctx)
+ (emit-string "<?xml version=\"" ctx)
+ (emit-string (xml-declaration-version declaration) ctx)
+ (emit-string "\"" ctx)
(if (xml-declaration-encoding declaration)
(begin
- (write-string " encoding=\"" port)
- (write-string (xml-declaration-encoding declaration) port)
- (write-string "\"" port)))
+ (emit-string " encoding=\"" ctx)
+ (emit-string (xml-declaration-encoding declaration) ctx)
+ (emit-string "\"" ctx)))
(if (xml-declaration-standalone declaration)
(begin
- (write-string " standalone=\"" port)
- (write-string (xml-declaration-standalone declaration) port)
- (write-string "\"" port)))
- (write-string "?>" port))
+ (emit-string " standalone=\"" ctx)
+ (emit-string (xml-declaration-standalone declaration) ctx)
+ (emit-string "\"" ctx)))
+ (emit-string "?>" ctx))
-(define-method write-xml ((element xml-element-rtd) port)
+(define-method %write-xml ((element xml-element-rtd) ctx)
(let ((name (xml-element-name element))
(contents (xml-element-contents element)))
- (write-string "<" port)
- (write-xml-name name port)
+ (emit-string "<" ctx)
+ (write-xml-name name ctx)
(write-xml-attributes (xml-element-attributes element)
(if (pair? contents) 1 3)
- port)
+ ctx)
(if (pair? contents)
(begin
- (write-string ">" port)
- (for-each (lambda (content) (write-xml content port))
+ (emit-string ">" ctx)
+ (for-each (lambda (content) (%write-xml content ctx))
contents)
- (write-string "</" port)
- (write-xml-name (xml-element-name element) port)
- (write-string ">" port))
- (write-string " />" port))))
-
-(define-method write-xml ((comment xml-comment-rtd) port)
- (write-string "<!--" port)
- (write-string (xml-comment-text comment) port)
- (write-string "-->" port))
-
-(define-method write-xml ((pi xml-processing-instructions-rtd) port)
- (write-string "<?" port)
- (write-xml-name (xml-processing-instructions-name pi) port)
- (write-string (xml-processing-instructions-text pi) port)
- (write-string "?>" port))
+ (emit-string "</" ctx)
+ (write-xml-name (xml-element-name element) ctx)
+ (emit-string ">" ctx))
+ (emit-string " />" ctx))))
+
+(define-method %write-xml ((comment xml-comment-rtd) ctx)
+ (emit-string "<!--" ctx)
+ (emit-string (xml-comment-text comment) ctx)
+ (emit-string "-->" ctx))
+
+(define-method %write-xml ((pi xml-processing-instructions-rtd) ctx)
+ (emit-string "<?" ctx)
+ (write-xml-name (xml-processing-instructions-name pi) ctx)
+ (emit-string (xml-processing-instructions-text pi) ctx)
+ (emit-string "?>" ctx))
\f
-(define-method write-xml ((dtd xml-dtd-rtd) port)
+(define-method %write-xml ((dtd xml-dtd-rtd) ctx)
;;root external internal
- (write-string "<!DOCTYPE " port)
- (let ((indent (output-port/column port)))
- (write-xml-name (xml-dtd-root dtd) port)
+ (emit-string "<!DOCTYPE " ctx)
+ (let ((col (ctx-start-col ctx)))
+ (write-xml-name (xml-dtd-root dtd) ctx)
(if (xml-dtd-external dtd)
- (write-xml-external-id (xml-dtd-external dtd) indent port))
+ (write-xml-external-id (xml-dtd-external dtd) col ctx))
(if (pair? (xml-dtd-internal dtd))
(begin
(if (xml-dtd-external dtd)
- (newline port)
- (write-string " " port))
- (write-string "[" port)
- (newline port)
+ (emit-newline ctx)
+ (emit-string " " ctx))
+ (emit-string "[" ctx)
+ (emit-newline ctx)
(for-each (lambda (element)
- (write-xml element port)
- (newline port))
+ (%write-xml element ctx)
+ (emit-newline ctx))
(xml-dtd-internal dtd))
- (write-string "]" port)))
- (write-string ">" port)))
+ (emit-string "]" ctx)))
+ (emit-string ">" ctx)))
-(define-method write-xml ((decl xml-!element-rtd) port)
- (write-string "<!ELEMENT " port)
- (write-xml-name (xml-!element-name decl) port)
- (write-string " " port)
+(define-method %write-xml ((decl xml-!element-rtd) ctx)
+ (emit-string "<!ELEMENT " ctx)
+ (write-xml-name (xml-!element-name decl) ctx)
+ (emit-string " " ctx)
(let ((type (xml-!element-content-type decl)))
(cond ((symbol? type)
- (write-string (string-upcase (symbol-name type)) port))
+ (emit-string (string-upcase (symbol-name type)) ctx))
((and (pair? type) (eq? (car type) 'MIX))
- (write-string "(#PCDATA" port)
+ (emit-string "(#PCDATA" ctx)
(if (pair? (cdr type))
(begin
(for-each (lambda (name)
- (write-string "|" port)
- (write-xml-name name port))
+ (emit-string "|" ctx)
+ (write-xml-name name ctx))
(cdr type))
- (write-string ")*" port))
- (write-string ")" port)))
+ (emit-string ")*" ctx))
+ (emit-string ")" ctx)))
(else
(letrec
((write-children
(if (not (and (pair? type)
(list? (cdr type))))
(lose))
- (write-string "(" port)
+ (emit-string "(" ctx)
(write-cp (cadr type))
(for-each
(let ((sep (if (eq? (car type) 'ALT) "|" ",")))
(lambda (type)
- (write-string sep port)
+ (emit-string sep ctx)
(write-cp type)))
(cddr type))
- (write-string ")" port)))))
+ (emit-string ")" ctx)))))
(write-cp
(lambda (type)
(handle-iterator type
(lambda (type)
(if (symbol? type)
- (write-xml-name type port)
+ (write-xml-name type ctx)
(write-children type))))))
(handle-iterator
(lambda (type procedure)
(null? (cddr type)))
(begin
(procedure (cadr type))
- (write-char (car type) port))
+ (emit-char (car type) ctx))
(procedure type))))
(lose
(lambda ()
(error "Malformed !ELEMENT content type:" type))))
(write-children type)))))
- (write-string ">" port))
+ (emit-string ">" ctx))
\f
-(define-method write-xml ((decl xml-!attlist-rtd) port)
- (write-string "<!ATTLIST " port)
- (write-xml-name (xml-!attlist-name decl) port)
+(define-method %write-xml ((decl xml-!attlist-rtd) ctx)
+ (emit-string "<!ATTLIST " ctx)
+ (write-xml-name (xml-!attlist-name decl) ctx)
(let ((definitions (xml-!attlist-definitions decl))
(write-definition
(lambda (definition)
- (write-xml-name (car definition) port)
- (write-string " " port)
+ (write-xml-name (car definition) ctx)
+ (emit-string " " ctx)
(let ((type (cadr definition)))
(cond ((symbol? type)
- (write-string (string-upcase (symbol-name type)) port))
+ (emit-string (string-upcase (symbol-name type)) ctx))
((and (pair? type) (eq? (car type) 'NOTATION))
- (write-string "NOTATION (" port)
+ (emit-string "NOTATION (" ctx)
(if (pair? (cdr type))
(begin
- (write-xml-name (cadr type) port)
+ (write-xml-name (cadr type) ctx)
(for-each (lambda (name)
- (write-string "|" port)
- (write-xml-name name port))
+ (emit-string "|" ctx)
+ (write-xml-name name ctx))
(cddr type))))
- (write-string ")" port))
+ (emit-string ")" ctx))
((and (pair? type) (eq? (car type) 'ENUMERATED))
- (write-string "(" port)
+ (emit-string "(" ctx)
(if (pair? (cdr type))
(begin
- (write-xml-name (cadr type) port)
+ (write-xml-name (cadr type) ctx)
(for-each (lambda (name)
- (write-string "|" port)
- (write-xml-name name port))
+ (emit-string "|" ctx)
+ (write-xml-name name ctx))
(cddr type))))
- (write-string ")" port))
+ (emit-string ")" ctx))
(else
(error "Malformed !ATTLIST type:" type))))
- (write-string " " port)
+ (emit-string " " ctx)
(let ((default (caddr definition)))
(cond ((eq? default 'REQUIRED)
- (write-string "#REQUIRED" port))
+ (emit-string "#REQUIRED" ctx))
((eq? default 'IMPLIED)
- (write-string "#IMPLIED" port))
+ (emit-string "#IMPLIED" ctx))
((and (pair? default) (eq? (car default) 'FIXED))
- (write-string "#FIXED" port)
- (write-string " " port)
- (write-xml-attribute-value (cdr default) port))
+ (emit-string "#FIXED" ctx)
+ (emit-string " " ctx)
+ (write-xml-attribute-value (cdr default) ctx))
((and (pair? default) (eq? (car default) 'DEFAULT))
- (write-xml-attribute-value (cdr default) port))
+ (write-xml-attribute-value (cdr default) ctx))
(else
(error "Malformed !ATTLIST default:" default)))))))
(if (pair? definitions)
(if (pair? (cdr definitions))
(for-each (lambda (definition)
- (newline port)
- (write-string " " port)
+ (emit-newline ctx)
+ (emit-string " " ctx)
(write-definition definition))
definitions)
(begin
- (write-string " " port)
+ (emit-string " " ctx)
(write-definition (car definitions))))))
- (write-string ">" port))
+ (emit-string ">" ctx))
\f
-(define-method write-xml ((decl xml-!entity-rtd) port)
- (write-string "<!ENTITY " port)
- (let ((indent (output-port/column port)))
- (write-xml-name (xml-!entity-name decl) port)
- (write-string " " port)
- (write-entity-value (xml-!entity-value decl) indent port)
- (write-string ">" port)))
-
-(define-method write-xml ((decl xml-unparsed-!entity-rtd) port)
- (write-string "<!ENTITY " port)
- (let ((indent (output-port/column port)))
- (write-xml-name (xml-unparsed-!entity-name decl) port)
- (write-string " " port)
- (write-xml-external-id (xml-unparsed-!entity-id decl) indent port)
- (write-string " NDATA " port)
- (write-xml-name (xml-unparsed-!entity-notation decl) port)
- (write-string ">" port)))
-
-(define-method write-xml ((decl xml-parameter-!entity-rtd) port)
- (write-string "<!ENTITY " port)
- (let ((indent (output-port/column port)))
- (write-string "% " port)
- (write-xml-name (xml-parameter-!entity-name decl) port)
- (write-string " " port)
- (write-entity-value (xml-parameter-!entity-value decl) indent port)
- (write-string ">" port)))
-
-(define-method write-xml ((decl xml-!notation-rtd) port)
- (write-string "<!NOTATION " port)
- (let ((indent (output-port/column port)))
- (write-xml-name (xml-!notation-name decl) port)
- (write-string " " port)
- (write-xml-external-id (xml-!notation-id decl) indent port)
- (write-string ">" port)))
-
-(define-method write-xml ((string <string>) port)
+(define-method %write-xml ((decl xml-!entity-rtd) ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (ctx-start-col ctx)))
+ (write-xml-name (xml-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-entity-value (xml-!entity-value decl) col ctx)
+ (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-unparsed-!entity-rtd) ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (ctx-start-col ctx)))
+ (write-xml-name (xml-unparsed-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-xml-external-id (xml-unparsed-!entity-id decl) col ctx)
+ (emit-string " NDATA " ctx)
+ (write-xml-name (xml-unparsed-!entity-notation decl) ctx)
+ (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-parameter-!entity-rtd) ctx)
+ (emit-string "<!ENTITY " ctx)
+ (let ((col (ctx-start-col ctx)))
+ (emit-string "% " ctx)
+ (write-xml-name (xml-parameter-!entity-name decl) ctx)
+ (emit-string " " ctx)
+ (write-entity-value (xml-parameter-!entity-value decl) col ctx)
+ (emit-string ">" ctx)))
+
+(define-method %write-xml ((decl xml-!notation-rtd) ctx)
+ (emit-string "<!NOTATION " ctx)
+ (let ((col (ctx-start-col ctx)))
+ (write-xml-name (xml-!notation-name decl) ctx)
+ (emit-string " " ctx)
+ (write-xml-external-id (xml-!notation-id decl) col ctx)
+ (emit-string ">" ctx)))
+
+(define-method %write-xml ((string <string>) ctx)
(write-escaped-string string
'((#\< . "<")
(#\& . "&"))
- port))
+ ctx))
-(define-method write-xml ((ref xml-entity-ref-rtd) port)
- (write-string "&" port)
- (write-xml-name (xml-entity-ref-name ref) port)
- (write-string ";" port))
+(define-method %write-xml ((ref xml-entity-ref-rtd) ctx)
+ (emit-string "&" ctx)
+ (write-xml-name (xml-entity-ref-name ref) ctx)
+ (emit-string ";" ctx))
-(define-method write-xml ((ref xml-parameter-entity-ref-rtd) port)
- (write-string "%" port)
- (write-xml-name (xml-parameter-entity-ref-name ref) port)
- (write-string ";" port))
+(define-method %write-xml ((ref xml-parameter-entity-ref-rtd) ctx)
+ (emit-string "%" ctx)
+ (write-xml-name (xml-parameter-entity-ref-name ref) ctx)
+ (emit-string ";" ctx))
\f
-(define (write-xml-attributes attributes suffix-cols port)
- (let ((start-col (output-port/column port)))
- (if (and start-col
+(define (write-xml-attributes attributes suffix-cols ctx)
+ (let ((col (ctx-start-col ctx)))
+ (if (and col
(pair? attributes)
(pair? (cdr attributes))
- (>= (+ start-col
+ (>= (+ col
(xml-attributes-columns attributes)
suffix-cols)
- (output-port/x-size port)))
+ (ctx-x-size ctx)))
(begin
- (write-char #\space port)
- (write-xml-attribute (car attributes) port)
+ (emit-char #\space ctx)
+ (write-xml-attribute (car attributes) ctx)
(for-each (lambda (attribute)
- (write-indent (+ start-col 1) port)
- (write-xml-attribute attribute port))
+ (write-indent (+ col 1) ctx)
+ (write-xml-attribute attribute ctx))
(cdr attributes)))
(for-each (lambda (attribute)
- (write-char #\space port)
- (write-xml-attribute attribute port))
+ (emit-char #\space ctx)
+ (write-xml-attribute attribute ctx))
attributes))))
(define (xml-attributes-columns attributes)
(+ n-cols 1 (xml-attribute-columns (car attributes))))
n-cols)))
-(define (write-xml-attribute attribute port)
- (write-xml-name (car attribute) port)
- (write-char #\= port)
- (write-xml-attribute-value (cdr attribute) port))
+(define (write-xml-attribute attribute ctx)
+ (write-xml-name (car attribute) ctx)
+ (emit-char #\= ctx)
+ (write-xml-attribute-value (cdr attribute) ctx))
-(define (write-xml-attribute-value value port)
- (write-char #\" port)
+(define (write-xml-attribute-value value ctx)
+ (emit-char #\" ctx)
(for-each (lambda (item)
(if (string? item)
- (write-xml-string item port)
- (write-xml item port)))
+ (write-xml-string item ctx)
+ (%write-xml item ctx)))
value)
- (write-char #\" port))
+ (emit-char #\" ctx))
(define (xml-attribute-columns attribute)
(+ (xml-name-columns (car attribute))
2))))
n))))
-(define (write-xml-string string port)
+(define (write-xml-string string ctx)
(write-escaped-string string
'((#\" . """)
(#\< . "<")
(#\& . "&"))
- port))
+ ctx))
(define (xml-string-columns string)
- (let ((n (utf8-string-length string)))
- (for-each-utf8-char string
+ (let ((n 0))
+ (for-each-wide-char string
(lambda (char)
(set! n
(fix:+ n
(case char
- ((#\") 5)
- ((#\<) 3)
- ((#\&) 4)
- (else 0))))
+ ((#\") 6)
+ ((#\<) 4)
+ ((#\&) 5)
+ (else 1))))
unspecific))
n))
\f
-(define (write-xml-name name port)
- (write-string (symbol-name name) port))
+(define (write-xml-name name ctx)
+ (emit-string (symbol-name name) ctx))
(define (xml-name-columns name)
(utf8-string-length (symbol-name name)))
-(define (write-entity-value value indent port)
+(define (write-entity-value value col ctx)
(if (xml-external-id? value)
- (write-xml-external-id value indent port)
+ (write-xml-external-id value col ctx)
(begin
- (write-char #\" port)
+ (emit-char #\" ctx)
(for-each
(lambda (item)
(if (string? item)
'((#\" . """)
(#\& . "&")
(#\% . "%"))
- port)
- (write-xml item port)))
+ ctx)
+ (%write-xml item ctx)))
value)
- (write-char #\" port))))
+ (emit-char #\" ctx))))
-(define (write-xml-external-id id indent port)
+(define (write-xml-external-id id col ctx)
(let ((quoted-string
(lambda (string)
- (write-char #\" port)
- (write-xml-string string port)
- (write-char #\" port))))
+ (emit-char #\" ctx)
+ (write-xml-string string ctx)
+ (emit-char #\" ctx))))
(if (xml-external-id-id id)
(begin
- (write-indent indent port)
- (write-string "PUBLIC " port)
+ (write-indent col ctx)
+ (emit-string "PUBLIC " ctx)
(quoted-string (xml-external-id-id id))
(if (xml-external-id-uri id)
(begin
- (write-indent indent port)
+ (write-indent col ctx)
(quoted-string (xml-external-id-uri id)))))
(begin
- (write-indent indent port)
- (write-string "SYSTEM" port)
- (write-string " " port)
+ (write-indent col ctx)
+ (emit-string "SYSTEM" ctx)
+ (emit-string " " ctx)
(quoted-string (xml-external-id-uri id))))))
-
-(define (write-indent n port)
- (if n
+\f
+(define (write-indent col ctx)
+ (if col
(begin
- (newline port)
- (let ((q.r (integer-divide n 8)))
+ (emit-newline ctx)
+ (let ((q.r (integer-divide col 8)))
(do ((i 0 (fix:+ i 1)))
((fix:= i (car q.r)))
- (write-char #\tab port))
+ (emit-char #\tab ctx))
(do ((i 0 (fix:+ i 1)))
((fix:= i (cdr q.r)))
- (write-char #\space port))))
- (write-char #\space port)))
+ (emit-char #\space ctx))))
+ (emit-char #\space ctx)))
-(define (write-escaped-string string escapes port)
- (for-each-utf8-char string
+(define (write-escaped-string string escapes ctx)
+ (for-each-wide-char string
(lambda (char)
(let ((e (assq char escapes)))
(if e
- (write-string (cdr e) port)
- (write-utf8-char char port))))))
-
-(define (for-each-utf8-char string procedure)
- (let ((port (open-input-string string)))
- (let loop ()
- (let ((char (read-utf8-char port)))
- (if (not (eof-object? char))
- (begin
- (procedure char)
- (loop)))))))
\ No newline at end of file
+ (emit-string (cdr e) ctx)
+ (emit-char char ctx))))))
+
+(define (for-each-wide-char string procedure)
+ (if (wide-string? string)
+ (let ((port (open-wide-input-string string)))
+ (let loop ()
+ (let ((char (read-char port)))
+ (if (not (eof-object? char))
+ (begin
+ (procedure char)
+ (loop))))))
+ (let ((port (open-input-string string)))
+ (let loop ()
+ (let ((char (read-utf8-char port)))
+ (if (not (eof-object? char))
+ (begin
+ (procedure char)
+ (loop))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff