Index: generic/tcldom.c ================================================================== --- generic/tcldom.c +++ generic/tcldom.c @@ -357,20 +357,30 @@ typedef struct XsltMsgCBInfo { Tcl_Interp * interp; Tcl_Obj * msgcmd; } XsltMsgCBInfo; + +static void UpdateStringOfTdomNode(Tcl_Obj *objPtr); +static int SetTdomNodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); + +const Tcl_ObjType tdomNodeType = { + "tdom-node", + NULL, + NULL, + UpdateStringOfTdomNode, + SetTdomNodeFromAny +}; + /*---------------------------------------------------------------------------- | Prototypes for procedures defined later in this file: | \---------------------------------------------------------------------------*/ static Tcl_VarTraceProc tcldom_docTrace; -static Tcl_VarTraceProc tcldom_nodeTrace; static Tcl_CmdDeleteProc tcldom_docCmdDeleteProc; -static Tcl_CmdDeleteProc tcldom_nodeCmdDeleteProc; #ifdef TCL_THREADS static int tcldom_EvalLocked(Tcl_Interp* interp, Tcl_Obj** objv, domDocument* doc, int flag); @@ -483,39 +493,10 @@ tcldom_deleteDoc(dinfo->interp, doc); FREE((void*)dinfo); } - -/*---------------------------------------------------------------------------- -| tcldom_nodeCmdDeleteProc -| -\---------------------------------------------------------------------------*/ -static -void tcldom_nodeCmdDeleteProc ( - ClientData clientData -) -{ - domDeleteInfo *dinfo = (domDeleteInfo *)clientData; - char *var = dinfo->traceVarName; - - DBG(fprintf (stderr, "--> tcldom_nodeCmdDeleteProc node %p\n", - dinfo->node)); - - if (var) { - DBG(fprintf(stderr, "--> tcldom_nodeCmdDeleteProc calls " - "Tcl_UntraceVar for \"%s\"\n", var)); - Tcl_UntraceVar(dinfo->interp, var, - TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - tcldom_nodeTrace, clientData); - FREE(var); - dinfo->traceVarName = NULL; - } - FREE((void*)dinfo); -} - - /*---------------------------------------------------------------------------- | tcldom_docTrace | \---------------------------------------------------------------------------*/ static @@ -546,48 +527,76 @@ } return NULL; } +/*---------------------------------------------------------------------------- +| UpdateStringOfTdomNode +| +\---------------------------------------------------------------------------*/ +static void +UpdateStringOfTdomNode( + Tcl_Obj *objPtr) +{ + char nodeName[80]; + int len; + + NODE_CMD(nodeName, objPtr->internalRep.otherValuePtr); + len = strlen(nodeName); + objPtr->bytes = (ckalloc((unsigned char) len+1)); + memcpy(objPtr->bytes, nodeName, len+1); + objPtr->length = len; +} /*---------------------------------------------------------------------------- -| tcldom_nodeTrace +| SetTdomNodeFromAny | \---------------------------------------------------------------------------*/ -static -char * tcldom_nodeTrace ( - ClientData clientData, - Tcl_Interp *interp, - CONST84 char *name1, - CONST84 char *name2, - int flags -) -{ - domDeleteInfo *dinfo = (domDeleteInfo*)clientData; - domNode *node = dinfo->node; - char objCmdName[80]; - - DBG(fprintf(stderr, "--> tcldom_nodeTrace %x %p\n", flags, node)); - - if (flags & TCL_INTERP_DESTROYED) { - return NULL; - } - if (flags & TCL_TRACE_WRITES) { - return "var is read-only"; - } - if (flags & TCL_TRACE_UNSETS) { - NODE_CMD(objCmdName, node); - DBG(fprintf(stderr, "--> tcldom_nodeTrace delete node %p\n", node)); - Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES | TCL_TRACE_UNSETS, - tcldom_nodeTrace, clientData); - Tcl_DeleteCommand(interp, objCmdName); - node->nodeFlags &= ~VISIBLE_IN_TCL; - } - - return NULL; -} - +static int +SetTdomNodeFromAny( + Tcl_Interp *interp, /* Tcl interpreter or NULL */ + Tcl_Obj *objPtr) /* Pointer to the object to parse */ +{ + Tcl_CmdInfo cmdInfo; + domNode *node = NULL; + char *nodeName; + + if (objPtr->typePtr == &tdomNodeType) { + return TCL_OK; + } + + nodeName = Tcl_GetString(objPtr); + if (strncmp(nodeName, "domNode", 7)) { + if (interp) { + SetResult("parameter not a domNode!"); + return TCL_ERROR; + } + } + if (sscanf(&nodeName[7], "%p", &node) != 1) { + if (!Tcl_GetCommandInfo(interp, nodeName, &cmdInfo)) { + if (interp) { + SetResult("parameter not a domNode!"); + return TCL_ERROR; + } + } + if ( (cmdInfo.isNativeObjectProc == 0) + || (cmdInfo.objProc != (Tcl_ObjCmdProc*)tcldom_NodeObjCmd)) { + if (interp) { + SetResult("parameter not a domNode object command"); + return TCL_ERROR; + } + } + node = (domNode*)cmdInfo.objClientData; + } + if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->internalRep.otherValuePtr = node; + objPtr->typePtr = &tdomNodeType; + + return TCL_OK; +} /*---------------------------------------------------------------------------- | tcldom_createNodeObj | \---------------------------------------------------------------------------*/ @@ -611,71 +620,84 @@ node->nodeFlags |= VISIBLE_IN_TCL; } } /*---------------------------------------------------------------------------- -| tcldom_returnNodeObj +| tcldom_setInterpAndReturnVar | \---------------------------------------------------------------------------*/ static -int tcldom_returnNodeObj ( +int tcldom_setInterpAndReturnVar ( Tcl_Interp *interp, domNode *node, int setVariable, Tcl_Obj *var_name ) { - char objCmdName[80], *objVar; - domDeleteInfo * dinfo; - Tcl_CmdInfo cmdInfo; - + char objCmdName[80], *objVar; + Tcl_Obj *resultObj; + GetTcldomTSD() if (node == NULL) { if (setVariable) { objVar = Tcl_GetString(var_name); - Tcl_UnsetVar(interp, objVar, 0); Tcl_SetVar(interp, objVar, "", 0); } SetResult(""); return TCL_OK; } - tcldom_createNodeObj(interp, node, objCmdName); - if (TSD(dontCreateObjCommands)) { - if (setVariable) { - objVar = Tcl_GetString(var_name); - Tcl_SetVar(interp, objVar, objCmdName, 0); - } - } else { - if (setVariable) { - objVar = Tcl_GetString(var_name); - Tcl_UnsetVar(interp, objVar, 0); + if (TSD(dontCreateObjCommands) == 0) { + tcldom_createNodeObj(interp, node, objCmdName); + if (setVariable) { + objVar = Tcl_GetString(var_name); + Tcl_SetVar (interp, objVar, objCmdName, 0); + } + SetResult(objCmdName); + } else { + resultObj = Tcl_NewObj(); + resultObj->bytes = NULL; + resultObj->length = 0; + resultObj->internalRep.otherValuePtr = node; + resultObj->typePtr = &tdomNodeType; + Tcl_SetObjResult (interp, resultObj); + if (setVariable) { + NODE_CMD(objCmdName, node); + objVar = Tcl_GetString(var_name); Tcl_SetVar (interp, objVar, objCmdName, 0); - Tcl_GetCommandInfo(interp, objCmdName, &cmdInfo); - if (0) { - dinfo = (domDeleteInfo*)MALLOC(sizeof(domDeleteInfo)); - dinfo->interp = interp; - dinfo->node = node; - dinfo->traceVarName = NULL; - Tcl_TraceVar(interp, objVar, - TCL_TRACE_WRITES | TCL_TRACE_UNSETS, - (Tcl_VarTraceProc*)tcldom_nodeTrace, - (ClientData)dinfo); - dinfo->traceVarName = tdomstrdup(objVar); - - /* Patch node object command to remove above trace - on teardown */ - cmdInfo.deleteData = (ClientData)dinfo; - cmdInfo.deleteProc = tcldom_nodeCmdDeleteProc; - Tcl_SetCommandInfo(interp, objCmdName, &cmdInfo); - } - } - } - - SetResult(objCmdName); + } + } return TCL_OK; } + +/*---------------------------------------------------------------------------- +| tcldom_returnNodeObj +| +\---------------------------------------------------------------------------*/ +static +Tcl_Obj *tcldom_returnNodeObj ( + Tcl_Interp *interp, + domNode *node) +{ + char objCmdName[80]; + Tcl_Obj *resultObj; + + GetTcldomTSD() + + resultObj = Tcl_NewObj(); + if (node == NULL) { + return resultObj; + } + if (TSD(dontCreateObjCommands) == 0) { + tcldom_createNodeObj(interp, node, objCmdName); + } + resultObj->bytes = NULL; + resultObj->length = 0; + resultObj->internalRep.otherValuePtr = node; + resultObj->typePtr = &tdomNodeType; + return resultObj; +} /*---------------------------------------------------------------------------- | tcldom_returnDocumentObj | \---------------------------------------------------------------------------*/ @@ -759,11 +781,11 @@ const char *uri ) { int result; domNode *child; - char prefix[MAX_PREFIX_LEN], objCmdName[80]; + char prefix[MAX_PREFIX_LEN]; const char *localName; Tcl_Obj *namePtr, *resultPtr; /* nsIndex == -1 ==> DOM 1 no NS i.e getElementsByTagName nsIndex != -1 are the NS aware cases @@ -794,12 +816,11 @@ } else { domSplitQName(node->nodeName, prefix, &localName); } if (Tcl_StringMatch(localName, namePattern)) { resultPtr = Tcl_GetObjResult(interp); - tcldom_createNodeObj(interp, node, objCmdName); - namePtr = Tcl_NewStringObj(objCmdName, -1); + namePtr = tcldom_returnNodeObj(interp, node); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); return result; } @@ -871,16 +892,14 @@ ) { Tcl_Interp * interp = (Tcl_Interp*)clientData; Tcl_Obj * resultPtr = Tcl_GetObjResult(interp); Tcl_Obj * namePtr; - char objCmdName[80]; int result; - tcldom_createNodeObj(interp, node, objCmdName); - namePtr = Tcl_NewStringObj(objCmdName, -1); + namePtr = tcldom_returnNodeObj(interp, node); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); } return result; @@ -989,10 +1008,57 @@ return TCL_ERROR; } return TCL_OK; } + +/*---------------------------------------------------------------------------- +| tcldom_getNodeFromObj +| +\---------------------------------------------------------------------------*/ +domNode * tcldom_getNodeFromObj ( + Tcl_Interp *interp, + Tcl_Obj *nodeObj +) +{ + Tcl_CmdInfo cmdInfo; + domNode *node = NULL; + char *nodeName; + + GetTcldomTSD() + + if (nodeObj->typePtr == &tdomNodeType) { + return (domNode*)nodeObj->internalRep.otherValuePtr; + } + + if (TSD(dontCreateObjCommands)) { + if (SetTdomNodeFromAny (interp, nodeObj) == TCL_OK) { + return (domNode*)nodeObj->internalRep.otherValuePtr; + } + return NULL; + } + + nodeName = Tcl_GetString(nodeObj); + if (strncmp(nodeName, "domNode", 7)) { + SetResult("parameter not a domNode!"); + return NULL; + } + if (sscanf(&nodeName[7], "%p", &node) != 1) { + if (!Tcl_GetCommandInfo(interp, nodeName, &cmdInfo)) { + SetResult("parameter not a domNode!"); + return NULL; + } + if ( (cmdInfo.isNativeObjectProc == 0) + || (cmdInfo.objProc != (Tcl_ObjCmdProc*)tcldom_NodeObjCmd)) { + SetResult("parameter not a domNode object command!"); + return NULL; + } + node = (domNode*)cmdInfo.objClientData; + } + + return node; +} /*---------------------------------------------------------------------------- | tcldom_getNodeFromName | \---------------------------------------------------------------------------*/ @@ -1159,11 +1225,11 @@ domAppendChild(node, nodeToAppend); nodeToAppend = nodeToAppend->nextSibling; } domFreeDocument(doc, NULL, NULL); - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); #endif } /*---------------------------------------------------------------------------- @@ -1178,11 +1244,10 @@ Tcl_Obj *value ) { int rc, i; Tcl_Obj *namePtr, *objv[2]; - char objCmdName[80]; domAttrNode *attr; domNodeType startType; int mixedNodeSet; switch (rs->type) { @@ -1237,12 +1302,11 @@ objv[0] = Tcl_NewStringObj(attr->nodeName, -1); objv[1] = Tcl_NewStringObj(attr->nodeValue, attr->valueLength); namePtr = Tcl_NewListObj(2, objv); } else { - tcldom_createNodeObj(interp, rs->nodes[i], objCmdName); - namePtr = Tcl_NewStringObj(objCmdName, -1); + namePtr = tcldom_returnNodeObj(interp, rs->nodes[i]); } rc = Tcl_ListObjAppendElement(interp, value, namePtr); if (rc != TCL_OK) { Tcl_DecrRefCount(namePtr); return rc; @@ -1281,11 +1345,11 @@ char **errMsg ) { Tcl_Interp *interp = (Tcl_Interp*) clientData; char tclxpathFuncName[200], objCmdName[80]; - char *errStr, *typeStr, *nodeName; + char *errStr, *typeStr; Tcl_Obj *resultPtr, *objv[MAX_REWRITE_ARGS], *type, *value, *nodeObj, *tmpObj; Tcl_CmdInfo cmdInfo; int objc, rc, i, errStrLen, listLen, intValue, res; double doubleValue; @@ -1323,12 +1387,11 @@ Tcl_NewStringObj(objCmdName, -1)); Tcl_ListObjAppendElement( interp, tmpObj, Tcl_NewStringObj(((domAttrNode*)ctxNode)->nodeName, -1)); } else { - tcldom_createNodeObj(interp, ctxNode, objCmdName); - tmpObj = Tcl_NewStringObj(objCmdName, -1); + tmpObj = tcldom_returnNodeObj(interp, ctxNode); } objv[objc] = tmpObj; Tcl_IncrRefCount(objv[objc++]); objv[objc] = Tcl_NewIntObj(position); @@ -1394,14 +1457,13 @@ res = XPATH_EVAL_ERR; goto funcCallCleanup; } for (i=0; i < listLen; i++) { rc = Tcl_ListObjIndex(interp, value, i, &nodeObj); - nodeName = Tcl_GetString(nodeObj); - node = tcldom_getNodeFromName(interp, nodeName, &errStr); + node = tcldom_getNodeFromObj(interp, nodeObj); if (node == NULL) { - *errMsg = tdomstrdup(errStr); + *errMsg = tdomstrdup(Tcl_GetStringResult(interp)); res = XPATH_EVAL_ERR; goto funcCallCleanup; } rsAddNode(result, node); } @@ -1961,11 +2023,11 @@ if ((rc = tcldom_appendFromTclList(interp, newnode, childObj)) != TCL_OK) { return rc; } } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); } /*---------------------------------------------------------------------------- | tcldom_treeAsTclList @@ -3323,11 +3385,10 @@ int objc, Tcl_Obj *CONST objv[] ) { int len, i, hnew; - char *errMsg; Tcl_HashEntry *h; Tcl_Obj *objPtr; domNode *node; CheckArgs (4,4,0, " renameNode nodeList name"); @@ -3338,15 +3399,12 @@ } h = Tcl_CreateHashEntry(&HASHTAB(doc,tdom_tagNames), Tcl_GetString(objv[3]), &hnew); for (i = 0; i < len; i++) { Tcl_ListObjIndex (interp, objv[2], i, &objPtr); - node = tcldom_getNodeFromName (interp, Tcl_GetString (objPtr), - &errMsg); + node = tcldom_getNodeFromObj (interp, objPtr); if (node == NULL) { - SetResult (errMsg); - if (errMsg) FREE (errMsg); return TCL_ERROR; } node->nodeName = (char *)&(h->key); } return TCL_OK; @@ -3663,13 +3721,12 @@ domNode *node, *child, *refChild, *oldChild, *refNode; domNS *ns; domAttrNode *attrs; domException exception; - char tmp[200], objCmdName[80], prefix[MAX_PREFIX_LEN], - *method, *nodeName, *str, *attr_name, *attr_val, *filter, - *errMsg; + char tmp[200], prefix[MAX_PREFIX_LEN], *method, *nodeName, + *str, *attr_name, *attr_val, *filter; const char *localName, *uri, *nsStr; int result, length, methodIndex, i, line, column; int nsIndex, bool, hnew, legacy; Tcl_Obj *namePtr, *resultPtr; Tcl_Obj *mobjv[MAX_REWRITE_ARGS]; @@ -3731,14 +3788,12 @@ return TCL_ERROR; } if (TSD(domCreateCmdMode) == DOM_CREATECMDMODE_AUTO) { TSD(dontCreateObjCommands) = 1; } - nodeName = Tcl_GetString(objv[1]); - node = tcldom_getNodeFromName(interp, nodeName, &errMsg); + node = tcldom_getNodeFromObj(interp, objv[1]); if (node == NULL) { - SetResult(errMsg); return TCL_ERROR; } objc--; objv++; } @@ -3870,11 +3925,11 @@ case m_find: CheckArgs(4,5,2,"attrName attrVal ?nodeObjVar?"); attr_name = Tcl_GetStringFromObj(objv[2], NULL); attr_val = Tcl_GetStringFromObj(objv[3], &length); - return tcldom_returnNodeObj + return tcldom_setInterpAndReturnVar (interp, tcldom_find(node, attr_name, attr_val, length), (objc == 5), (objc == 5) ? objv[4] : NULL); case m_child: CheckArgs(3,6,2,"instance|all ?type? ?attr value?"); @@ -3899,11 +3954,11 @@ case m_root: CheckArgs(2,3,2,"?nodeObjVar?"); while (node->parentNode) { node = node->parentNode; } - return tcldom_returnNodeObj(interp, node, (objc == 3), + return tcldom_setInterpAndReturnVar(interp, node, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_text: CheckArgs(2,2,2,""); if (node->nodeType != ELEMENT_NODE) { @@ -4042,11 +4097,11 @@ CheckName (interp, attr_name, "attribute", 0); attr_val = Tcl_GetString(objv[i++]); CheckText (interp, attr_val, "attribute"); domSetAttribute(node, attr_name, attr_val); } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); case m_setAttributeNS: if (node->nodeType != ELEMENT_NODE) { SetResult("NOT_AN_ELEMENT : there are no attributes"); return TCL_ERROR; @@ -4072,11 +4127,11 @@ "you have to provide a namespace URI"); } return TCL_ERROR; } } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); case m_hasAttribute: CheckArgs(3,3,2,"attrName"); if (node->nodeType != ELEMENT_NODE) { SetResult("NOT_AN_ELEMENT : there are no attributes"); @@ -4130,11 +4185,11 @@ SetResult("can't remove attribute '"); AppendResult(attr_name); AppendResult("'"); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); case m_removeAttributeNS: CheckArgs(4,4,2,"uri attrName"); if (node->nodeType != ELEMENT_NODE) { SetResult("NOT_AN_ELEMENT : there are no attributes"); @@ -4147,43 +4202,43 @@ SetResult("can't remove attribute with localName '"); AppendResult(localName); AppendResult("'"); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); case m_nextSibling: CheckArgs(2,3,2,"?nodeObjVar?"); - return tcldom_returnNodeObj(interp, node->nextSibling, + return tcldom_setInterpAndReturnVar(interp, node->nextSibling, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_previousSibling: CheckArgs(2,3,2,"?nodeObjVar?"); - return tcldom_returnNodeObj(interp, node->previousSibling, + return tcldom_setInterpAndReturnVar(interp, node->previousSibling, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_firstChild: CheckArgs(2,3,2,"?nodeObjVar?"); if (node->nodeType == ELEMENT_NODE) { - return tcldom_returnNodeObj(interp, node->firstChild, + return tcldom_setInterpAndReturnVar(interp, node->firstChild, (objc == 3), (objc == 3) ? objv[2] : NULL); } - return tcldom_returnNodeObj(interp, NULL, (objc == 3), + return tcldom_setInterpAndReturnVar(interp, NULL, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_lastChild: CheckArgs(2,3,2,"?nodeObjVar?"); if (node->nodeType == ELEMENT_NODE) { - return tcldom_returnNodeObj(interp, node->lastChild, + return tcldom_setInterpAndReturnVar(interp, node->lastChild, (objc == 3), (objc == 3) ? objv[2] : NULL); } - return tcldom_returnNodeObj(interp, NULL, (objc == 3), + return tcldom_setInterpAndReturnVar(interp, NULL, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_parentNode: CheckArgs(2,3,2,"?nodeObjVar?"); - return tcldom_returnNodeObj(interp, node->parentNode, (objc == 3), + return tcldom_setInterpAndReturnVar(interp, node->parentNode, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_appendFromList: CheckArgs(3,3,2,"list"); return tcldom_appendFromTclList(interp, node, objv[2]); @@ -4190,123 +4245,118 @@ case m_appendFromScript: CheckArgs(3,3,2,"script"); if (nodecmd_appendFromScript(interp, node, objv[2]) != TCL_OK) { return TCL_ERROR; } - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); case m_insertBeforeFromScript: CheckArgs(4,4,2, "script refChild"); - nodeName = Tcl_GetString (objv[3]); - if (nodeName[0] == '\0') { - refChild = NULL; + if (objv[3]->typePtr == &tdomNodeType) { + refChild = objv[3]->internalRep.otherValuePtr; } else { - refChild = tcldom_getNodeFromName (interp, nodeName, &errMsg); - if (refChild == NULL) { - SetResult ( errMsg ); - return TCL_ERROR; + nodeName = Tcl_GetString (objv[3]); + if (nodeName[0] == '\0') { + refChild = NULL; + } else { + refChild = tcldom_getNodeFromObj (interp, objv[3]); + if (refChild == NULL) { + return TCL_ERROR; + } } } if (nodecmd_insertBeforeFromScript(interp, node, objv[2], refChild) != TCL_OK) { return TCL_ERROR; } - return tcldom_returnNodeObj (interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar (interp, node, 0, NULL); case m_appendXML: CheckArgs(3,3,2,"xmlString"); return tcldom_appendXML(interp, node, objv[2]); case m_appendChild: CheckArgs(3,3,2,"nodeToAppend"); - nodeName = Tcl_GetString(objv[2]); - child = tcldom_getNodeFromName(interp, nodeName, &errMsg); + child = tcldom_getNodeFromObj(interp, objv[2]); if (child == NULL) { - SetResult(errMsg); return TCL_ERROR; } exception = domAppendChild (node, child); if (exception != OK) { SetResult(domException2String(exception)); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, child, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, child, 0, NULL); case m_cloneNode: CheckArgs(2,3,2,"?-deep?"); if (objc == 3) { if (!strcmp(Tcl_GetString(objv[2]), "-deep")) { - return tcldom_returnNodeObj(interp, domCloneNode(node, 1), + return tcldom_setInterpAndReturnVar(interp, domCloneNode(node, 1), 0, NULL); } SetResult("unknown option! Options: ?-deep? "); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, domCloneNode(node, 0), 0, NULL); + return tcldom_setInterpAndReturnVar(interp, domCloneNode(node, 0), 0, NULL); case m_removeChild: CheckArgs(3,3,2,"childToRemove"); - nodeName = Tcl_GetString(objv[2]); - child = tcldom_getNodeFromName(interp, nodeName, &errMsg); + child = tcldom_getNodeFromObj(interp, objv[2]); if (child == NULL) { - SetResult(errMsg); return TCL_ERROR; } exception = domRemoveChild (node, child); if (exception != OK) { SetResult (domException2String (exception)); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, child, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, child, 0, NULL); case m_insertBefore: CheckArgs(4,4,2,"childToInsert refChild"); - nodeName = Tcl_GetString(objv[2]); - child = tcldom_getNodeFromName(interp, nodeName, &errMsg); + child = tcldom_getNodeFromObj(interp, objv[2]); if (child == NULL) { - SetResult(errMsg); return TCL_ERROR; } - nodeName = Tcl_GetString (objv[3]); - if (nodeName[0] == '\0') { - refChild = NULL; + if (objv[3]->typePtr == &tdomNodeType) { + refChild = objv[3]->internalRep.otherValuePtr; } else { - refChild = tcldom_getNodeFromName (interp, nodeName, &errMsg); - if (refChild == NULL) { - SetResult ( errMsg ); - return TCL_ERROR; + nodeName = Tcl_GetString (objv[3]); + if (nodeName[0] == '\0') { + refChild = NULL; + } else { + refChild = tcldom_getNodeFromObj (interp, objv[3]); + if (refChild == NULL) { + return TCL_ERROR; + } } } exception = domInsertBefore(node, child, refChild); if (exception != OK) { SetResult(domException2String(exception)); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, child, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, child, 0, NULL); case m_replaceChild: CheckArgs(4,4,2,"new old"); - nodeName = Tcl_GetString(objv[2]); - child = tcldom_getNodeFromName(interp, nodeName, &errMsg); + child = tcldom_getNodeFromObj(interp, objv[2]); if (child == NULL) { - SetResult(errMsg); return TCL_ERROR; } - - nodeName = Tcl_GetString(objv[3]); - oldChild = tcldom_getNodeFromName(interp, nodeName, &errMsg); + oldChild = tcldom_getNodeFromObj(interp, objv[3]); if (oldChild == NULL) { - SetResult(errMsg); return TCL_ERROR; } exception = domReplaceChild(node, child, oldChild); if (exception != OK) { SetResult(domException2String(exception)); return TCL_ERROR; } - return tcldom_returnNodeObj(interp, oldChild, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, oldChild, 0, NULL); case m_hasChildNodes: CheckArgs(2,2,2,""); if (node->nodeType == ELEMENT_NODE) { SetIntResult(node->firstChild ? 1 : 0); @@ -4319,12 +4369,11 @@ CheckArgs(2,2,2,""); resultPtr = Tcl_GetObjResult(interp); if (node->nodeType == ELEMENT_NODE) { child = node->firstChild; while (child != NULL) { - tcldom_createNodeObj(interp, child, objCmdName); - namePtr = Tcl_NewStringObj(objCmdName, -1); + namePtr = tcldom_returnNodeObj(interp, child); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); return result; @@ -4388,11 +4437,11 @@ if (node->ownerDocument->ids) { str = Tcl_GetString(objv[2]); h = Tcl_FindHashEntry(node->ownerDocument->ids, str); if (h) { domNode *node = Tcl_GetHashValue(h); - return tcldom_returnNodeObj(interp, node, 0, NULL); + return tcldom_setInterpAndReturnVar(interp, node, 0, NULL); } } SetResult(""); return TCL_OK; @@ -4621,14 +4670,12 @@ } break; case m_precedes: CheckArgs(3,3,2, "node"); - nodeName = Tcl_GetString(objv[2]); - refNode = tcldom_getNodeFromName(interp, nodeName, &errMsg); + refNode = tcldom_getNodeFromObj(interp, objv[2]); if (refNode == NULL) { - SetResult(errMsg); return TCL_ERROR; } if (node->ownerDocument != refNode->ownerDocument) { SetResult("Cannot compare the relative order of nodes " "out of different documents."); @@ -4678,12 +4725,12 @@ CheckArgs(3,3,2,"script"); return tcldom_EvalLocked(interp, (Tcl_Obj**)objv, node->ownerDocument, LOCK_READ); ) } - return TCL_OK; -} + return TCL_OK;} + /*---------------------------------------------------------------------------- | tcldom_DocObjCmd | @@ -4826,11 +4873,11 @@ switch ((enum docMethod) methodIndex ) { case m_documentElement: CheckArgs(2,3,2,""); - return tcldom_returnNodeObj(interp, doc->documentElement, + return tcldom_setInterpAndReturnVar(interp, doc->documentElement, (objc == 3), (objc == 3) ? objv[2] : NULL); case m_getElementsByTagName: CheckArgs(3,3,2,"elementName"); return tcldom_getElementsByTagName(interp, Tcl_GetString(objv[2]), @@ -4871,45 +4918,45 @@ case m_createElement: CheckArgs(3,4,2,"elementName ?newObjVar?"); tag = Tcl_GetString(objv[2]); CheckName (interp, tag, "tag", 0); n = domNewElementNode(doc, tag, ELEMENT_NODE); - return tcldom_returnNodeObj(interp, n, (objc == 4), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 4), (objc == 4) ? objv[3] : NULL); case m_createElementNS: CheckArgs(4,5,2,"elementName uri ?newObjVar?"); uri = Tcl_GetString(objv[2]); tag = Tcl_GetString(objv[3]); CheckName (interp, tag, "full qualified tag", 1); n = domNewElementNodeNS(doc, tag, uri, ELEMENT_NODE); - return tcldom_returnNodeObj(interp, n, (objc == 5), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 5), (objc == 5) ? objv[4] : NULL); case m_createTextNode: CheckArgs(3,4,2,"data ?newObjVar?"); data = Tcl_GetStringFromObj(objv[2], &data_length); CheckText (interp, data, "text"); n = (domNode*)domNewTextNode(doc, data, data_length, TEXT_NODE); - return tcldom_returnNodeObj(interp, n, (objc == 4), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 4), (objc == 4) ? objv[3] : NULL); case m_createCDATASection: CheckArgs(3,4,2,"data ?newObjVar?"); data = Tcl_GetStringFromObj(objv[2], &data_length); CheckCDATA (interp, data); n = (domNode*)domNewTextNode(doc, data, data_length, CDATA_SECTION_NODE); - return tcldom_returnNodeObj(interp, n, (objc == 4), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 4), (objc == 4) ? objv[3] : NULL); case m_createComment: CheckArgs(3,4,2,"data ?newObjVar?"); data = Tcl_GetStringFromObj(objv[2], &data_length); CheckComment(interp, data); n = (domNode*)domNewTextNode(doc, data, data_length, COMMENT_NODE); - return tcldom_returnNodeObj(interp, n, (objc == 4), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 4), (objc == 4) ? objv[3] : NULL); case m_createProcessingInstruction: CheckArgs(4,5,2,"target data ?newObjVar?"); target = Tcl_GetStringFromObj(objv[2], &target_length); @@ -4917,11 +4964,11 @@ data = Tcl_GetStringFromObj(objv[3], &data_length); CheckPIValue (interp, data); n = (domNode*)domNewProcessingInstructionNode(doc, target, target_length, data, data_length); - return tcldom_returnNodeObj(interp, n, (objc == 5), + return tcldom_setInterpAndReturnVar(interp, n, (objc == 5), (objc == 5) ? objv[4] : NULL); case m_delete: CheckArgs(2,2,2,""); if (clientData != NULL) { ADDED tests/dom.bench Index: tests/dom.bench ================================================================== --- tests/dom.bench +++ tests/dom.bench @@ -0,0 +1,205 @@ +# -*- tcl -*- +# Tcl Benchmark File +# +# This file contains a number of benchmarks for the dom methods. +# This allow developers to monitor/gauge/track package performance. +# +# (c) 2013 Rolf Ade + + +# ### ### ### ######### ######### ######### ########################### +## Setting up the environment ... + +package require tdom + +# ### ### ### ######### ######### ######### ########################### +## Benchmarks. + +dom createNodeCmd elementNode e1 + +foreach nrOf {1 10 100 1000} { + + bench -desc "getElementsByTagName: $nrOf returned nodes" -pre { + dom createDocument root doc + $doc documentElement root + $root appendFromScript { + for {set x 0} {$x < $nrOf} {incr x} { + e1 + } + } + } -body { + $doc getElementsByTagName e1 + } -post { + $doc delete + } + +} + +foreach nrOf {1 10 100 1000} { + + bench -desc "getElementsByTagName: $nrOf returned node tokens" -pre { + dom createDocument root doc + $doc documentElement root + $root appendFromScript { + for {set x 0} {$x < $nrOf} {incr x} { + e1 + } + } + dom setObjectCommands token + } -body { + $doc getElementsByTagName e1 + } -post { + dom setObjectCommands automatic + $doc delete + } + +} + +proc cloneImitated {source target} { + foreach att [$source attributes] { + $target setAttribute $att [$source @$att] + } + set targetDoc [$target ownerDocument] + foreach child [$source childNodes] { + switch [$child nodeType] { + "ELEMENT_NODE" { + set targetChild [$targetDoc createElement [$child nodeName]] + } + "TEXT_NODE" { + set targetChild [$targetDoc createTextNode [$child nodeValue]] + } + "CDATA_SECTION_NODE" { + set targetChild [$targetDoc createCDATASection \ + [$child nodeValue]] + } + "PROCESSING_INSTRUCTION_NODE" { + set targetChild [$targetDoc createProcessingInstruction \ + [$child nodeName] [$child nodeValue]] + } + "COMMENT_NODE" { + set targetChild [$targetDoc createComment [$child nodeValue]] + } + default { + error "Unexpected node type [$child nodeType]" + } + } + $target appendChild $targetChild + cloneImitated $child $targetChild + } +} + +proc cloneImitated2 {source target} { + foreach att [$source attributes] { + $target setAttribute $att [$source @$att] + } + set targetDoc [$target ownerDocument] + foreach child [$source childNodes] { + switch [$child nodeType] { + "ELEMENT_NODE" { + $targetDoc createElement [$child nodeName] targetChild + } + "TEXT_NODE" { + $targetDoc createTextNode [$child nodeValue] targetChild + } + "CDATA_SECTION_NODE" { + $targetDoc createCDATASection [$child nodeValue] targetChild + } + "PROCESSING_INSTRUCTION_NODE" { + $targetDoc createProcessingInstruction [$child nodeName] \ + targetChild + } + "COMMENT_NODE" { + $targetDoc createComment [$child nodeValue] targetChild + } + default { + error "Unexpected node type [$child nodeType]" + } + } + $target appendChild $targetChild + cloneImitated2 $child $targetChild + } +} + +proc cloneImitatedToken {source target} { + foreach att [domNode $source attributes] { + domNode $target setAttribute $att [domNode $source @$att] + } + set targetDoc [domNode $target ownerDocument] + foreach child [domNode $source childNodes] { + switch [domNode $child nodeType] { + "ELEMENT_NODE" { + set targetChild [$targetDoc createElement \ + [domNode $child nodeName]] + } + "TEXT_NODE" { + set targetChild [$targetDoc createTextNode \ + [domNode $child nodeValue]] + } + "CDATA_SECTION_NODE" { + set targetChild [$targetDoc createCDATASection \ + [domNode $child nodeValue]] + } + "PROCESSING_INSTRUCTION_NODE" { + set targetChild [$targetDoc createProcessingInstruction \ + [domNode $child nodeName] \ + [domNode $child nodeValue]] + } + "COMMENT_NODE" { + set targetChild [$targetDoc createComment \ + [domNode $child nodeValue]] + } + default { + error "Unexpected node type [domNode $child nodeType]" + } + } + domNode $target appendChild $targetChild + cloneImitatedToken $child $targetChild + } +} + +bench -desc "clone dom tree without clone method - cmds" -pre { + set fd [open [file join [file dir [info script]] ../tests/data/mondial-europe.xml]] + fconfigure $fd -encoding utf-8 + set doc [dom parse -channel $fd] + close $fd + set root [$doc documentElement] + set clone [dom createDocument [$root nodeName]] + set cloneRoot [$clone documentElement] +} -iters 5 -body { + cloneImitated $root $cloneRoot +} -post { + $doc delete + $clone delete +} + +bench -desc "clone dom tree without clone method - cmds 2" -pre { + set fd [open [file join [file dir [info script]] ../tests/data/mondial-europe.xml]] + fconfigure $fd -encoding utf-8 + set doc [dom parse -channel $fd] + close $fd + set root [$doc documentElement] + set clone [dom createDocument [$root nodeName]] + set cloneRoot [$clone documentElement] +} -iters 5 -body { + cloneImitated2 $root $cloneRoot +} -post { + $doc delete + $clone delete +} + +bench -desc "clone dom tree without clone method - token" -pre { + set fd [open [file join [file dir [info script]] ../tests/data/mondial-europe.xml]] + fconfigure $fd -encoding utf-8 + set doc [dom parse -channel $fd] + close $fd + set root [$doc documentElement] + set clone [dom createDocument [$root nodeName]] + set cloneRoot [$clone documentElement] + dom setObjectCommands token +} -iters 5 -body { + cloneImitatedToken $root $cloneRoot +} -post { + $doc delete + $clone delete + dom setObjectCommands automatic +} Index: tests/domNode.bench ================================================================== --- tests/domNode.bench +++ tests/domNode.bench @@ -204,10 +204,80 @@ } -post { $doc delete } } + +foreach nrOf {1 10 100 1000} { + + bench -desc "getElementsByTagName: $nrOf returned nodes" -pre { + dom createDocument root doc + $doc documentElement root + $root appendFromScript { + for {set x 0} {$x < $nrOf} {incr x} { + e1 + } + } + } -body { + $doc getElementsByTagName e1 + } -post { + $doc delete + } + +} + +foreach nrOf {1 10 100 1000} { + + bench -desc "getElementsByTagName: $nrOf returned node tokens" -pre { + dom createDocument root doc + $doc documentElement root + $root appendFromScript { + for {set x 0} {$x < $nrOf} {incr x} { + e1 + } + } + dom setObjectCommands token + } -body { + $doc getElementsByTagName e1 + } -post { + dom setObjectCommands automatic + $doc delete + } + +} + + +bench -desc "firstChild node cmd" -pre { + dom parse doc + $doc documentElement root +} -body { + $root firstChild +} -post { + $doc delete +} + +bench -desc "firstChild node token" -pre { + dom parse doc + $doc documentElement root + dom setObjectCommands token +} -body { + $root firstChild +} -post { + $doc delete + dom setObjectCommands automatic +} + +bench -desc "firstChild node token from node token" -pre { + dom parse doc + dom setObjectCommands token + $doc documentElement root +} -body { + domNode $root firstChild +} -post { + $doc delete + dom setObjectCommands automatic +} dom parse doc $doc documentElement root bench -desc "Check for text-only element - xpath - empty" -body {