diff --git a/pkgs/racket-doc/xml/xml.scrbl b/pkgs/racket-doc/xml/xml.scrbl index db17192331..58be25b58e 100644 --- a/pkgs/racket-doc/xml/xml.scrbl +++ b/pkgs/racket-doc/xml/xml.scrbl @@ -416,6 +416,25 @@ or otherwise escaping. Results from the leaves are combined with @section{Parameters} +@defparam[current-unescaped-tags tags (listof symbol?) #:value null]{ + A parameter that determines which tags' string contents should not + be escaped. For backwards compatibility, this defaults to the empty + list. +} + +@defthing[html-unescaped-tags (listof symbol?) #:value '(script style)]{ + The list of tags whose contents are normally not escaped in HTML. + See @racket[current-unescaped-tags]. + + @examples[ + #:eval xml-eval + (parameterize ([current-unescaped-tags html-unescaped-tags]) + (write-xexpr '(html + (p "1 < 2") + (script "1 < 2")))) + ] +} + @defparam[empty-tag-shorthand shorthand (or/c (one-of/c 'always 'never) (listof symbol?))]{ A parameter that determines whether output functions should use the diff --git a/pkgs/racket-test/tests/xml/test.rkt b/pkgs/racket-test/tests/xml/test.rkt index fc18b228f9..90189cf3ad 100644 --- a/pkgs/racket-test/tests/xml/test.rkt +++ b/pkgs/racket-test/tests/xml/test.rkt @@ -826,6 +826,23 @@ XML "(") (test-xexpr->string '(root () "\f") "\f") + + (test-equal? + "escapes" + (xexpr->string + '(html + (p "1 < 2") + (script () "1 < 2"))) + "

1 < 2

") + + (test-equal? + "unescaped tags" + (parameterize ([current-unescaped-tags '(script)]) + (xexpr->string + '(html + (p "1 < 2") + (script "1 < 2")))) + "

1 < 2

") ; XXX more xexpr->string tests ) diff --git a/racket/collects/xml/private/writer.rkt b/racket/collects/xml/private/writer.rkt index a8644b0ff2..c36b2b99a0 100644 --- a/racket/collects/xml/private/writer.rkt +++ b/racket/collects/xml/private/writer.rkt @@ -12,7 +12,9 @@ [write-xml/content ((content/c) (output-port?) . ->* . void?)] [display-xml/content ((content/c) (output-port? #:indentation indentation?) . ->* . void?)] [empty-tag-shorthand (parameter/c (or/c (symbols 'always 'never) (listof symbol?)))] - [html-empty-tags (listof symbol?)]) + [html-empty-tags (listof symbol?)] + [html-unescaped-tags (listof symbol?)] + [current-unescaped-tags (parameter/c (listof symbol?))]) (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) @@ -26,6 +28,12 @@ x (error 'empty-tag-shorthand "expected 'always, 'never, or a list of symbols: received ~e" x))))) +(define html-unescaped-tags + '(script style)) + +(define current-unescaped-tags + (make-parameter null)) + ;; indent : Nat Output-port -> Void (define (indent n out) (newline out) diff --git a/racket/collects/xml/private/xexpr.rkt b/racket/collects/xml/private/xexpr.rkt index 76bce07c53..f9127e79a9 100644 --- a/racket/collects/xml/private/xexpr.rkt +++ b/racket/collects/xml/private/xexpr.rkt @@ -110,7 +110,8 @@ (define (write-xexpr x [out (current-output-port)] #:insert-newlines? [insert-newlines? #f]) (define short (empty-tag-shorthand)) - (let loop ([x x]) + (define unescaped (current-unescaped-tags)) + (let loop ([x x] [escape? #t]) (cond ; Element [(cons? x) @@ -145,14 +146,16 @@ (write-bytes #">" out) ; Write body (for ([xe (in-list content)]) - (loop xe)) + (loop xe (not (memq name unescaped)))) ; Write closing tag (write-bytes #"immutable-string name) out) (write-bytes #">" out)])] ; PCData [(string? x) - (write-string/escape x escape-table out)] + (if escape? + (write-string/escape x escape-table out) + (write-string x out))] ; Entities [(symbol? x) (write-bytes #"&" out)