diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss index dbf2c0a18e..8a46053c83 100644 --- a/collects/stepper/private/xml-snip-helpers.ss +++ b/collects/stepper/private/xml-snip-helpers.ss @@ -53,7 +53,7 @@ (let* ([source-name (get-source-name editor)] [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)] [xml (read-xml port)] - [xexpr (xml->xexpr (document-element xml))] + [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))] [clean-xexpr (if eliminate-whitespace-in-empty-tags? (eliminate-whitespace-in-empty-tags xexpr) xexpr)] diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss index 9abd1387d7..6deac29f88 100644 --- a/collects/xml/private/sig.ss +++ b/collects/xml/private/sig.ss @@ -41,6 +41,7 @@ xexpr->string xexpr-drop-empty-attributes xexpr? + permissive? correct-xexpr? validate-xexpr (struct exn:invalid-xexpr (code)) diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 6d512b30f4..5ad02cf369 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -146,6 +146,9 @@ (pair? (cdr b)) (string? (cadr b)) (null? (cddr b)))) + + ; permissive? : parameter bool + (define permissive? (make-parameter #f)) ;; xml->xexpr : Content -> Xexpr (define (xml->xexpr x) @@ -169,6 +172,7 @@ [(entity? x) (entity-text x)] [(or (comment? x) (pi? x) (cdata? x)) x] [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)] + [(permissive?) x] [else (error 'xml->xexpr "Expected content, given ~e" x)])))) ;; attribute->srep : Attribute -> Attribute-srep diff --git a/collects/xml/test.ss b/collects/xml/test.ss index 3cc340c2e8..c2f1c57a29 100644 --- a/collects/xml/test.ss +++ b/collects/xml/test.ss @@ -3,13 +3,13 @@ (module test mzscheme (require xml/xml) - - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; utils ;; - + ;; test-bad-read-input : format-str str -> void ;; First argument is the input, second is the error message (define (test-bad-read-input format-str err-string) @@ -20,11 +20,11 @@ (report-err format-str (exn-message x) err-string)))]) (read-xml (open-input-string str)) (report-err str "no error" err-string)))) - + ;; tests-failed : number ;; incremened for each test that fails (define tests-failed 0) - + ;; report-err : string string string -> void ;; reports an error in the test suite ;; increments tests-failed. @@ -32,7 +32,7 @@ (set! tests-failed (+ tests-failed 1)) (printf "FAILED test: ~a~n got: ~a~n expected: ~a~n" test got expected)) - + ;; done : -> void ;; prints out a message saying the tests are done. ;; if any tests failed, prints a message saying how many @@ -40,13 +40,13 @@ (if (= tests-failed 0) (printf "All tests passed~n") (printf "~a tests failed~n" tests-failed))) - - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; reader error tests ;; - + (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") (test-bad-read-input "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") (test-bad-read-input @@ -54,7 +54,7 @@ "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") (test-bad-read-input "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") - + (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") (test-bad-read-input "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") (test-bad-read-input @@ -62,8 +62,21 @@ "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") (test-bad-read-input "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") - - + + ;; permissive? + (with-handlers ([exn? + (lambda (exn) + (regexp-match #rx"Expected content," (exn-message exn)))]) + (report-err "Non-permissive" (xml->xexpr #f) "Exception")) + + (with-handlers ([exn? + (lambda (exn) + (report-err "Permissive" "Exception" "#f"))]) + (parameterize ([permissive? #t]) + (let ([tmp (xml->xexpr #f)]) + (when tmp + (report-err "Permissive" tmp "#f"))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; done diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 0555df9526..dc89b9042d 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -235,9 +235,16 @@ like @scheme[display-xml].} @section{XML and X-expression Conversions} +@defboolparam[permissive? v]{ + If this is set to non-false, then @scheme[xml->xexpr] will allow + non-XML objects, such as other structs, in the content of the converted XML + and leave them in place in the resulting ``@tech{X-expression}''. +} + @defproc[(xml->xexpr [content content?]) xexpr?]{ -Converts document content into an @tech{X-expression}.} +Converts document content into an @tech{X-expression}, using +@scheme[permissive?] to determine if foreign objects are allowed.} @defproc[(xexpr->xml [xexpr xexpr?]) content?]{