diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclBasic.c | 6 | ||||
| -rw-r--r-- | generic/tclInt.h | 5 | ||||
| -rw-r--r-- | generic/tclObj.c | 40 |
4 files changed, 52 insertions, 4 deletions
@@ -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 |