/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* PACKAGE: [incr Tcl]
|
* PACKAGE: [incr Tcl]
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
*
|
*
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
* C++ provides object-oriented extensions to C. It provides a means
|
* C++ provides object-oriented extensions to C. It provides a means
|
* of encapsulating related procedures together with their shared data
|
* of encapsulating related procedures together with their shared data
|
* in a local namespace that is hidden from the outside world. It
|
* in a local namespace that is hidden from the outside world. It
|
* promotes code re-use through inheritance. More than anything else,
|
* promotes code re-use through inheritance. More than anything else,
|
* it encourages better organization of Tcl applications through the
|
* it encourages better organization of Tcl applications through the
|
* object-oriented paradigm, leading to code that is easier to
|
* object-oriented paradigm, leading to code that is easier to
|
* understand and maintain.
|
* understand and maintain.
|
*
|
*
|
* Procedures in this file support the old-style syntax for [incr Tcl]
|
* Procedures in this file support the old-style syntax for [incr Tcl]
|
* class definitions:
|
* class definitions:
|
*
|
*
|
* itcl_class <className> {
|
* itcl_class <className> {
|
* inherit <base-class>...
|
* inherit <base-class>...
|
*
|
*
|
* constructor {<arglist>} { <body> }
|
* constructor {<arglist>} { <body> }
|
* destructor { <body> }
|
* destructor { <body> }
|
*
|
*
|
* method <name> {<arglist>} { <body> }
|
* method <name> {<arglist>} { <body> }
|
* proc <name> {<arglist>} { <body> }
|
* proc <name> {<arglist>} { <body> }
|
*
|
*
|
* public <varname> ?<init>? ?<config>?
|
* public <varname> ?<init>? ?<config>?
|
* protected <varname> ?<init>?
|
* protected <varname> ?<init>?
|
* common <varname> ?<init>?
|
* common <varname> ?<init>?
|
* }
|
* }
|
*
|
*
|
* This capability will be removed in a future release, after users
|
* This capability will be removed in a future release, after users
|
* have had a chance to switch over to the new syntax.
|
* have had a chance to switch over to the new syntax.
|
*
|
*
|
* ========================================================================
|
* ========================================================================
|
* AUTHOR: Michael J. McLennan
|
* AUTHOR: Michael J. McLennan
|
* Bell Labs Innovations for Lucent Technologies
|
* Bell Labs Innovations for Lucent Technologies
|
* mmclennan@lucent.com
|
* mmclennan@lucent.com
|
* http://www.tcltk.com/itcl
|
* http://www.tcltk.com/itcl
|
*
|
*
|
* RCS: $Id: itcl_obsolete.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* RCS: $Id: itcl_obsolete.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
* ========================================================================
|
* ========================================================================
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* See the file "license.terms" for information on usage and redistribution
|
* See the file "license.terms" for information on usage and redistribution
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
*/
|
*/
|
#include "itclInt.h"
|
#include "itclInt.h"
|
|
|
/*
|
/*
|
* FORWARD DECLARATIONS
|
* FORWARD DECLARATIONS
|
*/
|
*/
|
static int ItclOldClassCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldClassCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
|
|
static int ItclOldMethodCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldMethodCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldPublicCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldPublicCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldProtectedCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldProtectedCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldCommonCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldCommonCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
|
|
static int ItclOldBiDeleteCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiDeleteCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiVirtualCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiVirtualCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiPreviousCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiPreviousCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
|
|
static int ItclOldBiInfoMethodsCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiInfoMethodsCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiInfoProcsCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiInfoProcsCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiInfoPublicsCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiInfoPublicsCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiInfoProtectedsCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiInfoProtectedsCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
static int ItclOldBiInfoCommonsCmd _ANSI_ARGS_((ClientData cdata,
|
static int ItclOldBiInfoCommonsCmd _ANSI_ARGS_((ClientData cdata,
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
|
|
|
|
/*
|
/*
|
* Standard list of built-in methods for old-style objects.
|
* Standard list of built-in methods for old-style objects.
|
*/
|
*/
|
typedef struct BiMethod {
|
typedef struct BiMethod {
|
char* name; /* method name */
|
char* name; /* method name */
|
char* usage; /* string describing usage */
|
char* usage; /* string describing usage */
|
char* registration; /* registration name for C proc */
|
char* registration; /* registration name for C proc */
|
Tcl_ObjCmdProc *proc; /* implementation C proc */
|
Tcl_ObjCmdProc *proc; /* implementation C proc */
|
} BiMethod;
|
} BiMethod;
|
|
|
static BiMethod BiMethodList[] = {
|
static BiMethod BiMethodList[] = {
|
{ "cget", "-option",
|
{ "cget", "-option",
|
"@itcl-oldstyle-cget", Itcl_BiCgetCmd },
|
"@itcl-oldstyle-cget", Itcl_BiCgetCmd },
|
{ "configure", "?-option? ?value -option value...?",
|
{ "configure", "?-option? ?value -option value...?",
|
"@itcl-oldstyle-configure", Itcl_BiConfigureCmd },
|
"@itcl-oldstyle-configure", Itcl_BiConfigureCmd },
|
{ "delete", "",
|
{ "delete", "",
|
"@itcl-oldstyle-delete", ItclOldBiDeleteCmd },
|
"@itcl-oldstyle-delete", ItclOldBiDeleteCmd },
|
{ "isa", "className",
|
{ "isa", "className",
|
"@itcl-oldstyle-isa", Itcl_BiIsaCmd },
|
"@itcl-oldstyle-isa", Itcl_BiIsaCmd },
|
};
|
};
|
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
|
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_OldInit()
|
* Itcl_OldInit()
|
*
|
*
|
* Invoked by Itcl_Init() whenever a new interpeter is created to add
|
* Invoked by Itcl_Init() whenever a new interpeter is created to add
|
* [incr Tcl] facilities. Adds the commands needed for backward
|
* [incr Tcl] facilities. Adds the commands needed for backward
|
* compatibility with previous releases of [incr Tcl].
|
* compatibility with previous releases of [incr Tcl].
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_OldInit(interp,info)
|
Itcl_OldInit(interp,info)
|
Tcl_Interp *interp; /* interpreter to be updated */
|
Tcl_Interp *interp; /* interpreter to be updated */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
ItclObjectInfo *info; /* info regarding all known objects */
|
{
|
{
|
int i;
|
int i;
|
Tcl_Namespace *parserNs, *oldBiNs;
|
Tcl_Namespace *parserNs, *oldBiNs;
|
|
|
/*
|
/*
|
* Declare all of the old-style built-in methods as C procedures.
|
* Declare all of the old-style built-in methods as C procedures.
|
*/
|
*/
|
for (i=0; i < BiMethodListLen; i++) {
|
for (i=0; i < BiMethodListLen; i++) {
|
if (Itcl_RegisterObjC(interp,
|
if (Itcl_RegisterObjC(interp,
|
BiMethodList[i].registration+1, BiMethodList[i].proc,
|
BiMethodList[i].registration+1, BiMethodList[i].proc,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Create the "itcl::old-parser" namespace for backward
|
* Create the "itcl::old-parser" namespace for backward
|
* compatibility, to handle the old-style class definitions.
|
* compatibility, to handle the old-style class definitions.
|
*/
|
*/
|
parserNs = Tcl_CreateNamespace(interp, "::itcl::old-parser",
|
parserNs = Tcl_CreateNamespace(interp, "::itcl::old-parser",
|
(ClientData)info, Itcl_ReleaseData);
|
(ClientData)info, Itcl_ReleaseData);
|
|
|
if (!parserNs) {
|
if (!parserNs) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
" (cannot initialize itcl old-style parser)",
|
" (cannot initialize itcl old-style parser)",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
/*
|
/*
|
* Add commands for parsing old-style class definitions.
|
* Add commands for parsing old-style class definitions.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::inherit",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::inherit",
|
Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::constructor",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::constructor",
|
Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::destructor",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::destructor",
|
Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::method",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::method",
|
ItclOldMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::proc",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::proc",
|
Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::public",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::public",
|
ItclOldPublicCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldPublicCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::protected",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::protected",
|
ItclOldProtectedCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldProtectedCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::common",
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::common",
|
ItclOldCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
|
|
/*
|
/*
|
* Set the runtime variable resolver for the parser namespace,
|
* Set the runtime variable resolver for the parser namespace,
|
* to control access to "common" data members while parsing
|
* to control access to "common" data members while parsing
|
* the class definition.
|
* the class definition.
|
*/
|
*/
|
Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL,
|
Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL,
|
Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
|
Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
|
|
|
/*
|
/*
|
* Create the "itcl::old-builtin" namespace for backward
|
* Create the "itcl::old-builtin" namespace for backward
|
* compatibility with the old-style built-in commands.
|
* compatibility with the old-style built-in commands.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::virtual",
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::virtual",
|
ItclOldBiVirtualCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldBiVirtualCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::previous",
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::previous",
|
ItclOldBiPreviousCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
ItclOldBiPreviousCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
|
|
if (Itcl_CreateEnsemble(interp, "::itcl::old-builtin::info") != TCL_OK) {
|
if (Itcl_CreateEnsemble(interp, "::itcl::old-builtin::info") != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"class", "", Itcl_BiInfoClassCmd,
|
"class", "", Itcl_BiInfoClassCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"inherit", "", Itcl_BiInfoInheritCmd,
|
"inherit", "", Itcl_BiInfoInheritCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"heritage", "", Itcl_BiInfoHeritageCmd,
|
"heritage", "", Itcl_BiInfoHeritageCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"method", "?methodName? ?-args? ?-body?",
|
"method", "?methodName? ?-args? ?-body?",
|
ItclOldBiInfoMethodsCmd,
|
ItclOldBiInfoMethodsCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"proc", "?procName? ?-args? ?-body?",
|
"proc", "?procName? ?-args? ?-body?",
|
ItclOldBiInfoProcsCmd,
|
ItclOldBiInfoProcsCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"public", "?varName? ?-init? ?-value? ?-config?",
|
"public", "?varName? ?-init? ?-value? ?-config?",
|
ItclOldBiInfoPublicsCmd,
|
ItclOldBiInfoPublicsCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"protected", "?varName? ?-init? ?-value?",
|
"protected", "?varName? ?-init? ?-value?",
|
ItclOldBiInfoProtectedsCmd,
|
ItclOldBiInfoProtectedsCmd,
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"common", "?varName? ?-init? ?-value?",
|
"common", "?varName? ?-init? ?-value?",
|
ItclOldBiInfoCommonsCmd,
|
ItclOldBiInfoCommonsCmd,
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"args", "procname", Itcl_BiInfoArgsCmd,
|
"args", "procname", Itcl_BiInfoArgsCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK ||
|
!= TCL_OK ||
|
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"body", "procname", Itcl_BiInfoBodyCmd,
|
"body", "procname", Itcl_BiInfoBodyCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK
|
!= TCL_OK
|
) {
|
) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Plug in an "@error" handler to handle other options from
|
* Plug in an "@error" handler to handle other options from
|
* the usual info command.
|
* the usual info command.
|
*/
|
*/
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
"@error", (char*)NULL, Itcl_DefaultInfoCmd,
|
"@error", (char*)NULL, Itcl_DefaultInfoCmd,
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
!= TCL_OK
|
!= TCL_OK
|
) {
|
) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
oldBiNs = Tcl_FindNamespace(interp, "::itcl::old-builtin",
|
oldBiNs = Tcl_FindNamespace(interp, "::itcl::old-builtin",
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
|
|
if (!oldBiNs ||
|
if (!oldBiNs ||
|
Tcl_Export(interp, oldBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
|
Tcl_Export(interp, oldBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Install the "itcl_class" and "itcl_info" commands into
|
* Install the "itcl_class" and "itcl_info" commands into
|
* the global scope. This supports the old syntax for
|
* the global scope. This supports the old syntax for
|
* backward compatibility.
|
* backward compatibility.
|
*/
|
*/
|
Tcl_CreateObjCommand(interp, "::itcl_class", ItclOldClassCmd,
|
Tcl_CreateObjCommand(interp, "::itcl_class", ItclOldClassCmd,
|
(ClientData)info, Itcl_ReleaseData);
|
(ClientData)info, Itcl_ReleaseData);
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
|
|
if (Itcl_CreateEnsemble(interp, "::itcl_info") != TCL_OK) {
|
if (Itcl_CreateEnsemble(interp, "::itcl_info") != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
"classes", "?pattern?",
|
"classes", "?pattern?",
|
Itcl_FindClassesCmd, (ClientData)info, Itcl_ReleaseData)
|
Itcl_FindClassesCmd, (ClientData)info, Itcl_ReleaseData)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
"objects", "?-class className? ?-isa className? ?pattern?",
|
"objects", "?-class className? ?-isa className? ?pattern?",
|
Itcl_FindObjectsCmd, (ClientData)info, Itcl_ReleaseData)
|
Itcl_FindObjectsCmd, (ClientData)info, Itcl_ReleaseData)
|
!= TCL_OK) {
|
!= TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
Itcl_PreserveData((ClientData)info);
|
Itcl_PreserveData((ClientData)info);
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* Itcl_InstallOldBiMethods()
|
* Itcl_InstallOldBiMethods()
|
*
|
*
|
* Invoked when a class is first created, just after the class
|
* Invoked when a class is first created, just after the class
|
* definition has been parsed, to add definitions for built-in
|
* definition has been parsed, to add definitions for built-in
|
* methods to the class. If a method already exists in the class
|
* methods to the class. If a method already exists in the class
|
* with the same name as the built-in, then the built-in is skipped.
|
* with the same name as the built-in, then the built-in is skipped.
|
* Otherwise, a method definition for the built-in method is added.
|
* Otherwise, a method definition for the built-in method is added.
|
*
|
*
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
* message in the interpreter) if anything goes wrong.
|
* message in the interpreter) if anything goes wrong.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
int
|
int
|
Itcl_InstallOldBiMethods(interp, cdefn)
|
Itcl_InstallOldBiMethods(interp, cdefn)
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
ItclClass *cdefn; /* class definition to be updated */
|
ItclClass *cdefn; /* class definition to be updated */
|
{
|
{
|
int result = TCL_OK;
|
int result = TCL_OK;
|
|
|
int i;
|
int i;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
/*
|
/*
|
* Scan through all of the built-in methods and see if
|
* Scan through all of the built-in methods and see if
|
* that method already exists in the class. If not, add
|
* that method already exists in the class. If not, add
|
* it in.
|
* it in.
|
*
|
*
|
* TRICKY NOTE: The virtual tables haven't been built yet,
|
* TRICKY NOTE: The virtual tables haven't been built yet,
|
* so look for existing methods the hard way--by scanning
|
* so look for existing methods the hard way--by scanning
|
* through all classes.
|
* through all classes.
|
*/
|
*/
|
for (i=0; i < BiMethodListLen; i++) {
|
for (i=0; i < BiMethodListLen; i++) {
|
Itcl_InitHierIter(&hier, cdefn);
|
Itcl_InitHierIter(&hier, cdefn);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
|
|
entry = NULL;
|
entry = NULL;
|
while (cdPtr) {
|
while (cdPtr) {
|
entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
|
entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
|
if (entry) {
|
if (entry) {
|
break;
|
break;
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
if (!entry) {
|
if (!entry) {
|
result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
|
result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
|
BiMethodList[i].usage, BiMethodList[i].registration);
|
BiMethodList[i].usage, BiMethodList[i].registration);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
break;
|
break;
|
}
|
}
|
}
|
}
|
}
|
}
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldClassCmd()
|
* ItclOldClassCmd()
|
*
|
*
|
* Invoked by Tcl whenever the user issues a "itcl_class" command to
|
* Invoked by Tcl whenever the user issues a "itcl_class" command to
|
* specify a class definition. Handles the following syntax:
|
* specify a class definition. Handles the following syntax:
|
*
|
*
|
* itcl_class <className> {
|
* itcl_class <className> {
|
* inherit <base-class>...
|
* inherit <base-class>...
|
*
|
*
|
* constructor {<arglist>} { <body> }
|
* constructor {<arglist>} { <body> }
|
* destructor { <body> }
|
* destructor { <body> }
|
*
|
*
|
* method <name> {<arglist>} { <body> }
|
* method <name> {<arglist>} { <body> }
|
* proc <name> {<arglist>} { <body> }
|
* proc <name> {<arglist>} { <body> }
|
*
|
*
|
* public <varname> ?<init>? ?<config>?
|
* public <varname> ?<init>? ?<config>?
|
* protected <varname> ?<init>?
|
* protected <varname> ?<init>?
|
* common <varname> ?<init>?
|
* common <varname> ?<init>?
|
* }
|
* }
|
*
|
*
|
* NOTE: This command is will only be provided for a limited time,
|
* NOTE: This command is will only be provided for a limited time,
|
* to support backward compatibility with the old-style
|
* to support backward compatibility with the old-style
|
* [incr Tcl] syntax. Users should convert their scripts
|
* [incr Tcl] syntax. Users should convert their scripts
|
* to use the newer syntax (Itcl_ClassCmd()) as soon as possible.
|
* to use the newer syntax (Itcl_ClassCmd()) as soon as possible.
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclOldClassCmd(clientData, interp, objc, objv)
|
ItclOldClassCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo* info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo* info = (ItclObjectInfo*)clientData;
|
|
|
int result;
|
int result;
|
char *className;
|
char *className;
|
Tcl_Namespace *parserNs;
|
Tcl_Namespace *parserNs;
|
ItclClass *cdefnPtr;
|
ItclClass *cdefnPtr;
|
Tcl_HashEntry* entry;
|
Tcl_HashEntry* entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Tcl_CallFrame frame;
|
Tcl_CallFrame frame;
|
|
|
if (objc != 3) {
|
if (objc != 3) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
|
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
className = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
className = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
|
|
/*
|
/*
|
* Find the namespace to use as a parser for the class definition.
|
* Find the namespace to use as a parser for the class definition.
|
* If for some reason it is destroyed, bail out here.
|
* If for some reason it is destroyed, bail out here.
|
*/
|
*/
|
parserNs = Tcl_FindNamespace(interp, "::itcl::old-parser",
|
parserNs = Tcl_FindNamespace(interp, "::itcl::old-parser",
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
|
|
if (parserNs == NULL) {
|
if (parserNs == NULL) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while parsing class definition for \"%.100s\")",
|
sprintf(msg, "\n (while parsing class definition for \"%.100s\")",
|
className);
|
className);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Try to create the specified class and its namespace.
|
* Try to create the specified class and its namespace.
|
*/
|
*/
|
if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
|
if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
cdefnPtr->flags |= ITCL_OLD_STYLE;
|
cdefnPtr->flags |= ITCL_OLD_STYLE;
|
|
|
/*
|
/*
|
* Import the built-in commands from the itcl::old-builtin
|
* Import the built-in commands from the itcl::old-builtin
|
* and itcl::builtin namespaces. Do this before parsing the
|
* and itcl::builtin namespaces. Do this before parsing the
|
* class definition, so methods/procs can override the built-in
|
* class definition, so methods/procs can override the built-in
|
* commands.
|
* commands.
|
*/
|
*/
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
|
/* allowOverwrite */ 1);
|
/* allowOverwrite */ 1);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::old-builtin::*",
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::old-builtin::*",
|
/* allowOverwrite */ 1);
|
/* allowOverwrite */ 1);
|
}
|
}
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className);
|
sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Push this class onto the class definition stack so that it
|
* Push this class onto the class definition stack so that it
|
* becomes the current context for all commands in the parser.
|
* becomes the current context for all commands in the parser.
|
* Activate the parser and evaluate the class definition.
|
* Activate the parser and evaluate the class definition.
|
*/
|
*/
|
Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);
|
Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);
|
|
|
result = Tcl_PushCallFrame(interp, &frame, parserNs,
|
result = Tcl_PushCallFrame(interp, &frame, parserNs,
|
/* isProcCallFrame */ 0);
|
/* isProcCallFrame */ 0);
|
|
|
if (result == TCL_OK) {
|
if (result == TCL_OK) {
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
result = Tcl_EvalObj(interp, objv[2]);
|
result = Tcl_EvalObj(interp, objv[2]);
|
#else
|
#else
|
result = Tcl_EvalObj(interp, objv[2], 0);
|
result = Tcl_EvalObj(interp, objv[2], 0);
|
#endif
|
#endif
|
/* END CYGNUS LOCAL */
|
/* END CYGNUS LOCAL */
|
Tcl_PopCallFrame(interp);
|
Tcl_PopCallFrame(interp);
|
}
|
}
|
Itcl_PopStack(&info->cdefnStack);
|
Itcl_PopStack(&info->cdefnStack);
|
|
|
if (result != TCL_OK) {
|
if (result != TCL_OK) {
|
char msg[256];
|
char msg[256];
|
sprintf(msg, "\n (class \"%.200s\" body line %d)",
|
sprintf(msg, "\n (class \"%.200s\" body line %d)",
|
className, interp->errorLine);
|
className, interp->errorLine);
|
Tcl_AddErrorInfo(interp, msg);
|
Tcl_AddErrorInfo(interp, msg);
|
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* At this point, parsing of the class definition has succeeded.
|
* At this point, parsing of the class definition has succeeded.
|
* Add built-in methods such as "configure" and "cget"--as long
|
* Add built-in methods such as "configure" and "cget"--as long
|
* as they don't conflict with those defined in the class.
|
* as they don't conflict with those defined in the class.
|
*/
|
*/
|
if (Itcl_InstallOldBiMethods(interp, cdefnPtr) != TCL_OK) {
|
if (Itcl_InstallOldBiMethods(interp, cdefnPtr) != TCL_OK) {
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* See if this class has a "constructor", and if it does, mark
|
* See if this class has a "constructor", and if it does, mark
|
* it as "old-style". This will allow the "config" argument
|
* it as "old-style". This will allow the "config" argument
|
* to work.
|
* to work.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefnPtr->functions, "constructor");
|
entry = Tcl_FindHashEntry(&cdefnPtr->functions, "constructor");
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
}
|
}
|
|
|
/*
|
/*
|
* Build the virtual tables for this class.
|
* Build the virtual tables for this class.
|
*/
|
*/
|
Itcl_BuildVirtualTables(cdefnPtr);
|
Itcl_BuildVirtualTables(cdefnPtr);
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldMethodCmd()
|
* ItclOldMethodCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "method" command is invoked to define an object method.
|
* the "method" command is invoked to define an object method.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* method <name> {<arglist>} {<body>}
|
* method <name> {<arglist>} {<body>}
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclOldMethodCmd(clientData, interp, objc, objv)
|
ItclOldMethodCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *arglist, *body;
|
char *name, *arglist, *body;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
|
|
if (objc != 4) {
|
if (objc != 4) {
|
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
|
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (Tcl_FindHashEntry(&cdefn->functions, name)) {
|
if (Tcl_FindHashEntry(&cdefn->functions, name)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\"", name, "\" already defined in class \"", cdefn->name, "\"",
|
"\"", name, "\" already defined in class \"", cdefn->name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
|
|
if (Itcl_CreateMethod(interp, cdefn, name, arglist, body) != TCL_OK) {
|
if (Itcl_CreateMethod(interp, cdefn, name, arglist, body) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Find the method that was just created and mark it as an
|
* Find the method that was just created and mark it as an
|
* "old-style" method, so that the magic "config" argument
|
* "old-style" method, so that the magic "config" argument
|
* will be allowed to work. This is done for backward-
|
* will be allowed to work. This is done for backward-
|
* compatibility with earlier releases. In the latest version,
|
* compatibility with earlier releases. In the latest version,
|
* use of the "config" argument is discouraged.
|
* use of the "config" argument is discouraged.
|
*/
|
*/
|
entry = Tcl_FindHashEntry(&cdefn->functions, name);
|
entry = Tcl_FindHashEntry(&cdefn->functions, name);
|
if (entry) {
|
if (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
}
|
}
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldPublicCmd()
|
* ItclOldPublicCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "public" command is invoked to define a public variable.
|
* the "public" command is invoked to define a public variable.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* public <varname> ?<init>? ?<config>?
|
* public <varname> ?<init>? ?<config>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclOldPublicCmd(clientData, interp, objc, objv)
|
ItclOldPublicCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *init, *config;
|
char *name, *init, *config;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
|
|
if ((objc < 2) || (objc > 4)) {
|
if ((objc < 2) || (objc > 4)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init? ?config?");
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init? ?config?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the variable name does not contain anything
|
* Make sure that the variable name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (strstr(name, "::")) {
|
if (strstr(name, "::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad variable name \"", name, "\"",
|
"bad variable name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
init = NULL;
|
init = NULL;
|
config = NULL;
|
config = NULL;
|
if (objc >= 3) {
|
if (objc >= 3) {
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
}
|
}
|
if (objc >= 4) {
|
if (objc >= 4) {
|
config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
}
|
}
|
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
|
&vdefn) != TCL_OK) {
|
&vdefn) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
vdefn->member->protection = ITCL_PUBLIC;
|
vdefn->member->protection = ITCL_PUBLIC;
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldProtectedCmd()
|
* ItclOldProtectedCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "protected" command is invoked to define a protected variable.
|
* the "protected" command is invoked to define a protected variable.
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* protected <varname> ?<init>?
|
* protected <varname> ?<init>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclOldProtectedCmd(clientData, interp, objc, objv)
|
ItclOldProtectedCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
char *name, *init;
|
char *name, *init;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
|
|
if ((objc < 2) || (objc > 3)) {
|
if ((objc < 2) || (objc > 3)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the variable name does not contain anything
|
* Make sure that the variable name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (strstr(name, "::")) {
|
if (strstr(name, "::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad variable name \"", name, "\"",
|
"bad variable name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (objc == 3) {
|
if (objc == 3) {
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
} else {
|
} else {
|
init = NULL;
|
init = NULL;
|
}
|
}
|
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
&vdefn) != TCL_OK) {
|
&vdefn) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
vdefn->member->protection = ITCL_PROTECTED;
|
vdefn->member->protection = ITCL_PROTECTED;
|
|
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldCommonCmd()
|
* ItclOldCommonCmd()
|
*
|
*
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* Invoked by Tcl during the parsing of a class definition whenever
|
* the "common" command is invoked to define a variable that is
|
* the "common" command is invoked to define a variable that is
|
* common to all objects in the class. Handles the following syntax:
|
* common to all objects in the class. Handles the following syntax:
|
*
|
*
|
* common <varname> ?<init>?
|
* common <varname> ?<init>?
|
*
|
*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
static int
|
static int
|
ItclOldCommonCmd(clientData, interp, objc, objv)
|
ItclOldCommonCmd(clientData, interp, objc, objv)
|
ClientData clientData; /* info for all known objects */
|
ClientData clientData; /* info for all known objects */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
|
|
int newEntry;
|
int newEntry;
|
char *name, *init;
|
char *name, *init;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Namespace *nsPtr;
|
Namespace *nsPtr;
|
Var *varPtr;
|
Var *varPtr;
|
|
|
if ((objc < 2) || (objc > 3)) {
|
if ((objc < 2) || (objc > 3)) {
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Make sure that the variable name does not contain anything
|
* Make sure that the variable name does not contain anything
|
* goofy like a "::" scope qualifier.
|
* goofy like a "::" scope qualifier.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
if (strstr(name, "::")) {
|
if (strstr(name, "::")) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad variable name \"", name, "\"",
|
"bad variable name \"", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (objc == 3) {
|
if (objc == 3) {
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
} else {
|
} else {
|
init = NULL;
|
init = NULL;
|
}
|
}
|
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
&vdefn) != TCL_OK) {
|
&vdefn) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
vdefn->member->protection = ITCL_PROTECTED;
|
vdefn->member->protection = ITCL_PROTECTED;
|
vdefn->member->flags |= ITCL_COMMON;
|
vdefn->member->flags |= ITCL_COMMON;
|
|
|
/*
|
/*
|
* Create the variable in the namespace associated with the
|
* Create the variable in the namespace associated with the
|
* class. Do this the hard way, to avoid the variable resolver
|
* class. Do this the hard way, to avoid the variable resolver
|
* procedures. These procedures won't work until we rebuild
|
* procedures. These procedures won't work until we rebuild
|
* the virtual tables below.
|
* the virtual tables below.
|
*/
|
*/
|
nsPtr = (Namespace*)cdefnPtr->namesp;
|
nsPtr = (Namespace*)cdefnPtr->namesp;
|
entry = Tcl_CreateHashEntry(&nsPtr->varTable,
|
entry = Tcl_CreateHashEntry(&nsPtr->varTable,
|
vdefn->member->name, &newEntry);
|
vdefn->member->name, &newEntry);
|
|
|
varPtr = _TclNewVar();
|
varPtr = _TclNewVar();
|
varPtr->hPtr = entry;
|
varPtr->hPtr = entry;
|
varPtr->nsPtr = nsPtr;
|
varPtr->nsPtr = nsPtr;
|
varPtr->refCount++; /* protect from being deleted */
|
varPtr->refCount++; /* protect from being deleted */
|
|
|
Tcl_SetHashValue(entry, varPtr);
|
Tcl_SetHashValue(entry, varPtr);
|
|
|
/*
|
/*
|
* TRICKY NOTE: Make sure to rebuild the virtual tables for this
|
* TRICKY NOTE: Make sure to rebuild the virtual tables for this
|
* class so that this variable is ready to access. The variable
|
* class so that this variable is ready to access. The variable
|
* resolver for the parser namespace needs this info to find the
|
* resolver for the parser namespace needs this info to find the
|
* variable if the developer tries to set it within the class
|
* variable if the developer tries to set it within the class
|
* definition.
|
* definition.
|
*
|
*
|
* If an initialization value was specified, then initialize
|
* If an initialization value was specified, then initialize
|
* the variable now.
|
* the variable now.
|
*/
|
*/
|
Itcl_BuildVirtualTables(cdefnPtr);
|
Itcl_BuildVirtualTables(cdefnPtr);
|
|
|
if (init) {
|
if (init) {
|
init = Tcl_SetVar(interp, vdefn->member->name, init,
|
init = Tcl_SetVar(interp, vdefn->member->name, init,
|
TCL_NAMESPACE_ONLY);
|
TCL_NAMESPACE_ONLY);
|
|
|
if (!init) {
|
if (!init) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot initialize common variable \"",
|
"cannot initialize common variable \"",
|
vdefn->member->name, "\"",
|
vdefn->member->name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldDeleteCmd()
|
* ItclOldDeleteCmd()
|
*
|
*
|
* Invokes the destructors, and deletes the object that invoked this
|
* Invokes the destructors, and deletes the object that invoked this
|
* operation. If an error is encountered during destruction, the
|
* operation. If an error is encountered during destruction, the
|
* delete operation is aborted. Handles the following syntax:
|
* delete operation is aborted. Handles the following syntax:
|
*
|
*
|
* <objName> delete
|
* <objName> delete
|
*
|
*
|
* When an object is successfully deleted, it is removed from the
|
* When an object is successfully deleted, it is removed from the
|
* list of known objects, and its access command is deleted.
|
* list of known objects, and its access command is deleted.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiDeleteCmd(dummy, interp, objc, objv)
|
ItclOldBiDeleteCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
if (objc != 1) {
|
if (objc != 1) {
|
Tcl_WrongNumArgs(interp, 1, objv, "");
|
Tcl_WrongNumArgs(interp, 1, objv, "");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is an object context, then destruct the object
|
* If there is an object context, then destruct the object
|
* and delete it.
|
* and delete it.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (!contextObj) {
|
if (!contextObj) {
|
Tcl_SetResult(interp, "improper usage: should be \"object delete\"",
|
Tcl_SetResult(interp, "improper usage: should be \"object delete\"",
|
TCL_STATIC);
|
TCL_STATIC);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
|
if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldVirtualCmd()
|
* ItclOldVirtualCmd()
|
*
|
*
|
* Executes the remainder of its command line arguments in the
|
* Executes the remainder of its command line arguments in the
|
* most-specific class scope for the current object. If there is
|
* most-specific class scope for the current object. If there is
|
* no object context, this fails.
|
* no object context, this fails.
|
*
|
*
|
* NOTE: All methods are now implicitly virtual, and there are
|
* NOTE: All methods are now implicitly virtual, and there are
|
* much better ways to manipulate scope. This command is only
|
* much better ways to manipulate scope. This command is only
|
* provided for backward-compatibility, and should be avoided.
|
* provided for backward-compatibility, and should be avoided.
|
*
|
*
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiVirtualCmd(dummy, interp, objc, objv)
|
ItclOldBiVirtualCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int result;
|
int result;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclContext context;
|
ItclContext context;
|
|
|
if (objc == 1) {
|
if (objc == 1) {
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"\n This command will be removed soon.",
|
"\n This command will be removed soon.",
|
"\n Commands are now virtual by default.",
|
"\n Commands are now virtual by default.",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is no object context, then return an error.
|
* If there is no object context, then return an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
if (!contextObj) {
|
if (!contextObj) {
|
Tcl_ResetResult(interp);
|
Tcl_ResetResult(interp);
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"cannot use \"virtual\" without an object context\n",
|
"cannot use \"virtual\" without an object context\n",
|
" This command will be removed soon.\n",
|
" This command will be removed soon.\n",
|
" Commands are now virtual by default.",
|
" Commands are now virtual by default.",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Install the most-specific namespace for this object, with
|
* Install the most-specific namespace for this object, with
|
* the object context as clientData. Invoke the rest of the
|
* the object context as clientData. Invoke the rest of the
|
* args as a command in that namespace.
|
* args as a command in that namespace.
|
*/
|
*/
|
if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
|
if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
|
contextObj, &context) != TCL_OK) {
|
contextObj, &context) != TCL_OK) {
|
|
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
result = Itcl_EvalArgs(interp, objc-1, objv+1);
|
result = Itcl_EvalArgs(interp, objc-1, objv+1);
|
Itcl_PopContext(interp, &context);
|
Itcl_PopContext(interp, &context);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldPreviousCmd()
|
* ItclOldPreviousCmd()
|
*
|
*
|
* Executes the remainder of its command line arguments in the
|
* Executes the remainder of its command line arguments in the
|
* previous class scope (i.e., the next scope up in the heritage
|
* previous class scope (i.e., the next scope up in the heritage
|
* list).
|
* list).
|
*
|
*
|
* NOTE: There are much better ways to manipulate scope. This
|
* NOTE: There are much better ways to manipulate scope. This
|
* command is only provided for backward-compatibility, and should
|
* command is only provided for backward-compatibility, and should
|
* be avoided.
|
* be avoided.
|
*
|
*
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiPreviousCmd(dummy, interp, objc, objv)
|
ItclOldBiPreviousCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
int result;
|
int result;
|
char *name;
|
char *name;
|
ItclClass *contextClass, *base;
|
ItclClass *contextClass, *base;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclMember *member;
|
ItclMember *member;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
Itcl_ListElem *elem;
|
Itcl_ListElem *elem;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
|
|
if (objc < 2) {
|
if (objc < 2) {
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If the current context is not a class namespace,
|
* If the current context is not a class namespace,
|
* return an error.
|
* return an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Get the heritage information for this class and move one
|
* Get the heritage information for this class and move one
|
* level up in the hierarchy. If there is no base class,
|
* level up in the hierarchy. If there is no base class,
|
* return an error.
|
* return an error.
|
*/
|
*/
|
elem = Itcl_FirstListElem(&contextClass->bases);
|
elem = Itcl_FirstListElem(&contextClass->bases);
|
if (!elem) {
|
if (!elem) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"no previous class in inheritance hierarchy for \"",
|
"no previous class in inheritance hierarchy for \"",
|
contextClass->name, "\"",
|
contextClass->name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
base = (ItclClass*)Itcl_GetListValue(elem);
|
base = (ItclClass*)Itcl_GetListValue(elem);
|
|
|
/*
|
/*
|
* Look in the command resolution table for the base class
|
* Look in the command resolution table for the base class
|
* to find the desired method.
|
* to find the desired method.
|
*/
|
*/
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
entry = Tcl_FindHashEntry(&base->resolveCmds, name);
|
entry = Tcl_FindHashEntry(&base->resolveCmds, name);
|
if (!entry) {
|
if (!entry) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"invalid command name \"", base->name, "::", name, "\"",
|
"invalid command name \"", base->name, "::", name, "\"",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
member = mfunc->member;
|
member = mfunc->member;
|
|
|
/*
|
/*
|
* Make sure that this method is accessible.
|
* Make sure that this method is accessible.
|
*/
|
*/
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
member->classDefn->info);
|
member->classDefn->info);
|
|
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"can't access \"", member->fullname, "\": ",
|
"can't access \"", member->fullname, "\": ",
|
Itcl_ProtectionStr(member->protection), " function",
|
Itcl_ProtectionStr(member->protection), " function",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Invoke the desired method by calling Itcl_EvalMemberCode.
|
* Invoke the desired method by calling Itcl_EvalMemberCode.
|
* directly. This bypasses the virtual behavior built into
|
* directly. This bypasses the virtual behavior built into
|
* the usual Itcl_ExecMethod handler.
|
* the usual Itcl_ExecMethod handler.
|
*/
|
*/
|
result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
|
result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
|
objc-1, objv+1);
|
objc-1, objv+1);
|
|
|
result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);
|
result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);
|
|
|
return result;
|
return result;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldBiInfoMethodsCmd()
|
* ItclOldBiInfoMethodsCmd()
|
*
|
*
|
* Returns information regarding methods for an object. This command
|
* Returns information regarding methods for an object. This command
|
* can be invoked with or without an object context:
|
* can be invoked with or without an object context:
|
*
|
*
|
* <objName> info... <= returns info for most-specific class
|
* <objName> info... <= returns info for most-specific class
|
* info... <= returns info for active namespace
|
* info... <= returns info for active namespace
|
*
|
*
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info method ?methodName? ?-args? ?-body?
|
* info method ?methodName? ?-args? ?-body?
|
*
|
*
|
* If the ?methodName? is not specified, then a list of all known
|
* If the ?methodName? is not specified, then a list of all known
|
* methods is returned. Otherwise, the information (args/body) for
|
* methods is returned. Otherwise, the information (args/body) for
|
* a specific method is returned. Returns a status TCL_OK/TCL_ERROR
|
* a specific method is returned. Returns a status TCL_OK/TCL_ERROR
|
* to indicate success/failure.
|
* to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiInfoMethodsCmd(dummy, interp, objc, objv)
|
ItclOldBiInfoMethodsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
char *methodName = NULL;
|
char *methodName = NULL;
|
int methodArgs = 0;
|
int methodArgs = 0;
|
int methodBody = 0;
|
int methodBody = 0;
|
|
|
char *token;
|
char *token;
|
ItclClass *contextClass, *cdefn;
|
ItclClass *contextClass, *cdefn;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is an object context, then use the most-specific
|
* If there is an object context, then use the most-specific
|
* class for the object. Otherwise, use the current class
|
* class for the object. Otherwise, use the current class
|
* namespace.
|
* namespace.
|
*/
|
*/
|
if (contextObj) {
|
if (contextObj) {
|
contextClass = contextObj->classDefn;
|
contextClass = contextObj->classDefn;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args: ?methodName? ?-args? ?-body?
|
* Process args: ?methodName? ?-args? ?-body?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
methodName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
methodName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
for ( ; objc > 0; objc--, objv++) {
|
for ( ; objc > 0; objc--, objv++) {
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (strcmp(token, "-args") == 0)
|
if (strcmp(token, "-args") == 0)
|
methodArgs = ~0;
|
methodArgs = ~0;
|
else if (strcmp(token, "-body") == 0)
|
else if (strcmp(token, "-body") == 0)
|
methodBody = ~0;
|
methodBody = ~0;
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", token, "\": should be -args or -body",
|
"bad option \"", token, "\": should be -args or -body",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific method.
|
* Return info for a specific method.
|
*/
|
*/
|
if (methodName) {
|
if (methodName) {
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, methodName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, methodName);
|
if (entry) {
|
if (entry) {
|
int i, valc = 0;
|
int i, valc = 0;
|
Tcl_Obj *valv[5];
|
Tcl_Obj *valv[5];
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If the implementation has not yet been defined,
|
* If the implementation has not yet been defined,
|
* autoload it now.
|
* autoload it now.
|
*/
|
*/
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
mcode = mfunc->member->code;
|
mcode = mfunc->member->code;
|
|
|
if (!methodArgs && !methodBody) {
|
if (!methodArgs && !methodBody) {
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
methodArgs = methodBody = ~0;
|
methodArgs = methodBody = ~0;
|
}
|
}
|
if (methodArgs) {
|
if (methodArgs) {
|
if (mcode->arglist) {
|
if (mcode->arglist) {
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("", -1);
|
objPtr = Tcl_NewStringObj("", -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
}
|
}
|
if (methodBody) {
|
if (methodBody) {
|
objPtr = mcode->procPtr->bodyPtr;
|
objPtr = mcode->procPtr->bodyPtr;
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If the result list has a single element, then
|
* If the result list has a single element, then
|
* return it using Tcl_SetResult() so that it will
|
* return it using Tcl_SetResult() so that it will
|
* look like a string and not a list with one element.
|
* look like a string and not a list with one element.
|
*/
|
*/
|
if (valc == 1) {
|
if (valc == 1) {
|
objPtr = valv[0];
|
objPtr = valv[0];
|
} else {
|
} else {
|
objPtr = Tcl_NewListObj(valc, valv);
|
objPtr = Tcl_NewListObj(valc, valv);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
for (i=0; i < valc; i++) {
|
for (i=0; i < valc; i++) {
|
Tcl_DecrRefCount(valv[i]);
|
Tcl_DecrRefCount(valv[i]);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of available methods.
|
* Return the list of available methods.
|
*/
|
*/
|
else {
|
else {
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
while (entry) {
|
while (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
|
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldBiInfoProcsCmd()
|
* ItclOldBiInfoProcsCmd()
|
*
|
*
|
* Returns information regarding procs for a class. This command
|
* Returns information regarding procs for a class. This command
|
* can be invoked with or without an object context:
|
* can be invoked with or without an object context:
|
*
|
*
|
* <objName> info... <= returns info for most-specific class
|
* <objName> info... <= returns info for most-specific class
|
* info... <= returns info for active namespace
|
* info... <= returns info for active namespace
|
*
|
*
|
* Handles the following syntax:
|
* Handles the following syntax:
|
*
|
*
|
* info proc ?procName? ?-args? ?-body?
|
* info proc ?procName? ?-args? ?-body?
|
*
|
*
|
* If the ?procName? is not specified, then a list of all known
|
* If the ?procName? is not specified, then a list of all known
|
* procs is returned. Otherwise, the information (args/body) for
|
* procs is returned. Otherwise, the information (args/body) for
|
* a specific proc is returned. Returns a status TCL_OK/TCL_ERROR
|
* a specific proc is returned. Returns a status TCL_OK/TCL_ERROR
|
* to indicate success/failure.
|
* to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiInfoProcsCmd(dummy, interp, objc, objv)
|
ItclOldBiInfoProcsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
char *procName = NULL;
|
char *procName = NULL;
|
int procArgs = 0;
|
int procArgs = 0;
|
int procBody = 0;
|
int procBody = 0;
|
|
|
char *token;
|
char *token;
|
ItclClass *contextClass, *cdefn;
|
ItclClass *contextClass, *cdefn;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
ItclMemberFunc *mfunc;
|
ItclMemberFunc *mfunc;
|
ItclMemberCode *mcode;
|
ItclMemberCode *mcode;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* If there is an object context, then use the most-specific
|
* If there is an object context, then use the most-specific
|
* class for the object. Otherwise, use the current class
|
* class for the object. Otherwise, use the current class
|
* namespace.
|
* namespace.
|
*/
|
*/
|
if (contextObj) {
|
if (contextObj) {
|
contextClass = contextObj->classDefn;
|
contextClass = contextObj->classDefn;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args: ?procName? ?-args? ?-body?
|
* Process args: ?procName? ?-args? ?-body?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
procName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
procName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
for ( ; objc > 0; objc--, objv++) {
|
for ( ; objc > 0; objc--, objv++) {
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (strcmp(token, "-args") == 0)
|
if (strcmp(token, "-args") == 0)
|
procArgs = ~0;
|
procArgs = ~0;
|
else if (strcmp(token, "-body") == 0)
|
else if (strcmp(token, "-body") == 0)
|
procBody = ~0;
|
procBody = ~0;
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", token, "\": should be -args or -body",
|
"bad option \"", token, "\": should be -args or -body",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific proc.
|
* Return info for a specific proc.
|
*/
|
*/
|
if (procName) {
|
if (procName) {
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, procName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, procName);
|
if (entry) {
|
if (entry) {
|
int i, valc = 0;
|
int i, valc = 0;
|
Tcl_Obj *valv[5];
|
Tcl_Obj *valv[5];
|
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* If the implementation has not yet been defined,
|
* If the implementation has not yet been defined,
|
* autoload it now.
|
* autoload it now.
|
*/
|
*/
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
mcode = mfunc->member->code;
|
mcode = mfunc->member->code;
|
|
|
if (!procArgs && !procBody) {
|
if (!procArgs && !procBody) {
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
procArgs = procBody = ~0;
|
procArgs = procBody = ~0;
|
}
|
}
|
if (procArgs) {
|
if (procArgs) {
|
if (mcode->arglist) {
|
if (mcode->arglist) {
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("", -1);
|
objPtr = Tcl_NewStringObj("", -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
}
|
}
|
if (procBody) {
|
if (procBody) {
|
objPtr = mcode->procPtr->bodyPtr;
|
objPtr = mcode->procPtr->bodyPtr;
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If the result list has a single element, then
|
* If the result list has a single element, then
|
* return it using Tcl_SetResult() so that it will
|
* return it using Tcl_SetResult() so that it will
|
* look like a string and not a list with one element.
|
* look like a string and not a list with one element.
|
*/
|
*/
|
if (valc == 1) {
|
if (valc == 1) {
|
objPtr = valv[0];
|
objPtr = valv[0];
|
} else {
|
} else {
|
objPtr = Tcl_NewListObj(valc, valv);
|
objPtr = Tcl_NewListObj(valc, valv);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
for (i=0; i < valc; i++) {
|
for (i=0; i < valc; i++) {
|
Tcl_DecrRefCount(valv[i]);
|
Tcl_DecrRefCount(valv[i]);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of available procs.
|
* Return the list of available procs.
|
*/
|
*/
|
else {
|
else {
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
while (entry) {
|
while (entry) {
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
|
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldBiInfoPublicsCmd()
|
* ItclOldBiInfoPublicsCmd()
|
*
|
*
|
* Sets the interpreter result to contain information for public
|
* Sets the interpreter result to contain information for public
|
* variables in the class. Handles the following syntax:
|
* variables in the class. Handles the following syntax:
|
*
|
*
|
* info public ?varName? ?-init? ?-value? ?-config?
|
* info public ?varName? ?-init? ?-value? ?-config?
|
*
|
*
|
* If the ?varName? is not specified, then a list of all known public
|
* If the ?varName? is not specified, then a list of all known public
|
* variables is returned. Otherwise, the information (init/value/config)
|
* variables is returned. Otherwise, the information (init/value/config)
|
* for a specific variable is returned. Returns a status
|
* for a specific variable is returned. Returns a status
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiInfoPublicsCmd(dummy, interp, objc, objv)
|
ItclOldBiInfoPublicsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
char *varName = NULL;
|
char *varName = NULL;
|
int varInit = 0;
|
int varInit = 0;
|
int varCheck = 0;
|
int varCheck = 0;
|
int varValue = 0;
|
int varValue = 0;
|
|
|
char *token, *val;
|
char *token, *val;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclMember *member;
|
ItclMember *member;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args: ?varName? ?-init? ?-value? ?-config?
|
* Process args: ?varName? ?-init? ?-value? ?-config?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
for ( ; objc > 0; objc--, objv++) {
|
for ( ; objc > 0; objc--, objv++) {
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (strcmp(token, "-init") == 0)
|
if (strcmp(token, "-init") == 0)
|
varInit = ~0;
|
varInit = ~0;
|
else if (strcmp(token, "-value") == 0)
|
else if (strcmp(token, "-value") == 0)
|
varValue = ~0;
|
varValue = ~0;
|
else if (strcmp(token, "-config") == 0)
|
else if (strcmp(token, "-config") == 0)
|
varCheck = ~0;
|
varCheck = ~0;
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", token,
|
"bad option \"", token,
|
"\": should be -init, -value or -config",
|
"\": should be -init, -value or -config",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific variable.
|
* Return info for a specific variable.
|
*/
|
*/
|
if (varName) {
|
if (varName) {
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
vlookup = NULL;
|
vlookup = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (vlookup) {
|
if (vlookup) {
|
int i, valc = 0;
|
int i, valc = 0;
|
Tcl_Obj *valv[5];
|
Tcl_Obj *valv[5];
|
|
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
|
|
if (!varInit && !varCheck && !varValue) {
|
if (!varInit && !varCheck && !varValue) {
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
varInit = varCheck = varValue = ~0;
|
varInit = varCheck = varValue = ~0;
|
}
|
}
|
if (varInit) {
|
if (varInit) {
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
if (varValue) {
|
if (varValue) {
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
contextObj, contextObj->classDefn);
|
contextObj, contextObj->classDefn);
|
|
|
if (!val) {
|
if (!val) {
|
val = "<undefined>";
|
val = "<undefined>";
|
}
|
}
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
if (varCheck) {
|
if (varCheck) {
|
if (member->code && member->code->procPtr->bodyPtr) {
|
if (member->code && member->code->procPtr->bodyPtr) {
|
objPtr = member->code->procPtr->bodyPtr;
|
objPtr = member->code->procPtr->bodyPtr;
|
} else {
|
} else {
|
objPtr = Tcl_NewStringObj("", -1);
|
objPtr = Tcl_NewStringObj("", -1);
|
}
|
}
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If the result list has a single element, then
|
* If the result list has a single element, then
|
* return it using Tcl_SetResult() so that it will
|
* return it using Tcl_SetResult() so that it will
|
* look like a string and not a list with one element.
|
* look like a string and not a list with one element.
|
*/
|
*/
|
if (valc == 1) {
|
if (valc == 1) {
|
objPtr = valv[0];
|
objPtr = valv[0];
|
} else {
|
} else {
|
objPtr = Tcl_NewListObj(valc, valv);
|
objPtr = Tcl_NewListObj(valc, valv);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
for (i=0; i < valc; i++) {
|
for (i=0; i < valc; i++) {
|
Tcl_DecrRefCount(valv[i]);
|
Tcl_DecrRefCount(valv[i]);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of public variables.
|
* Return the list of public variables.
|
*/
|
*/
|
else {
|
else {
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
member = vdefn->member;
|
member = vdefn->member;
|
|
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
member->protection == ITCL_PUBLIC) {
|
member->protection == ITCL_PUBLIC) {
|
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldBiInfoProtectedsCmd()
|
* ItclOldBiInfoProtectedsCmd()
|
*
|
*
|
* Sets the interpreter result to contain information for protected
|
* Sets the interpreter result to contain information for protected
|
* variables in the class. Handles the following syntax:
|
* variables in the class. Handles the following syntax:
|
*
|
*
|
* info protected ?varName? ?-init? ?-value?
|
* info protected ?varName? ?-init? ?-value?
|
*
|
*
|
* If the ?varName? is not specified, then a list of all known public
|
* If the ?varName? is not specified, then a list of all known public
|
* variables is returned. Otherwise, the information (init/value)
|
* variables is returned. Otherwise, the information (init/value)
|
* for a specific variable is returned. Returns a status
|
* for a specific variable is returned. Returns a status
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiInfoProtectedsCmd(dummy, interp, objc, objv)
|
ItclOldBiInfoProtectedsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
char *varName = NULL;
|
char *varName = NULL;
|
int varInit = 0;
|
int varInit = 0;
|
int varValue = 0;
|
int varValue = 0;
|
|
|
char *token, *val;
|
char *token, *val;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclMember *member;
|
ItclMember *member;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args: ?varName? ?-init? ?-value?
|
* Process args: ?varName? ?-init? ?-value?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
for ( ; objc > 0; objc--, objv++) {
|
for ( ; objc > 0; objc--, objv++) {
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (strcmp(token, "-init") == 0)
|
if (strcmp(token, "-init") == 0)
|
varInit = ~0;
|
varInit = ~0;
|
else if (strcmp(token, "-value") == 0)
|
else if (strcmp(token, "-value") == 0)
|
varValue = ~0;
|
varValue = ~0;
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", token, "\": should be -init or -value",
|
"bad option \"", token, "\": should be -init or -value",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific variable.
|
* Return info for a specific variable.
|
*/
|
*/
|
if (varName) {
|
if (varName) {
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
vlookup = NULL;
|
vlookup = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (vlookup) {
|
if (vlookup) {
|
int i, valc = 0;
|
int i, valc = 0;
|
Tcl_Obj *valv[5];
|
Tcl_Obj *valv[5];
|
|
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
|
|
if (!varInit && !varValue) {
|
if (!varInit && !varValue) {
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
varInit = varValue = ~0;
|
varInit = varValue = ~0;
|
}
|
}
|
|
|
/*
|
/*
|
* If this is the built-in "this" variable, then
|
* If this is the built-in "this" variable, then
|
* report the object name as its initialization string.
|
* report the object name as its initialization string.
|
*/
|
*/
|
if (varInit) {
|
if (varInit) {
|
if ((member->flags & ITCL_THIS_VAR) != 0) {
|
if ((member->flags & ITCL_THIS_VAR) != 0) {
|
if (contextObj && contextObj->accessCmd) {
|
if (contextObj && contextObj->accessCmd) {
|
objPtr = Tcl_NewStringObj("", -1);
|
objPtr = Tcl_NewStringObj("", -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
contextObj->accessCmd, objPtr);
|
contextObj->accessCmd, objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
else {
|
else {
|
objPtr = Tcl_NewStringObj("<objectName>", -1);
|
objPtr = Tcl_NewStringObj("<objectName>", -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
}
|
}
|
else {
|
else {
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
}
|
}
|
|
|
if (varValue) {
|
if (varValue) {
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
contextObj, contextObj->classDefn);
|
contextObj, contextObj->classDefn);
|
|
|
if (!val) {
|
if (!val) {
|
val = "<undefined>";
|
val = "<undefined>";
|
}
|
}
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If the result list has a single element, then
|
* If the result list has a single element, then
|
* return it using Tcl_SetResult() so that it will
|
* return it using Tcl_SetResult() so that it will
|
* look like a string and not a list with one element.
|
* look like a string and not a list with one element.
|
*/
|
*/
|
if (valc == 1) {
|
if (valc == 1) {
|
objPtr = valv[0];
|
objPtr = valv[0];
|
} else {
|
} else {
|
objPtr = Tcl_NewListObj(valc, valv);
|
objPtr = Tcl_NewListObj(valc, valv);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
for (i=0; i < valc; i++) {
|
for (i=0; i < valc; i++) {
|
Tcl_DecrRefCount(valv[i]);
|
Tcl_DecrRefCount(valv[i]);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of public variables.
|
* Return the list of public variables.
|
*/
|
*/
|
else {
|
else {
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
member = vdefn->member;
|
member = vdefn->member;
|
|
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
member->protection == ITCL_PROTECTED) {
|
member->protection == ITCL_PROTECTED) {
|
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|
/*
|
/*
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
* ItclOldBiInfoCommonsCmd()
|
* ItclOldBiInfoCommonsCmd()
|
*
|
*
|
* Sets the interpreter result to contain information for common
|
* Sets the interpreter result to contain information for common
|
* variables in the class. Handles the following syntax:
|
* variables in the class. Handles the following syntax:
|
*
|
*
|
* info common ?varName? ?-init? ?-value?
|
* info common ?varName? ?-init? ?-value?
|
*
|
*
|
* If the ?varName? is not specified, then a list of all known common
|
* If the ?varName? is not specified, then a list of all known common
|
* variables is returned. Otherwise, the information (init/value)
|
* variables is returned. Otherwise, the information (init/value)
|
* for a specific variable is returned. Returns a status
|
* for a specific variable is returned. Returns a status
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
* ------------------------------------------------------------------------
|
* ------------------------------------------------------------------------
|
*/
|
*/
|
/* ARGSUSED */
|
/* ARGSUSED */
|
static int
|
static int
|
ItclOldBiInfoCommonsCmd(dummy, interp, objc, objv)
|
ItclOldBiInfoCommonsCmd(dummy, interp, objc, objv)
|
ClientData dummy; /* not used */
|
ClientData dummy; /* not used */
|
Tcl_Interp *interp; /* current interpreter */
|
Tcl_Interp *interp; /* current interpreter */
|
int objc; /* number of arguments */
|
int objc; /* number of arguments */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
{
|
{
|
char *varName = NULL;
|
char *varName = NULL;
|
int varInit = 0;
|
int varInit = 0;
|
int varValue = 0;
|
int varValue = 0;
|
|
|
char *token, *val;
|
char *token, *val;
|
ItclClass *contextClass;
|
ItclClass *contextClass;
|
ItclObject *contextObj;
|
ItclObject *contextObj;
|
|
|
ItclClass *cdPtr;
|
ItclClass *cdPtr;
|
ItclVarDefn *vdefn;
|
ItclVarDefn *vdefn;
|
ItclVarLookup *vlookup;
|
ItclVarLookup *vlookup;
|
ItclMember *member;
|
ItclMember *member;
|
ItclHierIter hier;
|
ItclHierIter hier;
|
Tcl_HashEntry *entry;
|
Tcl_HashEntry *entry;
|
Tcl_HashSearch place;
|
Tcl_HashSearch place;
|
Tcl_Obj *objPtr, *listPtr;
|
Tcl_Obj *objPtr, *listPtr;
|
|
|
/*
|
/*
|
* If this command is not invoked within a class namespace,
|
* If this command is not invoked within a class namespace,
|
* signal an error.
|
* signal an error.
|
*/
|
*/
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
|
|
/*
|
/*
|
* Process args: ?varName? ?-init? ?-value?
|
* Process args: ?varName? ?-init? ?-value?
|
*/
|
*/
|
objv++; /* skip over command name */
|
objv++; /* skip over command name */
|
objc--;
|
objc--;
|
|
|
if (objc > 0) {
|
if (objc > 0) {
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
objc--; objv++;
|
objc--; objv++;
|
}
|
}
|
for ( ; objc > 0; objc--, objv++) {
|
for ( ; objc > 0; objc--, objv++) {
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
if (strcmp(token, "-init") == 0)
|
if (strcmp(token, "-init") == 0)
|
varInit = ~0;
|
varInit = ~0;
|
else if (strcmp(token, "-value") == 0)
|
else if (strcmp(token, "-value") == 0)
|
varValue = ~0;
|
varValue = ~0;
|
else {
|
else {
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
"bad option \"", token, "\": should be -init or -value",
|
"bad option \"", token, "\": should be -init or -value",
|
(char*)NULL);
|
(char*)NULL);
|
return TCL_ERROR;
|
return TCL_ERROR;
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return info for a specific variable.
|
* Return info for a specific variable.
|
*/
|
*/
|
if (varName) {
|
if (varName) {
|
vlookup = NULL;
|
vlookup = NULL;
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
if (entry) {
|
if (entry) {
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
vlookup = NULL;
|
vlookup = NULL;
|
}
|
}
|
}
|
}
|
|
|
if (vlookup) {
|
if (vlookup) {
|
int i, valc = 0;
|
int i, valc = 0;
|
Tcl_Obj *valv[5];
|
Tcl_Obj *valv[5];
|
|
|
member = vlookup->vdefn->member;
|
member = vlookup->vdefn->member;
|
|
|
if (!varInit && !varValue) {
|
if (!varInit && !varValue) {
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
varInit = varValue = ~0;
|
varInit = varValue = ~0;
|
}
|
}
|
if (varInit) {
|
if (varInit) {
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
if (varValue) {
|
if (varValue) {
|
val = Itcl_GetCommonVar(interp, member->fullname,
|
val = Itcl_GetCommonVar(interp, member->fullname,
|
contextObj->classDefn);
|
contextObj->classDefn);
|
|
|
if (!val) {
|
if (!val) {
|
val = "<undefined>";
|
val = "<undefined>";
|
}
|
}
|
objPtr = Tcl_NewStringObj(val, -1);
|
objPtr = Tcl_NewStringObj(val, -1);
|
Tcl_IncrRefCount(objPtr);
|
Tcl_IncrRefCount(objPtr);
|
valv[valc++] = objPtr;
|
valv[valc++] = objPtr;
|
}
|
}
|
|
|
/*
|
/*
|
* If the result list has a single element, then
|
* If the result list has a single element, then
|
* return it using Tcl_SetResult() so that it will
|
* return it using Tcl_SetResult() so that it will
|
* look like a string and not a list with one element.
|
* look like a string and not a list with one element.
|
*/
|
*/
|
if (valc == 1) {
|
if (valc == 1) {
|
objPtr = valv[0];
|
objPtr = valv[0];
|
} else {
|
} else {
|
objPtr = Tcl_NewListObj(valc, valv);
|
objPtr = Tcl_NewListObj(valc, valv);
|
}
|
}
|
Tcl_SetObjResult(interp, objPtr);
|
Tcl_SetObjResult(interp, objPtr);
|
|
|
for (i=0; i < valc; i++) {
|
for (i=0; i < valc; i++) {
|
Tcl_DecrRefCount(valv[i]);
|
Tcl_DecrRefCount(valv[i]);
|
}
|
}
|
}
|
}
|
}
|
}
|
|
|
/*
|
/*
|
* Return the list of public variables.
|
* Return the list of public variables.
|
*/
|
*/
|
else {
|
else {
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
|
|
Itcl_InitHierIter(&hier, contextClass);
|
Itcl_InitHierIter(&hier, contextClass);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
while (cdPtr != NULL) {
|
while (cdPtr != NULL) {
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
while (entry) {
|
while (entry) {
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
member = vdefn->member;
|
member = vdefn->member;
|
|
|
if ((member->flags & ITCL_COMMON) &&
|
if ((member->flags & ITCL_COMMON) &&
|
member->protection == ITCL_PROTECTED) {
|
member->protection == ITCL_PROTECTED) {
|
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, "::", -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
objPtr);
|
objPtr);
|
}
|
}
|
entry = Tcl_NextHashEntry(&place);
|
entry = Tcl_NextHashEntry(&place);
|
}
|
}
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
}
|
}
|
Itcl_DeleteHierIter(&hier);
|
Itcl_DeleteHierIter(&hier);
|
|
|
Tcl_SetObjResult(interp, listPtr);
|
Tcl_SetObjResult(interp, listPtr);
|
}
|
}
|
return TCL_OK;
|
return TCL_OK;
|
}
|
}
|
|
|