Added *unsupported* command to report an object's representation.

1 files changed, 39 insertions, 1 deletions

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