Index: doc/expat.xml ================================================================== --- doc/expat.xml +++ doc/expat.xml @@ -585,10 +585,20 @@

If the -handlerset option is used, the configuration for the named handler set is returned.

+ + parser currentmarkup + +

Returns the current markup as found in the XML, if + called from within one of its markup event handler script + (-elementstartcommand, -elementendcommand, -commentcommand + and -processinginstructioncommand). Otherwise it return the + empty string.

+
+ parser free

Deletes the parser and the parser command. A parser cannot be freed from within one of its handler callbacks (neither directly nor Index: generic/tclexpat.c ================================================================== --- generic/tclexpat.c +++ generic/tclexpat.c @@ -551,58 +551,47 @@ /* * Set handlers for the parser to routines in this module. */ XML_SetElementHandler(expat->parser, - (XML_StartElementHandler) TclGenExpatElementStartHandler, - (XML_EndElementHandler) TclGenExpatElementEndHandler); + TclGenExpatElementStartHandler, + TclGenExpatElementEndHandler); XML_SetNamespaceDeclHandler(expat->parser, - (XML_StartNamespaceDeclHandler) TclGenExpatStartNamespaceDeclHandler, - (XML_EndNamespaceDeclHandler) TclGenExpatEndNamespaceDeclHandler); + TclGenExpatStartNamespaceDeclHandler, + TclGenExpatEndNamespaceDeclHandler); XML_SetCharacterDataHandler(expat->parser, - (XML_CharacterDataHandler) TclGenExpatCharacterDataHandler); + TclGenExpatCharacterDataHandler); XML_SetProcessingInstructionHandler(expat->parser, - (XML_ProcessingInstructionHandler) TclGenExpatProcessingInstructionHandler); - XML_SetDefaultHandlerExpand(expat->parser, - (XML_DefaultHandler) TclGenExpatDefaultHandler); - + TclGenExpatProcessingInstructionHandler); + XML_SetDefaultHandlerExpand(expat->parser, TclGenExpatDefaultHandler); XML_SetNotationDeclHandler(expat->parser, - (XML_NotationDeclHandler) TclGenExpatNotationDeclHandler); + TclGenExpatNotationDeclHandler); XML_SetExternalEntityRefHandler(expat->parser, - (XML_ExternalEntityRefHandler) TclGenExpatExternalEntityRefHandler); + TclGenExpatExternalEntityRefHandler); XML_SetUnknownEncodingHandler(expat->parser, - (XML_UnknownEncodingHandler) TclGenExpatUnknownEncodingHandler, + TclGenExpatUnknownEncodingHandler, (void *) expat); - - XML_SetCommentHandler(expat->parser, TclGenExpatCommentHandler); - - XML_SetNotStandaloneHandler(expat->parser, TclGenExpatNotStandaloneHandler); - - XML_SetCdataSectionHandler(expat->parser, TclGenExpatStartCdataSectionHandler, + XML_SetNotStandaloneHandler(expat->parser, + TclGenExpatNotStandaloneHandler); + XML_SetCdataSectionHandler(expat->parser, + TclGenExpatStartCdataSectionHandler, TclGenExpatEndCdataSectionHandler); - XML_SetElementDeclHandler(expat->parser, TclGenExpatElementDeclHandler); - XML_SetAttlistDeclHandler(expat->parser, TclGenExpatAttlistDeclHandler); - XML_SetDoctypeDeclHandler(expat->parser, TclGenExpatStartDoctypeDeclHandler, TclGenExpatEndDoctypeDeclHandler); - XML_SetXmlDeclHandler (expat->parser, TclGenExpatXmlDeclHandler); - XML_SetEntityDeclHandler (expat->parser, TclGenExpatEntityDeclHandler); if (expat->noexpand) { - XML_SetDefaultHandlerExpand(expat->parser, NULL); XML_SetDefaultHandler(expat->parser, - (XML_DefaultHandler) TclGenExpatDefaultHandler); + TclGenExpatDefaultHandler); } else { - XML_SetDefaultHandler(expat->parser, NULL); XML_SetDefaultHandlerExpand(expat->parser, - (XML_DefaultHandler) TclGenExpatDefaultHandler); + TclGenExpatDefaultHandler); } XML_SetUserData(expat->parser, (void *) expat); return TCL_OK; @@ -646,10 +635,54 @@ } /* *---------------------------------------------------------------------------- * + * CurrentmarkupCommand -- + * + * Set as defaultHandler prior to XML_Currentmarkup() call. + * + * Results: + * None. + * + * Side effects: + * Stores the markup context in expapt->currentmarkup. + * + *---------------------------------------------------------------------------- + */ +static void +CurrentmarkupCommand(userData, s, len) + void *userData; + CONST char *s; + int len; +{ + TclGenExpatInfo *expat = (TclGenExpatInfo *) userData; + + if (expat->status != TCL_OK) { + return; + } + + if (expat->cdata) { + /* TclGenExpatCharacterDataHandler() was called and + * initialized expat->cdata, but expat->cdata isn't reset by + * TclExpatDispatchPCDATA(), so we're called from + * -characterdatacommand and return the empty string by + * definition. */ + expat->currentmarkup = NULL; + expat->currentmarkuplen = 0; + return; + } + expat->currentmarkup = s; + expat->currentmarkuplen = len; + return; +} + + + +/* + *---------------------------------------------------------------------------- + * * TclExpatInstanceCmd -- * * Implements instance command for expat class objects. * * Results: @@ -671,15 +704,15 @@ TclGenExpatInfo *expat = (TclGenExpatInfo *) clientData; char *data; int len = 0, optionIndex, result = TCL_OK; static CONST84 char *options[] = { - "configure", "cget", "free", "get", + "configure", "cget", "currentmarkup", "free", "get", "parse", "parsechannel", "parsefile", "reset", NULL }; enum options { - EXPAT_CONFIGURE, EXPAT_CGET, EXPAT_FREE, EXPAT_GET, + EXPAT_CONFIGURE, EXPAT_CGET, EXPAT_CURRENTMARKUP, EXPAT_FREE, EXPAT_GET, EXPAT_PARSE, EXPAT_PARSECHANNEL, EXPAT_PARSEFILE, EXPAT_RESET }; if (objc < 2) { @@ -708,10 +741,40 @@ case EXPAT_CGET: CheckArgs (3,5,2, "?-handlerset handlersetname? switch"); result = TclExpatCget(interp, expat, objc - 2, objv + 2); break; + + case EXPAT_CURRENTMARKUP: + + CheckArgs (2,2,1, ""); + if (expat->parsingState < 2) { + Tcl_ResetResult(expat->interp); + break; + } + + XML_SetDefaultHandlerExpand(expat->parser, + CurrentmarkupCommand); + XML_DefaultCurrent(expat->parser); + if (expat->currentmarkuplen) { + Tcl_SetObjResult(expat->interp, + Tcl_NewStringObj(expat->currentmarkup, + expat->currentmarkuplen)); + } else { + Tcl_ResetResult(expat->interp); + } + expat->currentmarkup = NULL; + expat->currentmarkuplen = 0; + if (expat->noexpand) { + XML_SetDefaultHandler(expat->parser, + TclGenExpatDefaultHandler); + } else { + XML_SetDefaultHandlerExpand(expat->parser, + TclGenExpatDefaultHandler); + } + result = TCL_OK; + break; case EXPAT_FREE: CheckArgs (2,2,1,""); @@ -1177,11 +1240,10 @@ if (rc && cmdInfo.isNativeObjectProc) { activeTclHandlerSet->elementstartObjProc = cmdInfo.objProc; activeTclHandlerSet->elementstartclientData = cmdInfo.objClientData; } else { - /* hmoreau 22 May 2003 */ activeTclHandlerSet->elementstartObjProc = NULL; } break; case EXPAT_ELEMENTENDCMD: /* -elementendcommand */ @@ -1196,11 +1258,10 @@ rc = Tcl_GetCommandInfo(interp, Tcl_GetString(objPtr[1]), &cmdInfo); if (rc && cmdInfo.isNativeObjectProc) { activeTclHandlerSet->elementendObjProc = cmdInfo.objProc; activeTclHandlerSet->elementendclientData = cmdInfo.objClientData; } else { - /* hmoreau 22 May 2003 */ activeTclHandlerSet->elementendObjProc = NULL; } break; case EXPAT_STARTNAMESPACEDECLCMD: /* -startnamespacedeclcommand */ @@ -1239,11 +1300,10 @@ rc = Tcl_GetCommandInfo (interp, Tcl_GetString(objPtr[1]), &cmdInfo); if (rc && cmdInfo.isNativeObjectProc) { activeTclHandlerSet->datacommandObjProc = cmdInfo.objProc; activeTclHandlerSet->datacommandclientData = cmdInfo.objClientData; } else { - /* hmoreau 22 May 2003 */ activeTclHandlerSet->datacommandObjProc = NULL; } break; case EXPAT_PICMD: /* -processinginstructioncommand */ @@ -1506,18 +1566,15 @@ case EXPAT_NOEXPAND: if (Tcl_GetBooleanFromObj (interp, objv[1], &bool) != TCL_OK) { return TCL_ERROR; } if (bool) { - XML_SetDefaultHandlerExpand(expat->parser, NULL); - XML_SetDefaultHandler(expat->parser, - (XML_DefaultHandler) TclGenExpatDefaultHandler); - } - else { - XML_SetDefaultHandler(expat->parser, NULL); - XML_SetDefaultHandlerExpand(expat->parser, - (XML_DefaultHandler) TclGenExpatDefaultHandler); + XML_SetDefaultHandler( expat->parser, + TclGenExpatDefaultHandler); + } else { + XML_SetDefaultHandlerExpand( expat->parser, + TclGenExpatDefaultHandler); } expat->noexpand = bool; break; } @@ -2735,11 +2792,11 @@ } } activeCHandlerSet = activeCHandlerSet->nextHandlerSet; } Tcl_DecrRefCount (expat->cdata); - expat->cdata = 0; + expat->cdata = NULL; return; } /* Index: generic/tclexpat.h ================================================================== --- generic/tclexpat.h +++ generic/tclexpat.h @@ -132,11 +132,13 @@ 2 == parsing an input chunk */ XML_Char nsSeparator; int paramentityparsing; int noexpand; int useForeignDTD; - + CONST char *currentmarkup; /* Used to transfer data for method */ + int currentmarkuplen; /* currentmarkup */ + TclHandlerSet *firstTclHandlerSet; CHandlerSet *firstCHandlerSet; } TclGenExpatInfo; /*-------------------------------------------------------------------------- Index: tests/parser.test ================================================================== --- tests/parser.test +++ tests/parser.test @@ -11,13 +11,14 @@ # parser-7.*: parser reset # parser-8.*: parser free # parser-9.*: parser parse # parser-10.*: return code 'return' from callback # parser-11.*: parser input from filename +# parser-12.*: parser currentmarkup # # Copyright (c) 1999-2000 Zveno Pty Ltd. -# Copyright (c) 2002-2005 Rolf Ade +# Copyright (c) 2002-2015 Rolf Ade # # $Id$ source [file join [file dir [info script]] loadtdom.tcl] @@ -504,11 +505,11 @@ global parser $parser parse {foo bar} } -test parser-9.1 {try to use the parser form within one of its callbacks} { +test parser-9.1 {try to use the parser from within one of its callbacks} { set parser [expat -elementstartcommand elementstart] set result [catch {$parser parse foo} errMsg] lappend result $errMsg $parser free set result @@ -522,11 +523,11 @@ proc elementstart {args} { calledFromElementstart } -test parser-9.2 {try to use the parser form within one of its callbacks} { +test parser-9.2 {try to use the parser from within one of its callbacks} { set parser [expat -elementstartcommand elementstart] set result [catch {$parser parse foo} errMsg] lappend result $errMsg $parser free set result @@ -580,15 +581,198 @@ $parser parsefile $file set ::count } {42} +proc elementstart-12.1 {parser args} { + global result + append result [$parser currentmarkup] +} + +proc elementend-12.1 {parser args} { + global result + append result [$parser currentmarkup] +} + +test parser-12.1 {currentmarkup method} { + catch {unset result} + set result "" + set p [expat parser-12.1 -noexpand] + $p configure \ + -elementstartcommand [list elementstart-12.1 $p] \ + -elementendcommand [list elementend-12.1 $p] + $p parse {textmore text} + $p free + set result +} {} + +proc characterdata-12.2 {parser data} { + global result + append result [$parser currentmarkup] +} +test parser-12.2 {currentmarkup method} { + catch {unset result} + set result "" + set p [expat parser-12.2] + $p configure \ + -characterdatacommand [list characterdata-12.2 $p] + $p parse {textmore text} + $p free + set result +} {} + +test parser-12.3 {currentmarkup method} { + set p [expat parser-12.3] + set result [$p currentmarkup] + $p free + set result +} {} + +proc elementstart-12.4 {parser handlerset args} { + global result + append result "$handlerset: [$parser currentmarkup]\n" +} +proc elementend-12.4 {parser handlerset args} { + global result + append result "$handlerset: [$parser currentmarkup]\n" +} +test parser-12.4 {currentmarkup method - multiple handler set} { + catch {unset result} + set result "" + set p [expat parser-12.4] + $p configure \ + -elementstartcommand [list elementstart-12.4 $p default] \ + -elementendcommand [list elementend-12.4 $p default] \ + -handlerset "additional" \ + -elementstartcommand [list elementstart-12.4 $p "additional"] \ + -elementendcommand [list elementend-12.4 $p "additional"] + $p parse {textmore text} + $p free + set result +} {default: +additional: +default: +additional: +default: +additional: +default: +additional: +default: +additional: +default: +additional: +} + +proc elementstart-12.5 {parser args} { + global result + append result "[$parser currentmarkup]" +} +test parser-12.5 {currentmarkup method - empty element shortcut -elementstartcommand} { + catch {unset result} + set result "" + set p [expat parser-12.5] + $p configure \ + -elementstartcommand [list elementstart-12.5 $p] + $p parse {} + $p free + set result +} {} + +proc elementend-12.6 {parser args} { + global result + if {[$parser currentmarkup] eq ""} { + append result "" + } + append result "[$parser currentmarkup]" +} +test parser-12.6 {currentmarkup method - empty element shortcut -elementendcommand} { + catch {unset result} + set result "" + set p [expat parser-12.6] + $p configure \ + -elementendcommand [list elementend-12.6 $p] + $p parse {} + $p free + set result +} {} + foreach parser [info commands xmlparser*] { $parser free } foreach parser [info commands parser-*] { $parser free } + +proc elementdeclcommand-12.7 {parser args} { + global result + append result "elementdeclcommand: [$parser currentmarkup]" +} + +proc entitydeclcommand-12.7 {parser args} { + global result + append result "entitydeclcommand: [$parser currentmarkup]" +} + +test parser-12.7 {currentmarkup method - not for doctype markup handler} { + catch {unset result} + set result "" + set p [expat parser-12.7] + $p configure \ + -elementdeclcommand [list elementdeclcommand-12.7 $p] \ + -entitydeclcommand [list entitydeclcommand-12.7 $p] + $p parse { + +' > +%xx; +]> +This sample shows a &tricky; method.} + $p free + set result +} {elementdeclcommand: entitydeclcommand: entitydeclcommand: } + +proc pi-12.8 {parser args} { + global result + append result "pi: [$parser currentmarkup]" +} +test parser-12.8 {currentmarkup method - processing instruction} { + catch {unset result} + set result "" + set p [expat parser-12.8] + $p configure \ + -processinginstructioncommand [list pi-12.8 $p] + $p parse {} + $p free + set result +} {pi: } + +proc comment-12.9 {parser args} { + global result + append result "comment: [$parser currentmarkup]" +} +test parser-12.9 {currentmarkup method - comment} { + catch {unset result} + set result "" + set p [expat parser-12.9] + $p configure \ + -commentcommand [list comment-12.9 $p] + $p parse {} + $p free + set result +} {comment: } + # cleanup ::tcltest::cleanupTests return Index: tests/pi.test ================================================================== --- tests/pi.test +++ tests/pi.test @@ -16,49 +16,44 @@ } test pi-1.1 {PI} { set ::result {} - catch {rename xml::pi-1.1 {}} set parser [xml::parser pi-1.1 \ -processinginstructioncommand PI] $parser parse { } + $parser free set ::result } {Test {This is a processing instruction}} test pi-1.2 {PI: missing trailing ?} { set ::result {} - catch {rename xml::pi-1.2 {}} set parser [xml::parser pi-1.2 \ -processinginstructioncommand PI] set returncode [catch {$parser parse { }} msg] - + $parser free list $returncode [regexp {error "unclosed token" at.+} $msg] } {1 1} test pi-2.1 {PI with special characters} { set ::result {} - catch {rename xml::pi-2.1 {}} set parser [xml::parser pi-2.1 \ -processinginstructioncommand PI] $parser parse { } + $parser free set ::result } {Test {[if !VMLRender]}} -foreach parser [info commands pi-*] { - $parser free -} - # cleanup ::tcltest::cleanupTests return