diff --git a/module/sxml/upstream/SSAX.scm b/module/sxml/upstream/SSAX.scm index 776e3119e..d2b8fd925 100644 --- a/module/sxml/upstream/SSAX.scm +++ b/module/sxml/upstream/SSAX.scm @@ -442,6 +442,11 @@ ; named-entity-name is currently being expanded. A reference to ; this named-entity-name will be an error: violation of the ; WFC nonrecursion. +; +; As an extension to the original SSAX, Guile allows a +; named-entity-name of *DEFAULT* to indicate a fallback procedure, +; called as (FALLBACK PORT NAME). The procedure should return a +; string. ; XML-TOKEN -- a record @@ -1095,10 +1100,20 @@ (close-input-port port)))) (else (parser-error port "[norecursion] broken for " name)))))) - ((assq name ssax:predefined-parsed-entities) - => (lambda (decl-entity) - (str-handler (cdr decl-entity) "" seed))) - (else (parser-error port "[wf-entdeclared] broken for " name)))) + ((assq name ssax:predefined-parsed-entities) + => (lambda (decl-entity) + (str-handler (cdr decl-entity) "" seed))) + ((assq '*DEFAULT* entities) => + (lambda (decl-entity) + (let ((fallback (cdr decl-entity)) + (new-entities (cons (cons name #f) entities))) + (cond + ((procedure? fallback) + (call-with-input-string (fallback port name) + (lambda (port) (content-handler port new-entities seed)))) + (else + (parser-error port "[norecursion] broken for " name)))))) + (else (parser-error port "[wf-entdeclared] broken for " name)))) @@ -1267,6 +1282,14 @@ '((ent . "<&ent1;T;>") (ent1 . "&")) `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) (,(string->symbol "Next") . "12<&T;>34"))) + (test "%tAbc='<&> '%nNext='12&ent;34' />" + `((*DEFAULT* . ,(lambda (port name) + (case name + ((ent) "<&ent1;T;>") + ((ent1) "&") + (else (error "unrecognized" name)))))) + `((,(string->symbol "Abc") . ,(unesc-string "<&>%n")) + (,(string->symbol "Next") . "12<&T;>34"))) (assert (failed? (test "%tAbc='<&> '%nNext='12&ent;34' />" '((ent . "<&ent1;T;>") (ent1 . "&")) '())))