From 9b243d8861a7ba96ab64928edc9795beb02a4997 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Aug 2009 13:03:46 +0000
Subject: Added *unsupported* command to report an object's representation.

---
 ChangeLog          |  5 +++++
 generic/tclBasic.c |  6 ++++--
 generic/tclInt.h   |  5 ++++-
 generic/tclObj.c   | 40 +++++++++++++++++++++++++++++++++++++++-
 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
-- 
cgit v0.12