summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/CrtObjCmd.329
-rw-r--r--doc/info.n34
-rw-r--r--generic/tclBasic.c96
-rw-r--r--generic/tclCmdIL.c47
-rw-r--r--generic/tclEnsemble.c41
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclInterp.c33
-rw-r--r--generic/tclNamesp.c10
-rw-r--r--generic/tclOO.c29
-rw-r--r--generic/tclZlib.c6
-rw-r--r--tests/info.test141
11 files changed, 408 insertions, 73 deletions
diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3
index faf8b74..149d2f6 100644
--- a/doc/CrtObjCmd.3
+++ b/doc/CrtObjCmd.3
@@ -8,7 +8,7 @@
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
.BS
.SH NAME
-Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C
+Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj Tcl_RegisterCommandTypeName, Tcl_GetCommandTypeName \- implement new commands in C
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
@@ -42,6 +42,14 @@ void
.sp
Tcl_Command
\fBTcl_GetCommandFromObj\fR(\fIinterp, objPtr\fR)
+.sp
+.VS "info cmdtype feature"
+void
+\fBTcl_RegisterCommandTypeName\fR(\fIproc, typeName\fR)
+.sp
+const char *
+\fBTcl_GetCommandTypeName\fR(\fItoken\fR)
+.VE "info cmdtype feature"
.SH ARGUMENTS
.AS Tcl_CmdDeleteProc *deleteProc in/out
.AP Tcl_Interp *interp in
@@ -65,6 +73,9 @@ Pointer to structure containing various information about a
Tcl command.
.AP Tcl_Obj *objPtr in
Value containing the name of a Tcl command.
+.AP "const char" *typeName in
+Indicates the name of the type of command implementation associated
+with a particular \fIproc\fR, or NULL to break the association.
.BE
.SH DESCRIPTION
.PP
@@ -296,6 +307,22 @@ is appended to the value specified by \fIobjPtr\fR.
specified by the name in a \fBTcl_Obj\fR.
The command name is resolved relative to the current namespace.
Returns NULL if the command is not found.
+.PP
+.VS "info cmdtype feature"
+\fBTcl_RegisterCommandTypeName\fR is used to associate a name (the
+\fItypeName\fR argument) with a particular implementation function so that it
+can then be looked up with \fBTcl_GetCommandTypeName\fR, which in turn is
+called with a command token that information is wanted for and which returns
+the name of the type that was registered for the implementation function used
+for that command. (The lookup functionality is surfaced virtually directly in Tcl via
+\fBinfo cmdtype\fR.) If there is no function registered for a particular
+function, the result will be the string literal
+.QW \fBnative\fR .
+The registration of a name can be undone by registering a mapping to NULL
+instead. The result from \fBTcl_GetCommandTypeName\fR will be exactly that
+string which was registered, and not a copy; use of a compile-time constant
+string is \fIstrongly recommended\fR.
+.VE "info cmdtype feature"
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_ResetResult(3), Tcl_SetObjResult(3)
.SH KEYWORDS
diff --git a/doc/info.n b/doc/info.n
index e65a083..819991f 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -45,6 +45,40 @@ described in \fBCLASS INTROSPECTION\fR below.
Returns a count of the total number of commands that have been invoked
in this interpreter.
.TP
+\fBinfo cmdtype \fIcommandName\fR
+.VS "info cmdtype feature"
+Returns a description of the kind of command named by \fIcommandName\fR. The
+supported types are:
+.RS
+.IP \fBalias\fR
+Indicates that \fIcommandName\fR was created by \fBinterp alias\fR.
+.IP \fBcoroutine\fR
+Indicates that \fIcommandName\fR was created by \fBcoroutine\fR.
+.IP \fBensemble\fR
+Indicates that \fIcommandName\fR was created by \fBnamespace ensemble\fR.
+.IP \fBimport\fR
+Indicates that \fIcommandName\fR was created by \fBnamespace import\fR.
+.IP \fBnative\fR
+Indicates that \fIcommandName\fR was created by the \fBTcl_CreateObjProc\fR
+interface directly without further registration of the type of command.
+.IP \fBobject\fR
+Indicates that \fIcommandName\fR is the public command that represents an
+instance of \fBoo::object\fR or one of its subclasses.
+.IP \fBprivateObject\fR
+Indicates that \fIcommandName\fR is the private command (\fBmy\fR by default)
+that represents an instance of \fBoo::object\fR or one of its subclasses.
+.IP \fBproc\fR
+Indicates that \fIcommandName\fR was created by \fBproc\fR.
+.IP \fBslave\fR
+Indicates that \fIcommandName\fR was created by \fBinterp create\fR.
+.IP \fBzlibStream\fR
+Indicates that \fIcommandName\fR was created by \fBzlib stream\fR.
+.PP
+There may be other registered types as well; this is a set that is extensible
+at the implementation level with \fBTcl_RegisterCommandTypeName\fR.
+.RE
+.VE "info cmdtype feature"
+.TP
\fBinfo commands \fR?\fIpattern\fR?
.
If \fIpattern\fR is not specified,
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 82affb0..97cdc51 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -74,7 +74,18 @@ typedef struct {
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
-TCL_DECLARE_MUTEX(cancelLock)
+TCL_DECLARE_MUTEX(cancelLock);
+
+/*
+ * Table used to map command implementation functions to a human-readable type
+ * name, for [info type]. The keys in the table are function addresses, and
+ * the values in the table are static char* containing strings in Tcl's
+ * internal encoding (almost UTF-8).
+ */
+
+static Tcl_HashTable commandTypeTable;
+static int commandTypeInit = 0;
+TCL_DECLARE_MUTEX(commandTypeLock);
/*
* Declarations for managing contexts for non-recursive coroutines. Contexts
@@ -430,6 +441,13 @@ TclFinalizeEvaluation(void)
cancelTableInitialized = 0;
}
Tcl_MutexUnlock(&cancelLock);
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_DeleteHashTable(&commandTypeTable);
+ commandTypeInit = 0;
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
}
/*
@@ -507,6 +525,17 @@ Tcl_CreateInterp(void)
Tcl_MutexUnlock(&cancelLock);
}
+ if (commandTypeInit == 0) {
+ TclRegisterCommandTypeName(TclObjInterpProc, "proc");
+ TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble");
+ TclRegisterCommandTypeName(TclAliasObjCmd, "alias");
+ TclRegisterCommandTypeName(TclSlaveObjCmd, "slave");
+ TclRegisterCommandTypeName(TclInvokeImportedCmd, "import");
+ TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object");
+ TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject");
+ TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine");
+ }
+
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
@@ -995,6 +1024,71 @@ DeleteOpCmdClientData(
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * TclRegisterCommandTypeName, TclGetCommandTypeName --
+ *
+ * Command type registration and lookup mechanism. Everything is keyed by
+ * the Tcl_ObjCmdProc for the command, and that is used as the *key* into
+ * the hash table that maps to constant strings that are names. (It is
+ * recommended that those names be ASCII.)
+ *
+ * ---------------------------------------------------------------------
+ */
+
+void
+TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr)
+{
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit == 0) {
+ Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS);
+ commandTypeInit = 1;
+ }
+ if (nameStr != NULL) {
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&commandTypeTable,
+ (void *) implementationProc, &isNew);
+ Tcl_SetHashValue(hPtr, (void *) nameStr);
+ } else {
+ hPtr = Tcl_FindHashEntry(&commandTypeTable,
+ (void *) implementationProc);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+}
+
+const char *
+TclGetCommandTypeName(
+ Tcl_Command command)
+{
+ Command *cmdPtr = (Command *) command;
+ void *procPtr = cmdPtr->objProc;
+ const char *name = "native";
+
+ if (procPtr == NULL) {
+ procPtr = cmdPtr->nreProc;
+ }
+ Tcl_MutexLock(&commandTypeLock);
+ if (commandTypeInit) {
+ Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr);
+
+ if (hPtr && Tcl_GetHashValue(hPtr)) {
+ name = (const char *) Tcl_GetHashValue(hPtr);
+ }
+ }
+ Tcl_MutexUnlock(&commandTypeLock);
+
+ return name;
+}
+
+/*
*----------------------------------------------------------------------
*
* TclHideUnsafeCommands --
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 0e33392..b99b9e2 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -146,6 +146,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
+static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[]);
static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr,
@@ -164,6 +166,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
{"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
{"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
@@ -2141,6 +2144,50 @@ InfoTclVersionCmd(
/*
*----------------------------------------------------------------------
*
+ * InfoCmdTypeCmd --
+ *
+ * Called to implement the "info cmdtype" command that returns the type
+ * of a given command. Handles the following syntax:
+ *
+ * info cmdtype cmdName
+ *
+ * Results:
+ * Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ * Returns a type name. If there is an error, the result is an error
+ * message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InfoCmdTypeCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Command command;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "commandName");
+ return TCL_ERROR;
+ }
+ command = Tcl_FindCommand(interp, Tcl_GetString(objv[1]), NULL,
+ TCL_LEAVE_ERR_MSG);
+ if (command == NULL) {
+ return TCL_ERROR;
+ }
+
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TclGetCommandTypeName(command), -1));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_JoinObjCmd --
*
* This procedure is invoked to process the "join" Tcl command. See the
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index ad11785..b3a802a 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -21,8 +21,6 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
EnsembleConfig *ensemblePtr, int objc,
Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
-static int NsEnsembleImplementationCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NsEnsembleImplementationCmdNR(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
@@ -674,7 +672,7 @@ Tcl_CreateEnsemble(
ensemblePtr->parameterList = NULL;
ensemblePtr->unknownHandler = NULL;
ensemblePtr->token = Tcl_NRCreateCommand(interp, name,
- NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
+ TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR,
ensemblePtr, DeleteEnsembleConfig);
ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
@@ -725,7 +723,7 @@ Tcl_SetEnsembleSubcommandList(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -801,7 +799,7 @@ Tcl_SetEnsembleParameterList(
Tcl_Obj *oldList;
int length;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -877,7 +875,7 @@ Tcl_SetEnsembleMappingDict(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -976,7 +974,7 @@ Tcl_SetEnsembleUnknownHandler(
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1042,7 +1040,7 @@ Tcl_SetEnsembleFlags(
EnsembleConfig *ensemblePtr;
int wasCompiled;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
@@ -1118,7 +1116,7 @@ Tcl_GetEnsembleSubcommandList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1160,7 +1158,7 @@ Tcl_GetEnsembleParameterList(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1202,7 +1200,7 @@ Tcl_GetEnsembleMappingDict(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1243,7 +1241,7 @@ Tcl_GetEnsembleUnknownHandler(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1284,7 +1282,7 @@ Tcl_GetEnsembleFlags(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1325,7 +1323,7 @@ Tcl_GetEnsembleNamespace(
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
@@ -1375,7 +1373,7 @@ Tcl_FindEnsemble(
return NULL;
}
- if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link chains
* rather than duplicating it.
@@ -1383,7 +1381,8 @@ Tcl_FindEnsemble(
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
+ if (cmdPtr == NULL
+ || cmdPtr->objProc != TclEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" is not an ensemble command",
@@ -1421,11 +1420,11 @@ Tcl_IsEnsemble(
{
Command *cmdPtr = (Command *) token;
- if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
+ if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
return 0;
}
return 1;
@@ -1596,7 +1595,7 @@ TclMakeEnsemble(
/*
*----------------------------------------------------------------------
*
- * NsEnsembleImplementationCmd --
+ * TclEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
* namespace other than the global namespace) as a command with the same
@@ -1615,8 +1614,8 @@ TclMakeEnsemble(
*----------------------------------------------------------------------
*/
-static int
-NsEnsembleImplementationCmd(
+int
+TclEnsembleImplementationCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index da09366..906c2ce 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3096,6 +3096,10 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
+MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
+MODULE_SCOPE void TclRegisterCommandTypeName(
+ Tcl_ObjCmdProc *implementationProc,
+ const char *nameStr);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
@@ -3886,6 +3890,17 @@ MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
+ * Just for the purposes of command-type registration.
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd;
+
+/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 1a4297b..fe218ff 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -222,9 +222,6 @@ static int AliasDelete(Tcl_Interp *interp,
static int AliasDescribe(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, Tcl_Obj *objPtr);
static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp);
-static int AliasObjCmd(ClientData dummy,
- Tcl_Interp *currentInterp, int objc,
- Tcl_Obj *const objv[]);
static int AliasNRCmd(ClientData dummy,
Tcl_Interp *currentInterp, int objc,
Tcl_Obj *const objv[]);
@@ -257,8 +254,6 @@ static int SlaveInvokeHidden(Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
static int SlaveMarkTrusted(Tcl_Interp *interp,
Tcl_Interp *slaveInterp);
-static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[]);
static void SlaveObjCmdDeleteProc(ClientData clientData);
static int SlaveRecursionLimit(Tcl_Interp *interp,
Tcl_Interp *slaveInterp, int objc,
@@ -1390,7 +1385,7 @@ TclPreventAliasLoop(
* create or rename the command.
*/
- if (cmdPtr->objProc != AliasObjCmd) {
+ if (cmdPtr->objProc != TclAliasObjCmd) {
return TCL_OK;
}
@@ -1445,7 +1440,7 @@ TclPreventAliasLoop(
* Otherwise we do not have a loop.
*/
- if (aliasCmdPtr->objProc != AliasObjCmd) {
+ if (aliasCmdPtr->objProc != TclAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = aliasCmdPtr->objClientData;
@@ -1511,12 +1506,12 @@ AliasCreate(
if (slaveInterp == masterInterp) {
aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr,
+ TclGetString(namePtr), TclAliasObjCmd, AliasNRCmd, aliasPtr,
AliasObjCmdDeleteProc);
} else {
- aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
- TclGetString(namePtr), AliasObjCmd, aliasPtr,
- AliasObjCmdDeleteProc);
+ aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
+ TclGetString(namePtr), TclAliasObjCmd, aliasPtr,
+ AliasObjCmdDeleteProc);
}
if (TclPreventAliasLoop(interp, slaveInterp,
@@ -1752,7 +1747,7 @@ AliasList(
/*
*----------------------------------------------------------------------
*
- * AliasObjCmd --
+ * TclAliasObjCmd --
*
* This is the function that services invocations of aliases in a slave
* interpreter. One such command exists for each alias. When invoked,
@@ -1835,8 +1830,8 @@ AliasNRCmd(
return Tcl_NREvalObj(interp, listPtr, flags);
}
-static int
-AliasObjCmd(
+int
+TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2373,7 +2368,7 @@ SlaveCreate(
slavePtr->slaveEntryPtr = hPtr;
slavePtr->slaveInterp = slaveInterp;
slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path,
- SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
+ TclSlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc);
Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS);
Tcl_SetHashValue(hPtr, slavePtr);
Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
@@ -2441,7 +2436,7 @@ SlaveCreate(
/*
*----------------------------------------------------------------------
*
- * SlaveObjCmd --
+ * TclSlaveObjCmd --
*
* Command to manipulate an interpreter, e.g. to send commands to it to
* be evaluated. One such command exists for each slave interpreter.
@@ -2455,8 +2450,8 @@ SlaveCreate(
*----------------------------------------------------------------------
*/
-static int
-SlaveObjCmd(
+int
+TclSlaveObjCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -2478,7 +2473,7 @@ SlaveObjCmd(
};
if (slaveInterp == NULL) {
- Tcl_Panic("SlaveObjCmd: interpreter has been deleted");
+ Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted");
}
if (objc < 2) {
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index aed623a..cc2f953 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -89,8 +89,6 @@ static char * EstablishErrorInfoTraces(ClientData clientData,
static void FreeNsNameInternalRep(Tcl_Obj *objPtr);
static int GetNamespaceFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
-static int InvokeImportedCmd(ClientData clientData,
- Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int InvokeImportedNRCmd(ClientData clientData,
Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
static int NamespaceChildrenCmd(ClientData dummy,
@@ -1693,7 +1691,7 @@ DoImport(
dataPtr = ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
- InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
+ TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
@@ -1914,7 +1912,7 @@ TclGetOriginalCommand(
/*
*----------------------------------------------------------------------
*
- * InvokeImportedCmd --
+ * TclInvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that was
* created by Tcl_Import. Finds the "real" command (in another
@@ -1945,8 +1943,8 @@ InvokeImportedNRCmd(
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
-static int
-InvokeImportedCmd(
+int
+TclInvokeImportedCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
diff --git a/generic/tclOO.c b/generic/tclOO.c
index cb22de6..1138c99 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -84,15 +84,9 @@ static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
static inline void SquelchCachedName(Object *oPtr);
static void SquelchedNsFirst(ClientData clientData);
-static int PublicObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
static int PublicNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
-static int PrivateObjectCmd(ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *const *objv);
static int PrivateNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
@@ -650,10 +644,11 @@ AllocObject(
if (!nameStr) {
oPtr->command = Tcl_CreateObjCommand(interp,
- oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL);
+ oPtr->namespacePtr->fullName, TclOOPublicObjectCmd, oPtr,
+ NULL);
} else if (nameStr[0] == ':' && nameStr[1] == ':') {
oPtr->command = Tcl_CreateObjCommand(interp, nameStr,
- PublicObjectCmd, oPtr, NULL);
+ TclOOPublicObjectCmd, oPtr, NULL);
} else {
Tcl_DString buffer;
@@ -663,7 +658,7 @@ AllocObject(
TclDStringAppendLiteral(&buffer, "::");
Tcl_DStringAppend(&buffer, nameStr, -1);
oPtr->command = Tcl_CreateObjCommand(interp,
- Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL);
+ Tcl_DStringValue(&buffer), TclOOPublicObjectCmd, oPtr, NULL);
Tcl_DStringFree(&buffer);
}
@@ -692,7 +687,7 @@ AllocObject(
cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
&ignored);
cmdPtr->refCount = 1;
- cmdPtr->objProc = PrivateObjectCmd;
+ cmdPtr->objProc = TclOOPrivateObjectCmd;
cmdPtr->deleteProc = MyDeleted;
cmdPtr->objClientData = cmdPtr->deleteData = oPtr;
cmdPtr->proc = TclInvokeObjectCommand;
@@ -2368,7 +2363,7 @@ Tcl_ObjectSetMetadata(
/*
* ----------------------------------------------------------------------
*
- * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject --
+ * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject --
*
* Main entry point for object invokations. The Public* and Private*
* wrapper functions (implementations of both object instance commands
@@ -2378,8 +2373,8 @@ Tcl_ObjectSetMetadata(
* ----------------------------------------------------------------------
*/
-static int
-PublicObjectCmd(
+int
+TclOOPublicObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2399,8 +2394,8 @@ PublicNRObjectCmd(
NULL);
}
-static int
-PrivateObjectCmd(
+int
+TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -2784,9 +2779,9 @@ Tcl_GetObjectFromObj(
if (cmdPtr == NULL) {
goto notAnObject;
}
- if (cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
- if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) {
+ if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 9bceb4c..4907b45 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -3868,6 +3868,12 @@ TclZlibInit(
Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
+ * Allow command type introspection to do something sensible with streams.
+ */
+
+ TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
+
+ /*
* Formally provide the package as a Tcl built-in.
*/
diff --git a/tests/info.test b/tests/info.test
index 3057dd2..7cd6678 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -19,9 +19,9 @@ if {{::tcltest} ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
-
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
+testConstraint zlib [llength [info commands zlib]]
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
@@ -33,7 +33,7 @@ namespace eval test_ns_info1 {
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
-
+
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
@@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} {
proc testinfocmdcount {} {
set x [info cmdcount]
set y 12345
- set z [info cm]
+ set z [info cmdc]
expr {$z-$x}
}
test info-3.1 {info cmdcount compiled} {
@@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} {
test info-3.2 {info cmdcount evaled} -body {
set x [info cmdcount]
set y 12345
- set z [info cm]
+ set z [info cmdc]
expr {$z-$x}
} -cleanup {unset x y z} -result 4
test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4
@@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
} -result {wrong # args: should be "info subcommand ?arg ...?"}
test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
info gorp
-} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
info c
-} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
info l
-} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
info s
-} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
##
# ### ### ### ######### ######### #########
@@ -2396,6 +2396,131 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0}
# -------------------------------------------------------------------------
+namespace eval ::testinfocmdtype {
+ apply {cmds {
+ foreach c $cmds {rename $c {}}
+ } ::testinfocmdtype} [info commands ::testinfocmdtype::*]
+}
+test info-40.1 {info cmdtype: syntax} -body {
+ info cmdtype
+} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
+test info-40.2 {info cmdtype: syntax} -body {
+ info cmdtype foo bar
+} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"}
+test info-40.3 {info cmdtype: no such command} -body {
+ info cmdtype ::testinfocmdtype::foo
+} -returnCodes error -result {unknown command "::testinfocmdtype::foo"}
+test info-40.4 {info cmdtype: native commands} -body {
+ info cmdtype ::if
+} -result native
+test info-40.5 {info cmdtype: native commands} -body {
+ info cmdtype ::puts
+} -result native
+test info-40.6 {info cmdtype: native commands} -body {
+ info cmdtype ::yield
+} -result native
+test info-40.7 {info cmdtype: procedures} -setup {
+ proc ::testinfocmdtype::someproc {} {}
+} -body {
+ info cmdtype ::testinfocmdtype::someproc
+} -cleanup {
+ rename ::testinfocmdtype::someproc {}
+} -result proc
+test info-40.8 {info cmdtype: aliases} -setup {
+ interp alias {} ::testinfocmdtype::somealias {} ::puts
+} -body {
+ info cmdtype ::testinfocmdtype::somealias
+} -cleanup {
+ rename ::testinfocmdtype::somealias {}
+} -result alias
+test info-40.9 {info cmdtype: imports} -setup {
+ namespace eval ::testinfocmdtype {
+ namespace eval foo {
+ proc bar {} {}
+ namespace export bar
+ }
+ namespace import foo::bar
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::bar
+} -cleanup {
+ rename ::testinfocmdtype::bar {}
+ namespace delete ::testinfocmdtype::foo
+} -result import
+test info-40.10 {info cmdtype: slaves} -setup {
+ apply {i {
+ rename $i ::testinfocmdtype::slave
+ variable ::testinfocmdtype::slave $i
+ }} [interp create]
+} -body {
+ info cmdtype ::testinfocmdtype::slave
+} -cleanup {
+ interp delete $::testinfocmdtype::slave
+} -result slave
+test info-40.11 {info cmdtype: objects} -setup {
+ apply {{} {
+ oo::object create obj
+ } ::testinfocmdtype}
+} -body {
+ info cmdtype ::testinfocmdtype::obj
+} -cleanup {
+ ::testinfocmdtype::obj destroy
+} -result object
+test info-40.12 {info cmdtype: objects} -setup {
+ apply {{} {
+ oo::object create obj
+ } ::testinfocmdtype}
+} -body {
+ info cmdtype [info object namespace ::testinfocmdtype::obj]::my
+} -cleanup {
+ ::testinfocmdtype::obj destroy
+} -result privateObject
+test info-40.13 {info cmdtype: ensembles} -setup {
+ namespace eval ::testinfocmdtype {
+ namespace eval ensmbl {
+ proc bar {} {}
+ namespace export *
+ namespace ensemble create
+ }
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::ensmbl
+} -cleanup {
+ namespace delete ::testinfocmdtype::ensmbl
+} -result ensemble
+test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup {
+ namespace eval ::testinfocmdtype {
+ rename [zlib stream gzip] zstream
+ }
+} -body {
+ info cmdtype ::testinfocmdtype::zstream
+} -cleanup {
+ ::testinfocmdtype::zstream close
+} -result zlibStream
+test info-40.15 {info cmdtype: coroutines} -setup {
+ coroutine ::testinfocmdtype::coro eval yield
+} -body {
+ info cmdtype ::testinfocmdtype::coro
+} -cleanup {
+ ::testinfocmdtype::coro
+} -result coroutine
+test info-40.16 {info cmdtype: dynamic behavior} -setup {
+ proc ::testinfocmdtype::foo {} {}
+} -body {
+ namespace eval ::testinfocmdtype {
+ list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \
+ [namespace which foo] [rename foo bar] [namespace which bar] \
+ [catch {info cmdtype foo}] [catch {info cmdtype bar}]
+ }
+} -cleanup {
+ namespace eval ::testinfocmdtype {
+ catch {rename foo {}}
+ catch {rename bar {}}
+ }
+} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0}
+namespace delete ::testinfocmdtype
+
+# -------------------------------------------------------------------------
unset -nocomplain res
# cleanup
generated by cgit v0.12 at 2024-10-22 07:47:19 (GMT)