summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-08-02 13:03:46 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-08-02 13:03:46 (GMT)
commit9b243d8861a7ba96ab64928edc9795beb02a4997 (patch)
tree9ef3ff93e52517d40aa719be4a9fcb282bf74aa5
parentcaf9f82c8c57615ac532064b2eb0c7649ea7eb40 (diff)
downloadtcl-9b243d8861a7ba96ab64928edc9795beb02a4997.zip
tcl-9b243d8861a7ba96ab64928edc9795beb02a4997.tar.gz
tcl-9b243d8861a7ba96ab64928edc9795beb02a4997.tar.bz2
Added *unsupported* command to report an object's representation.
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclBasic.c6
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclObj.c40
4 files changed, 52 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index 1d3f768..352fd5e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
2009-08-02 Donal K. Fellows <dkf@users.sf.net>
+ * generic/tclObj.c (Tcl_RepresentationCmd): Added an unsupported
+ command for reporting the representation of an object. Result string
+ is deliberately a bit obstructive so that people are not encouraged to
+ make code that depends on it; it's a debugging tool only!
+
* unix/tclUnixFCmd.c (GetOwnerAttribute, SetOwnerAttribute)
(GetGroupAttribute, SetGroupAttribute): [Bug 1942222]: Stop calling
* unix/tclUnixFile.c (TclpGetUserHome): endpwent() and endgrent();
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 54d3b47..7941c7d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.399 2009/07/23 15:23:43 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.400 2009/08/02 13:03:47 dkf Exp $
*/
#include "tclInt.h"
@@ -782,11 +782,13 @@ Tcl_CreateInterp(void)
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
/*
- * Create an unsupported command for debugging bytecode.
+ * Create unsupported commands for debugging bytecode and objects.
*/
Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
Tcl_DisassembleObjCmd, NULL, NULL);
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation",
+ Tcl_RepresentationCmd, NULL, NULL);
/*
* Create the 'tailcall' command
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2f521eb..ac3b3bc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.431 2009/07/22 19:54:49 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.432 2009/08/02 13:03:47 dkf Exp $
*/
#ifndef _TCLINT
@@ -3138,6 +3138,9 @@ MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData,
MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index edc203c..46758fa 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclObj.c,v 1.153 2009/06/18 09:41:29 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.154 2009/08/02 13:03:47 dkf Exp $
*/
#include "tclInt.h"
@@ -3962,6 +3962,44 @@ SetCmdNameFromAny(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_RepresentationCmd --
+ *
+ * Implementation of the "tcl::unsupported::representation" command.
+ *
+ * Results:
+ * Reports the current representation (Tcl_Obj type) of its argument.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_RepresentationCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "value");
+ return TCL_ERROR;
+ }
+
+ if (objv[1]->typePtr == NULL) {
+ Tcl_AppendResult(interp, "value has no internal representation set",
+ NULL);
+ } else {
+ Tcl_AppendResult(interp, "value has internal representation of ",
+ objv[1]->typePtr->name, " currently", NULL);
+ }
+ return TCL_OK;
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4