Attachment "debugobj.patch" to
ticket [1980917fff]
added by
ferrieux
2009-06-07 17:17:02.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.394
diff -u -r1.394 tclBasic.c
--- generic/tclBasic.c 8 May 2009 08:48:19 -0000 1.394
+++ generic/tclBasic.c 7 Jun 2009 10:15:13 -0000
@@ -795,6 +795,13 @@
Tcl_NRCreateCommand(interp, "tailcall", NULL, TclNRTailcallObjCmd,
NULL, NULL);
+ /*
+ * Create an unsupported command for debugging objects.
+ */
+
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::debugobj",
+ Tcl_DebugObjObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.423
diff -u -r1.423 tclInt.h
--- generic/tclInt.h 8 May 2009 08:48:19 -0000 1.423
+++ generic/tclInt.h 7 Jun 2009 10:15:19 -0000
@@ -2959,6 +2959,10 @@
MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_DebugObjObjCmd(ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
Index: generic/tclObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclObj.c,v
retrieving revision 1.152
diff -u -r1.152 tclObj.c
--- generic/tclObj.c 8 May 2009 02:21:09 -0000 1.152
+++ generic/tclObj.c 7 Jun 2009 10:15:23 -0000
@@ -3831,6 +3831,41 @@
return TCL_OK;
}
+static void DebugObj(Tcl_Obj *ob)
+{
+ printf("Obj:0x%X(%d) ",
+ (int)ob,
+ ob->refCount);
+ if (!ob->typePtr)
+ printf("(null) ");
+ else
+ printf("(%s):0x%X-0x%X ",
+ ob->typePtr->name,
+ (int)ob->internalRep.twoPtrValue.ptr1,
+ (int)ob->internalRep.twoPtrValue.ptr2);
+ printf("<<<%s>>>\n",(ob->bytes?ob->bytes:"?"));
+ fflush(stdout);
+}
+
+int
+Tcl_DebugObjObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ Tcl_Obj *ob;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "object");
+ return TCL_ERROR;
+ }
+ ob=objv[1];
+ DebugObj(ob);
+ Tcl_SetObjResult(interp, ob);
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c
