1 |
578 |
markom |
/*
|
2 |
|
|
* ------------------------------------------------------------------------
|
3 |
|
|
* PACKAGE: [incr Tcl]
|
4 |
|
|
* DESCRIPTION: Object-Oriented Extensions to Tcl
|
5 |
|
|
*
|
6 |
|
|
* [incr Tcl] provides object-oriented extensions to Tcl, much as
|
7 |
|
|
* C++ provides object-oriented extensions to C. It provides a means
|
8 |
|
|
* of encapsulating related procedures together with their shared data
|
9 |
|
|
* in a local namespace that is hidden from the outside world. It
|
10 |
|
|
* promotes code re-use through inheritance. More than anything else,
|
11 |
|
|
* it encourages better organization of Tcl applications through the
|
12 |
|
|
* object-oriented paradigm, leading to code that is easier to
|
13 |
|
|
* understand and maintain.
|
14 |
|
|
*
|
15 |
|
|
* Procedures in this file support the old-style syntax for [incr Tcl]
|
16 |
|
|
* class definitions:
|
17 |
|
|
*
|
18 |
|
|
* itcl_class <className> {
|
19 |
|
|
* inherit <base-class>...
|
20 |
|
|
*
|
21 |
|
|
* constructor {<arglist>} { <body> }
|
22 |
|
|
* destructor { <body> }
|
23 |
|
|
*
|
24 |
|
|
* method <name> {<arglist>} { <body> }
|
25 |
|
|
* proc <name> {<arglist>} { <body> }
|
26 |
|
|
*
|
27 |
|
|
* public <varname> ?<init>? ?<config>?
|
28 |
|
|
* protected <varname> ?<init>?
|
29 |
|
|
* common <varname> ?<init>?
|
30 |
|
|
* }
|
31 |
|
|
*
|
32 |
|
|
* This capability will be removed in a future release, after users
|
33 |
|
|
* have had a chance to switch over to the new syntax.
|
34 |
|
|
*
|
35 |
|
|
* ========================================================================
|
36 |
|
|
* AUTHOR: Michael J. McLennan
|
37 |
|
|
* Bell Labs Innovations for Lucent Technologies
|
38 |
|
|
* mmclennan@lucent.com
|
39 |
|
|
* http://www.tcltk.com/itcl
|
40 |
|
|
*
|
41 |
|
|
* RCS: $Id: itcl_obsolete.c,v 1.1.1.1 2002-01-16 10:24:46 markom Exp $
|
42 |
|
|
* ========================================================================
|
43 |
|
|
* Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
44 |
|
|
* ------------------------------------------------------------------------
|
45 |
|
|
* See the file "license.terms" for information on usage and redistribution
|
46 |
|
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
47 |
|
|
*/
|
48 |
|
|
#include "itclInt.h"
|
49 |
|
|
|
50 |
|
|
/*
|
51 |
|
|
* FORWARD DECLARATIONS
|
52 |
|
|
*/
|
53 |
|
|
static int ItclOldClassCmd _ANSI_ARGS_((ClientData cdata,
|
54 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
55 |
|
|
|
56 |
|
|
static int ItclOldMethodCmd _ANSI_ARGS_((ClientData cdata,
|
57 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
58 |
|
|
static int ItclOldPublicCmd _ANSI_ARGS_((ClientData cdata,
|
59 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
60 |
|
|
static int ItclOldProtectedCmd _ANSI_ARGS_((ClientData cdata,
|
61 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
62 |
|
|
static int ItclOldCommonCmd _ANSI_ARGS_((ClientData cdata,
|
63 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
64 |
|
|
|
65 |
|
|
static int ItclOldBiDeleteCmd _ANSI_ARGS_((ClientData cdata,
|
66 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
67 |
|
|
static int ItclOldBiVirtualCmd _ANSI_ARGS_((ClientData cdata,
|
68 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
69 |
|
|
static int ItclOldBiPreviousCmd _ANSI_ARGS_((ClientData cdata,
|
70 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
71 |
|
|
|
72 |
|
|
static int ItclOldBiInfoMethodsCmd _ANSI_ARGS_((ClientData cdata,
|
73 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
74 |
|
|
static int ItclOldBiInfoProcsCmd _ANSI_ARGS_((ClientData cdata,
|
75 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
76 |
|
|
static int ItclOldBiInfoPublicsCmd _ANSI_ARGS_((ClientData cdata,
|
77 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
78 |
|
|
static int ItclOldBiInfoProtectedsCmd _ANSI_ARGS_((ClientData cdata,
|
79 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
80 |
|
|
static int ItclOldBiInfoCommonsCmd _ANSI_ARGS_((ClientData cdata,
|
81 |
|
|
Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));
|
82 |
|
|
|
83 |
|
|
|
84 |
|
|
/*
|
85 |
|
|
* Standard list of built-in methods for old-style objects.
|
86 |
|
|
*/
|
87 |
|
|
typedef struct BiMethod {
|
88 |
|
|
char* name; /* method name */
|
89 |
|
|
char* usage; /* string describing usage */
|
90 |
|
|
char* registration; /* registration name for C proc */
|
91 |
|
|
Tcl_ObjCmdProc *proc; /* implementation C proc */
|
92 |
|
|
} BiMethod;
|
93 |
|
|
|
94 |
|
|
static BiMethod BiMethodList[] = {
|
95 |
|
|
{ "cget", "-option",
|
96 |
|
|
"@itcl-oldstyle-cget", Itcl_BiCgetCmd },
|
97 |
|
|
{ "configure", "?-option? ?value -option value...?",
|
98 |
|
|
"@itcl-oldstyle-configure", Itcl_BiConfigureCmd },
|
99 |
|
|
{ "delete", "",
|
100 |
|
|
"@itcl-oldstyle-delete", ItclOldBiDeleteCmd },
|
101 |
|
|
{ "isa", "className",
|
102 |
|
|
"@itcl-oldstyle-isa", Itcl_BiIsaCmd },
|
103 |
|
|
};
|
104 |
|
|
static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod);
|
105 |
|
|
|
106 |
|
|
|
107 |
|
|
/*
|
108 |
|
|
* ------------------------------------------------------------------------
|
109 |
|
|
* Itcl_OldInit()
|
110 |
|
|
*
|
111 |
|
|
* Invoked by Itcl_Init() whenever a new interpeter is created to add
|
112 |
|
|
* [incr Tcl] facilities. Adds the commands needed for backward
|
113 |
|
|
* compatibility with previous releases of [incr Tcl].
|
114 |
|
|
* ------------------------------------------------------------------------
|
115 |
|
|
*/
|
116 |
|
|
int
|
117 |
|
|
Itcl_OldInit(interp,info)
|
118 |
|
|
Tcl_Interp *interp; /* interpreter to be updated */
|
119 |
|
|
ItclObjectInfo *info; /* info regarding all known objects */
|
120 |
|
|
{
|
121 |
|
|
int i;
|
122 |
|
|
Tcl_Namespace *parserNs, *oldBiNs;
|
123 |
|
|
|
124 |
|
|
/*
|
125 |
|
|
* Declare all of the old-style built-in methods as C procedures.
|
126 |
|
|
*/
|
127 |
|
|
for (i=0; i < BiMethodListLen; i++) {
|
128 |
|
|
if (Itcl_RegisterObjC(interp,
|
129 |
|
|
BiMethodList[i].registration+1, BiMethodList[i].proc,
|
130 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {
|
131 |
|
|
|
132 |
|
|
return TCL_ERROR;
|
133 |
|
|
}
|
134 |
|
|
}
|
135 |
|
|
|
136 |
|
|
/*
|
137 |
|
|
* Create the "itcl::old-parser" namespace for backward
|
138 |
|
|
* compatibility, to handle the old-style class definitions.
|
139 |
|
|
*/
|
140 |
|
|
parserNs = Tcl_CreateNamespace(interp, "::itcl::old-parser",
|
141 |
|
|
(ClientData)info, Itcl_ReleaseData);
|
142 |
|
|
|
143 |
|
|
if (!parserNs) {
|
144 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
145 |
|
|
" (cannot initialize itcl old-style parser)",
|
146 |
|
|
(char*)NULL);
|
147 |
|
|
return TCL_ERROR;
|
148 |
|
|
}
|
149 |
|
|
Itcl_PreserveData((ClientData)info);
|
150 |
|
|
|
151 |
|
|
/*
|
152 |
|
|
* Add commands for parsing old-style class definitions.
|
153 |
|
|
*/
|
154 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::inherit",
|
155 |
|
|
Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
156 |
|
|
|
157 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::constructor",
|
158 |
|
|
Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
159 |
|
|
|
160 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::destructor",
|
161 |
|
|
Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
162 |
|
|
|
163 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::method",
|
164 |
|
|
ItclOldMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
165 |
|
|
|
166 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::proc",
|
167 |
|
|
Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
168 |
|
|
|
169 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::public",
|
170 |
|
|
ItclOldPublicCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
171 |
|
|
|
172 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::protected",
|
173 |
|
|
ItclOldProtectedCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
174 |
|
|
|
175 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-parser::common",
|
176 |
|
|
ItclOldCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL);
|
177 |
|
|
|
178 |
|
|
/*
|
179 |
|
|
* Set the runtime variable resolver for the parser namespace,
|
180 |
|
|
* to control access to "common" data members while parsing
|
181 |
|
|
* the class definition.
|
182 |
|
|
*/
|
183 |
|
|
Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL,
|
184 |
|
|
Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL);
|
185 |
|
|
|
186 |
|
|
/*
|
187 |
|
|
* Create the "itcl::old-builtin" namespace for backward
|
188 |
|
|
* compatibility with the old-style built-in commands.
|
189 |
|
|
*/
|
190 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::virtual",
|
191 |
|
|
ItclOldBiVirtualCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
192 |
|
|
|
193 |
|
|
Tcl_CreateObjCommand(interp, "::itcl::old-builtin::previous",
|
194 |
|
|
ItclOldBiPreviousCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
|
195 |
|
|
|
196 |
|
|
if (Itcl_CreateEnsemble(interp, "::itcl::old-builtin::info") != TCL_OK) {
|
197 |
|
|
return TCL_ERROR;
|
198 |
|
|
}
|
199 |
|
|
|
200 |
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
201 |
|
|
"class", "", Itcl_BiInfoClassCmd,
|
202 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
203 |
|
|
!= TCL_OK ||
|
204 |
|
|
|
205 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
206 |
|
|
"inherit", "", Itcl_BiInfoInheritCmd,
|
207 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
208 |
|
|
!= TCL_OK ||
|
209 |
|
|
|
210 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
211 |
|
|
"heritage", "", Itcl_BiInfoHeritageCmd,
|
212 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
213 |
|
|
!= TCL_OK ||
|
214 |
|
|
|
215 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
216 |
|
|
"method", "?methodName? ?-args? ?-body?",
|
217 |
|
|
ItclOldBiInfoMethodsCmd,
|
218 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
219 |
|
|
!= TCL_OK ||
|
220 |
|
|
|
221 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
222 |
|
|
"proc", "?procName? ?-args? ?-body?",
|
223 |
|
|
ItclOldBiInfoProcsCmd,
|
224 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
225 |
|
|
!= TCL_OK ||
|
226 |
|
|
|
227 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
228 |
|
|
"public", "?varName? ?-init? ?-value? ?-config?",
|
229 |
|
|
ItclOldBiInfoPublicsCmd,
|
230 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
231 |
|
|
!= TCL_OK ||
|
232 |
|
|
|
233 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
234 |
|
|
"protected", "?varName? ?-init? ?-value?",
|
235 |
|
|
ItclOldBiInfoProtectedsCmd,
|
236 |
|
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
237 |
|
|
!= TCL_OK ||
|
238 |
|
|
|
239 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
240 |
|
|
"common", "?varName? ?-init? ?-value?",
|
241 |
|
|
ItclOldBiInfoCommonsCmd,
|
242 |
|
|
(ClientData)NULL,(Tcl_CmdDeleteProc*)NULL)
|
243 |
|
|
!= TCL_OK ||
|
244 |
|
|
|
245 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
246 |
|
|
"args", "procname", Itcl_BiInfoArgsCmd,
|
247 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
248 |
|
|
!= TCL_OK ||
|
249 |
|
|
|
250 |
|
|
Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
251 |
|
|
"body", "procname", Itcl_BiInfoBodyCmd,
|
252 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
253 |
|
|
!= TCL_OK
|
254 |
|
|
) {
|
255 |
|
|
return TCL_ERROR;
|
256 |
|
|
}
|
257 |
|
|
|
258 |
|
|
/*
|
259 |
|
|
* Plug in an "@error" handler to handle other options from
|
260 |
|
|
* the usual info command.
|
261 |
|
|
*/
|
262 |
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info",
|
263 |
|
|
"@error", (char*)NULL, Itcl_DefaultInfoCmd,
|
264 |
|
|
(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL)
|
265 |
|
|
!= TCL_OK
|
266 |
|
|
) {
|
267 |
|
|
return TCL_ERROR;
|
268 |
|
|
}
|
269 |
|
|
|
270 |
|
|
oldBiNs = Tcl_FindNamespace(interp, "::itcl::old-builtin",
|
271 |
|
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
272 |
|
|
|
273 |
|
|
if (!oldBiNs ||
|
274 |
|
|
Tcl_Export(interp, oldBiNs, "*", /* resetListFirst */ 1) != TCL_OK) {
|
275 |
|
|
return TCL_ERROR;
|
276 |
|
|
}
|
277 |
|
|
|
278 |
|
|
/*
|
279 |
|
|
* Install the "itcl_class" and "itcl_info" commands into
|
280 |
|
|
* the global scope. This supports the old syntax for
|
281 |
|
|
* backward compatibility.
|
282 |
|
|
*/
|
283 |
|
|
Tcl_CreateObjCommand(interp, "::itcl_class", ItclOldClassCmd,
|
284 |
|
|
(ClientData)info, Itcl_ReleaseData);
|
285 |
|
|
Itcl_PreserveData((ClientData)info);
|
286 |
|
|
|
287 |
|
|
|
288 |
|
|
if (Itcl_CreateEnsemble(interp, "::itcl_info") != TCL_OK) {
|
289 |
|
|
return TCL_ERROR;
|
290 |
|
|
}
|
291 |
|
|
|
292 |
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
293 |
|
|
"classes", "?pattern?",
|
294 |
|
|
Itcl_FindClassesCmd, (ClientData)info, Itcl_ReleaseData)
|
295 |
|
|
!= TCL_OK) {
|
296 |
|
|
return TCL_ERROR;
|
297 |
|
|
}
|
298 |
|
|
Itcl_PreserveData((ClientData)info);
|
299 |
|
|
|
300 |
|
|
if (Itcl_AddEnsemblePart(interp, "::itcl_info",
|
301 |
|
|
"objects", "?-class className? ?-isa className? ?pattern?",
|
302 |
|
|
Itcl_FindObjectsCmd, (ClientData)info, Itcl_ReleaseData)
|
303 |
|
|
!= TCL_OK) {
|
304 |
|
|
return TCL_ERROR;
|
305 |
|
|
}
|
306 |
|
|
Itcl_PreserveData((ClientData)info);
|
307 |
|
|
|
308 |
|
|
return TCL_OK;
|
309 |
|
|
}
|
310 |
|
|
|
311 |
|
|
|
312 |
|
|
/*
|
313 |
|
|
* ------------------------------------------------------------------------
|
314 |
|
|
* Itcl_InstallOldBiMethods()
|
315 |
|
|
*
|
316 |
|
|
* Invoked when a class is first created, just after the class
|
317 |
|
|
* definition has been parsed, to add definitions for built-in
|
318 |
|
|
* methods to the class. If a method already exists in the class
|
319 |
|
|
* with the same name as the built-in, then the built-in is skipped.
|
320 |
|
|
* Otherwise, a method definition for the built-in method is added.
|
321 |
|
|
*
|
322 |
|
|
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
|
323 |
|
|
* message in the interpreter) if anything goes wrong.
|
324 |
|
|
* ------------------------------------------------------------------------
|
325 |
|
|
*/
|
326 |
|
|
int
|
327 |
|
|
Itcl_InstallOldBiMethods(interp, cdefn)
|
328 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
329 |
|
|
ItclClass *cdefn; /* class definition to be updated */
|
330 |
|
|
{
|
331 |
|
|
int result = TCL_OK;
|
332 |
|
|
|
333 |
|
|
int i;
|
334 |
|
|
ItclHierIter hier;
|
335 |
|
|
ItclClass *cdPtr;
|
336 |
|
|
Tcl_HashEntry *entry;
|
337 |
|
|
|
338 |
|
|
/*
|
339 |
|
|
* Scan through all of the built-in methods and see if
|
340 |
|
|
* that method already exists in the class. If not, add
|
341 |
|
|
* it in.
|
342 |
|
|
*
|
343 |
|
|
* TRICKY NOTE: The virtual tables haven't been built yet,
|
344 |
|
|
* so look for existing methods the hard way--by scanning
|
345 |
|
|
* through all classes.
|
346 |
|
|
*/
|
347 |
|
|
for (i=0; i < BiMethodListLen; i++) {
|
348 |
|
|
Itcl_InitHierIter(&hier, cdefn);
|
349 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
350 |
|
|
|
351 |
|
|
entry = NULL;
|
352 |
|
|
while (cdPtr) {
|
353 |
|
|
entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name);
|
354 |
|
|
if (entry) {
|
355 |
|
|
break;
|
356 |
|
|
}
|
357 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
358 |
|
|
}
|
359 |
|
|
Itcl_DeleteHierIter(&hier);
|
360 |
|
|
|
361 |
|
|
if (!entry) {
|
362 |
|
|
result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name,
|
363 |
|
|
BiMethodList[i].usage, BiMethodList[i].registration);
|
364 |
|
|
|
365 |
|
|
if (result != TCL_OK) {
|
366 |
|
|
break;
|
367 |
|
|
}
|
368 |
|
|
}
|
369 |
|
|
}
|
370 |
|
|
return result;
|
371 |
|
|
}
|
372 |
|
|
|
373 |
|
|
|
374 |
|
|
/*
|
375 |
|
|
* ------------------------------------------------------------------------
|
376 |
|
|
* ItclOldClassCmd()
|
377 |
|
|
*
|
378 |
|
|
* Invoked by Tcl whenever the user issues a "itcl_class" command to
|
379 |
|
|
* specify a class definition. Handles the following syntax:
|
380 |
|
|
*
|
381 |
|
|
* itcl_class <className> {
|
382 |
|
|
* inherit <base-class>...
|
383 |
|
|
*
|
384 |
|
|
* constructor {<arglist>} { <body> }
|
385 |
|
|
* destructor { <body> }
|
386 |
|
|
*
|
387 |
|
|
* method <name> {<arglist>} { <body> }
|
388 |
|
|
* proc <name> {<arglist>} { <body> }
|
389 |
|
|
*
|
390 |
|
|
* public <varname> ?<init>? ?<config>?
|
391 |
|
|
* protected <varname> ?<init>?
|
392 |
|
|
* common <varname> ?<init>?
|
393 |
|
|
* }
|
394 |
|
|
*
|
395 |
|
|
* NOTE: This command is will only be provided for a limited time,
|
396 |
|
|
* to support backward compatibility with the old-style
|
397 |
|
|
* [incr Tcl] syntax. Users should convert their scripts
|
398 |
|
|
* to use the newer syntax (Itcl_ClassCmd()) as soon as possible.
|
399 |
|
|
*
|
400 |
|
|
* ------------------------------------------------------------------------
|
401 |
|
|
*/
|
402 |
|
|
static int
|
403 |
|
|
ItclOldClassCmd(clientData, interp, objc, objv)
|
404 |
|
|
ClientData clientData; /* info for all known objects */
|
405 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
406 |
|
|
int objc; /* number of arguments */
|
407 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
408 |
|
|
{
|
409 |
|
|
ItclObjectInfo* info = (ItclObjectInfo*)clientData;
|
410 |
|
|
|
411 |
|
|
int result;
|
412 |
|
|
char *className;
|
413 |
|
|
Tcl_Namespace *parserNs;
|
414 |
|
|
ItclClass *cdefnPtr;
|
415 |
|
|
Tcl_HashEntry* entry;
|
416 |
|
|
ItclMemberFunc *mfunc;
|
417 |
|
|
Tcl_CallFrame frame;
|
418 |
|
|
|
419 |
|
|
if (objc != 3) {
|
420 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "name { definition }");
|
421 |
|
|
return TCL_ERROR;
|
422 |
|
|
}
|
423 |
|
|
className = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
424 |
|
|
|
425 |
|
|
/*
|
426 |
|
|
* Find the namespace to use as a parser for the class definition.
|
427 |
|
|
* If for some reason it is destroyed, bail out here.
|
428 |
|
|
*/
|
429 |
|
|
parserNs = Tcl_FindNamespace(interp, "::itcl::old-parser",
|
430 |
|
|
(Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG);
|
431 |
|
|
|
432 |
|
|
if (parserNs == NULL) {
|
433 |
|
|
char msg[256];
|
434 |
|
|
sprintf(msg, "\n (while parsing class definition for \"%.100s\")",
|
435 |
|
|
className);
|
436 |
|
|
Tcl_AddErrorInfo(interp, msg);
|
437 |
|
|
return TCL_ERROR;
|
438 |
|
|
}
|
439 |
|
|
|
440 |
|
|
/*
|
441 |
|
|
* Try to create the specified class and its namespace.
|
442 |
|
|
*/
|
443 |
|
|
if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) {
|
444 |
|
|
return TCL_ERROR;
|
445 |
|
|
}
|
446 |
|
|
cdefnPtr->flags |= ITCL_OLD_STYLE;
|
447 |
|
|
|
448 |
|
|
/*
|
449 |
|
|
* Import the built-in commands from the itcl::old-builtin
|
450 |
|
|
* and itcl::builtin namespaces. Do this before parsing the
|
451 |
|
|
* class definition, so methods/procs can override the built-in
|
452 |
|
|
* commands.
|
453 |
|
|
*/
|
454 |
|
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::builtin::*",
|
455 |
|
|
/* allowOverwrite */ 1);
|
456 |
|
|
|
457 |
|
|
if (result == TCL_OK) {
|
458 |
|
|
result = Tcl_Import(interp, cdefnPtr->namesp, "::itcl::old-builtin::*",
|
459 |
|
|
/* allowOverwrite */ 1);
|
460 |
|
|
}
|
461 |
|
|
|
462 |
|
|
if (result != TCL_OK) {
|
463 |
|
|
char msg[256];
|
464 |
|
|
sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className);
|
465 |
|
|
Tcl_AddErrorInfo(interp, msg);
|
466 |
|
|
|
467 |
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
468 |
|
|
return TCL_ERROR;
|
469 |
|
|
}
|
470 |
|
|
|
471 |
|
|
/*
|
472 |
|
|
* Push this class onto the class definition stack so that it
|
473 |
|
|
* becomes the current context for all commands in the parser.
|
474 |
|
|
* Activate the parser and evaluate the class definition.
|
475 |
|
|
*/
|
476 |
|
|
Itcl_PushStack((ClientData)cdefnPtr, &info->cdefnStack);
|
477 |
|
|
|
478 |
|
|
result = Tcl_PushCallFrame(interp, &frame, parserNs,
|
479 |
|
|
/* isProcCallFrame */ 0);
|
480 |
|
|
|
481 |
|
|
if (result == TCL_OK) {
|
482 |
|
|
/* CYGNUS LOCAL - Fix for Tcl8.1 */
|
483 |
|
|
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
|
484 |
|
|
result = Tcl_EvalObj(interp, objv[2]);
|
485 |
|
|
#else
|
486 |
|
|
result = Tcl_EvalObj(interp, objv[2], 0);
|
487 |
|
|
#endif
|
488 |
|
|
/* END CYGNUS LOCAL */
|
489 |
|
|
Tcl_PopCallFrame(interp);
|
490 |
|
|
}
|
491 |
|
|
Itcl_PopStack(&info->cdefnStack);
|
492 |
|
|
|
493 |
|
|
if (result != TCL_OK) {
|
494 |
|
|
char msg[256];
|
495 |
|
|
sprintf(msg, "\n (class \"%.200s\" body line %d)",
|
496 |
|
|
className, interp->errorLine);
|
497 |
|
|
Tcl_AddErrorInfo(interp, msg);
|
498 |
|
|
|
499 |
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
500 |
|
|
return TCL_ERROR;
|
501 |
|
|
}
|
502 |
|
|
|
503 |
|
|
/*
|
504 |
|
|
* At this point, parsing of the class definition has succeeded.
|
505 |
|
|
* Add built-in methods such as "configure" and "cget"--as long
|
506 |
|
|
* as they don't conflict with those defined in the class.
|
507 |
|
|
*/
|
508 |
|
|
if (Itcl_InstallOldBiMethods(interp, cdefnPtr) != TCL_OK) {
|
509 |
|
|
Tcl_DeleteNamespace(cdefnPtr->namesp);
|
510 |
|
|
return TCL_ERROR;
|
511 |
|
|
}
|
512 |
|
|
|
513 |
|
|
/*
|
514 |
|
|
* See if this class has a "constructor", and if it does, mark
|
515 |
|
|
* it as "old-style". This will allow the "config" argument
|
516 |
|
|
* to work.
|
517 |
|
|
*/
|
518 |
|
|
entry = Tcl_FindHashEntry(&cdefnPtr->functions, "constructor");
|
519 |
|
|
if (entry) {
|
520 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
521 |
|
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
522 |
|
|
}
|
523 |
|
|
|
524 |
|
|
/*
|
525 |
|
|
* Build the virtual tables for this class.
|
526 |
|
|
*/
|
527 |
|
|
Itcl_BuildVirtualTables(cdefnPtr);
|
528 |
|
|
|
529 |
|
|
Tcl_ResetResult(interp);
|
530 |
|
|
return TCL_OK;
|
531 |
|
|
}
|
532 |
|
|
|
533 |
|
|
|
534 |
|
|
/*
|
535 |
|
|
* ------------------------------------------------------------------------
|
536 |
|
|
* ItclOldMethodCmd()
|
537 |
|
|
*
|
538 |
|
|
* Invoked by Tcl during the parsing of a class definition whenever
|
539 |
|
|
* the "method" command is invoked to define an object method.
|
540 |
|
|
* Handles the following syntax:
|
541 |
|
|
*
|
542 |
|
|
* method <name> {<arglist>} {<body>}
|
543 |
|
|
*
|
544 |
|
|
* ------------------------------------------------------------------------
|
545 |
|
|
*/
|
546 |
|
|
static int
|
547 |
|
|
ItclOldMethodCmd(clientData, interp, objc, objv)
|
548 |
|
|
ClientData clientData; /* info for all known objects */
|
549 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
550 |
|
|
int objc; /* number of arguments */
|
551 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
552 |
|
|
{
|
553 |
|
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
554 |
|
|
ItclClass *cdefn = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
555 |
|
|
|
556 |
|
|
char *name, *arglist, *body;
|
557 |
|
|
Tcl_HashEntry *entry;
|
558 |
|
|
ItclMemberFunc *mfunc;
|
559 |
|
|
|
560 |
|
|
if (objc != 4) {
|
561 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "name args body");
|
562 |
|
|
return TCL_ERROR;
|
563 |
|
|
}
|
564 |
|
|
|
565 |
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
566 |
|
|
if (Tcl_FindHashEntry(&cdefn->functions, name)) {
|
567 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
568 |
|
|
"\"", name, "\" already defined in class \"", cdefn->name, "\"",
|
569 |
|
|
(char*)NULL);
|
570 |
|
|
return TCL_ERROR;
|
571 |
|
|
}
|
572 |
|
|
|
573 |
|
|
arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
574 |
|
|
body = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
575 |
|
|
|
576 |
|
|
if (Itcl_CreateMethod(interp, cdefn, name, arglist, body) != TCL_OK) {
|
577 |
|
|
return TCL_ERROR;
|
578 |
|
|
}
|
579 |
|
|
|
580 |
|
|
/*
|
581 |
|
|
* Find the method that was just created and mark it as an
|
582 |
|
|
* "old-style" method, so that the magic "config" argument
|
583 |
|
|
* will be allowed to work. This is done for backward-
|
584 |
|
|
* compatibility with earlier releases. In the latest version,
|
585 |
|
|
* use of the "config" argument is discouraged.
|
586 |
|
|
*/
|
587 |
|
|
entry = Tcl_FindHashEntry(&cdefn->functions, name);
|
588 |
|
|
if (entry) {
|
589 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
590 |
|
|
mfunc->member->flags |= ITCL_OLD_STYLE;
|
591 |
|
|
}
|
592 |
|
|
|
593 |
|
|
return TCL_OK;
|
594 |
|
|
}
|
595 |
|
|
|
596 |
|
|
|
597 |
|
|
/*
|
598 |
|
|
* ------------------------------------------------------------------------
|
599 |
|
|
* ItclOldPublicCmd()
|
600 |
|
|
*
|
601 |
|
|
* Invoked by Tcl during the parsing of a class definition whenever
|
602 |
|
|
* the "public" command is invoked to define a public variable.
|
603 |
|
|
* Handles the following syntax:
|
604 |
|
|
*
|
605 |
|
|
* public <varname> ?<init>? ?<config>?
|
606 |
|
|
*
|
607 |
|
|
* ------------------------------------------------------------------------
|
608 |
|
|
*/
|
609 |
|
|
static int
|
610 |
|
|
ItclOldPublicCmd(clientData, interp, objc, objv)
|
611 |
|
|
ClientData clientData; /* info for all known objects */
|
612 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
613 |
|
|
int objc; /* number of arguments */
|
614 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
615 |
|
|
{
|
616 |
|
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
617 |
|
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
618 |
|
|
|
619 |
|
|
char *name, *init, *config;
|
620 |
|
|
ItclVarDefn *vdefn;
|
621 |
|
|
|
622 |
|
|
if ((objc < 2) || (objc > 4)) {
|
623 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init? ?config?");
|
624 |
|
|
return TCL_ERROR;
|
625 |
|
|
}
|
626 |
|
|
|
627 |
|
|
/*
|
628 |
|
|
* Make sure that the variable name does not contain anything
|
629 |
|
|
* goofy like a "::" scope qualifier.
|
630 |
|
|
*/
|
631 |
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
632 |
|
|
if (strstr(name, "::")) {
|
633 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
634 |
|
|
"bad variable name \"", name, "\"",
|
635 |
|
|
(char*)NULL);
|
636 |
|
|
return TCL_ERROR;
|
637 |
|
|
}
|
638 |
|
|
|
639 |
|
|
init = NULL;
|
640 |
|
|
config = NULL;
|
641 |
|
|
if (objc >= 3) {
|
642 |
|
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
643 |
|
|
}
|
644 |
|
|
if (objc >= 4) {
|
645 |
|
|
config = Tcl_GetStringFromObj(objv[3], (int*)NULL);
|
646 |
|
|
}
|
647 |
|
|
|
648 |
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config,
|
649 |
|
|
&vdefn) != TCL_OK) {
|
650 |
|
|
|
651 |
|
|
return TCL_ERROR;
|
652 |
|
|
}
|
653 |
|
|
|
654 |
|
|
vdefn->member->protection = ITCL_PUBLIC;
|
655 |
|
|
|
656 |
|
|
return TCL_OK;
|
657 |
|
|
}
|
658 |
|
|
|
659 |
|
|
/*
|
660 |
|
|
* ------------------------------------------------------------------------
|
661 |
|
|
* ItclOldProtectedCmd()
|
662 |
|
|
*
|
663 |
|
|
* Invoked by Tcl during the parsing of a class definition whenever
|
664 |
|
|
* the "protected" command is invoked to define a protected variable.
|
665 |
|
|
* Handles the following syntax:
|
666 |
|
|
*
|
667 |
|
|
* protected <varname> ?<init>?
|
668 |
|
|
*
|
669 |
|
|
* ------------------------------------------------------------------------
|
670 |
|
|
*/
|
671 |
|
|
static int
|
672 |
|
|
ItclOldProtectedCmd(clientData, interp, objc, objv)
|
673 |
|
|
ClientData clientData; /* info for all known objects */
|
674 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
675 |
|
|
int objc; /* number of arguments */
|
676 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
677 |
|
|
{
|
678 |
|
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
679 |
|
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
680 |
|
|
|
681 |
|
|
char *name, *init;
|
682 |
|
|
ItclVarDefn *vdefn;
|
683 |
|
|
|
684 |
|
|
if ((objc < 2) || (objc > 3)) {
|
685 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
686 |
|
|
return TCL_ERROR;
|
687 |
|
|
}
|
688 |
|
|
|
689 |
|
|
/*
|
690 |
|
|
* Make sure that the variable name does not contain anything
|
691 |
|
|
* goofy like a "::" scope qualifier.
|
692 |
|
|
*/
|
693 |
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
694 |
|
|
if (strstr(name, "::")) {
|
695 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
696 |
|
|
"bad variable name \"", name, "\"",
|
697 |
|
|
(char*)NULL);
|
698 |
|
|
return TCL_ERROR;
|
699 |
|
|
}
|
700 |
|
|
|
701 |
|
|
if (objc == 3) {
|
702 |
|
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
703 |
|
|
} else {
|
704 |
|
|
init = NULL;
|
705 |
|
|
}
|
706 |
|
|
|
707 |
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
708 |
|
|
&vdefn) != TCL_OK) {
|
709 |
|
|
|
710 |
|
|
return TCL_ERROR;
|
711 |
|
|
}
|
712 |
|
|
|
713 |
|
|
vdefn->member->protection = ITCL_PROTECTED;
|
714 |
|
|
|
715 |
|
|
return TCL_OK;
|
716 |
|
|
}
|
717 |
|
|
|
718 |
|
|
/*
|
719 |
|
|
* ------------------------------------------------------------------------
|
720 |
|
|
* ItclOldCommonCmd()
|
721 |
|
|
*
|
722 |
|
|
* Invoked by Tcl during the parsing of a class definition whenever
|
723 |
|
|
* the "common" command is invoked to define a variable that is
|
724 |
|
|
* common to all objects in the class. Handles the following syntax:
|
725 |
|
|
*
|
726 |
|
|
* common <varname> ?<init>?
|
727 |
|
|
*
|
728 |
|
|
* ------------------------------------------------------------------------
|
729 |
|
|
*/
|
730 |
|
|
static int
|
731 |
|
|
ItclOldCommonCmd(clientData, interp, objc, objv)
|
732 |
|
|
ClientData clientData; /* info for all known objects */
|
733 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
734 |
|
|
int objc; /* number of arguments */
|
735 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
736 |
|
|
{
|
737 |
|
|
ItclObjectInfo *info = (ItclObjectInfo*)clientData;
|
738 |
|
|
ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack);
|
739 |
|
|
|
740 |
|
|
int newEntry;
|
741 |
|
|
char *name, *init;
|
742 |
|
|
ItclVarDefn *vdefn;
|
743 |
|
|
Tcl_HashEntry *entry;
|
744 |
|
|
Namespace *nsPtr;
|
745 |
|
|
Var *varPtr;
|
746 |
|
|
|
747 |
|
|
if ((objc < 2) || (objc > 3)) {
|
748 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?");
|
749 |
|
|
return TCL_ERROR;
|
750 |
|
|
}
|
751 |
|
|
|
752 |
|
|
/*
|
753 |
|
|
* Make sure that the variable name does not contain anything
|
754 |
|
|
* goofy like a "::" scope qualifier.
|
755 |
|
|
*/
|
756 |
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
757 |
|
|
if (strstr(name, "::")) {
|
758 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
759 |
|
|
"bad variable name \"", name, "\"",
|
760 |
|
|
(char*)NULL);
|
761 |
|
|
return TCL_ERROR;
|
762 |
|
|
}
|
763 |
|
|
|
764 |
|
|
if (objc == 3) {
|
765 |
|
|
init = Tcl_GetStringFromObj(objv[2], (int*)NULL);
|
766 |
|
|
} else {
|
767 |
|
|
init = NULL;
|
768 |
|
|
}
|
769 |
|
|
|
770 |
|
|
if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL,
|
771 |
|
|
&vdefn) != TCL_OK) {
|
772 |
|
|
|
773 |
|
|
return TCL_ERROR;
|
774 |
|
|
}
|
775 |
|
|
|
776 |
|
|
vdefn->member->protection = ITCL_PROTECTED;
|
777 |
|
|
vdefn->member->flags |= ITCL_COMMON;
|
778 |
|
|
|
779 |
|
|
/*
|
780 |
|
|
* Create the variable in the namespace associated with the
|
781 |
|
|
* class. Do this the hard way, to avoid the variable resolver
|
782 |
|
|
* procedures. These procedures won't work until we rebuild
|
783 |
|
|
* the virtual tables below.
|
784 |
|
|
*/
|
785 |
|
|
nsPtr = (Namespace*)cdefnPtr->namesp;
|
786 |
|
|
entry = Tcl_CreateHashEntry(&nsPtr->varTable,
|
787 |
|
|
vdefn->member->name, &newEntry);
|
788 |
|
|
|
789 |
|
|
varPtr = _TclNewVar();
|
790 |
|
|
varPtr->hPtr = entry;
|
791 |
|
|
varPtr->nsPtr = nsPtr;
|
792 |
|
|
varPtr->refCount++; /* protect from being deleted */
|
793 |
|
|
|
794 |
|
|
Tcl_SetHashValue(entry, varPtr);
|
795 |
|
|
|
796 |
|
|
/*
|
797 |
|
|
* TRICKY NOTE: Make sure to rebuild the virtual tables for this
|
798 |
|
|
* class so that this variable is ready to access. The variable
|
799 |
|
|
* resolver for the parser namespace needs this info to find the
|
800 |
|
|
* variable if the developer tries to set it within the class
|
801 |
|
|
* definition.
|
802 |
|
|
*
|
803 |
|
|
* If an initialization value was specified, then initialize
|
804 |
|
|
* the variable now.
|
805 |
|
|
*/
|
806 |
|
|
Itcl_BuildVirtualTables(cdefnPtr);
|
807 |
|
|
|
808 |
|
|
if (init) {
|
809 |
|
|
init = Tcl_SetVar(interp, vdefn->member->name, init,
|
810 |
|
|
TCL_NAMESPACE_ONLY);
|
811 |
|
|
|
812 |
|
|
if (!init) {
|
813 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
814 |
|
|
"cannot initialize common variable \"",
|
815 |
|
|
vdefn->member->name, "\"",
|
816 |
|
|
(char*)NULL);
|
817 |
|
|
return TCL_ERROR;
|
818 |
|
|
}
|
819 |
|
|
}
|
820 |
|
|
return TCL_OK;
|
821 |
|
|
}
|
822 |
|
|
|
823 |
|
|
|
824 |
|
|
/*
|
825 |
|
|
* ------------------------------------------------------------------------
|
826 |
|
|
* ItclOldDeleteCmd()
|
827 |
|
|
*
|
828 |
|
|
* Invokes the destructors, and deletes the object that invoked this
|
829 |
|
|
* operation. If an error is encountered during destruction, the
|
830 |
|
|
* delete operation is aborted. Handles the following syntax:
|
831 |
|
|
*
|
832 |
|
|
* <objName> delete
|
833 |
|
|
*
|
834 |
|
|
* When an object is successfully deleted, it is removed from the
|
835 |
|
|
* list of known objects, and its access command is deleted.
|
836 |
|
|
* ------------------------------------------------------------------------
|
837 |
|
|
*/
|
838 |
|
|
/* ARGSUSED */
|
839 |
|
|
static int
|
840 |
|
|
ItclOldBiDeleteCmd(dummy, interp, objc, objv)
|
841 |
|
|
ClientData dummy; /* not used */
|
842 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
843 |
|
|
int objc; /* number of arguments */
|
844 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
845 |
|
|
{
|
846 |
|
|
ItclClass *contextClass;
|
847 |
|
|
ItclObject *contextObj;
|
848 |
|
|
|
849 |
|
|
if (objc != 1) {
|
850 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "");
|
851 |
|
|
return TCL_ERROR;
|
852 |
|
|
}
|
853 |
|
|
|
854 |
|
|
/*
|
855 |
|
|
* If there is an object context, then destruct the object
|
856 |
|
|
* and delete it.
|
857 |
|
|
*/
|
858 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
859 |
|
|
return TCL_ERROR;
|
860 |
|
|
}
|
861 |
|
|
|
862 |
|
|
if (!contextObj) {
|
863 |
|
|
Tcl_SetResult(interp, "improper usage: should be \"object delete\"",
|
864 |
|
|
TCL_STATIC);
|
865 |
|
|
return TCL_ERROR;
|
866 |
|
|
}
|
867 |
|
|
|
868 |
|
|
if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) {
|
869 |
|
|
return TCL_ERROR;
|
870 |
|
|
}
|
871 |
|
|
|
872 |
|
|
Tcl_ResetResult(interp);
|
873 |
|
|
return TCL_OK;
|
874 |
|
|
}
|
875 |
|
|
|
876 |
|
|
|
877 |
|
|
/*
|
878 |
|
|
* ------------------------------------------------------------------------
|
879 |
|
|
* ItclOldVirtualCmd()
|
880 |
|
|
*
|
881 |
|
|
* Executes the remainder of its command line arguments in the
|
882 |
|
|
* most-specific class scope for the current object. If there is
|
883 |
|
|
* no object context, this fails.
|
884 |
|
|
*
|
885 |
|
|
* NOTE: All methods are now implicitly virtual, and there are
|
886 |
|
|
* much better ways to manipulate scope. This command is only
|
887 |
|
|
* provided for backward-compatibility, and should be avoided.
|
888 |
|
|
*
|
889 |
|
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
890 |
|
|
* ------------------------------------------------------------------------
|
891 |
|
|
*/
|
892 |
|
|
/* ARGSUSED */
|
893 |
|
|
static int
|
894 |
|
|
ItclOldBiVirtualCmd(dummy, interp, objc, objv)
|
895 |
|
|
ClientData dummy; /* not used */
|
896 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
897 |
|
|
int objc; /* number of arguments */
|
898 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
899 |
|
|
{
|
900 |
|
|
int result;
|
901 |
|
|
ItclClass *contextClass;
|
902 |
|
|
ItclObject *contextObj;
|
903 |
|
|
ItclContext context;
|
904 |
|
|
|
905 |
|
|
if (objc == 1) {
|
906 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
907 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
908 |
|
|
"\n This command will be removed soon.",
|
909 |
|
|
"\n Commands are now virtual by default.",
|
910 |
|
|
(char*)NULL);
|
911 |
|
|
return TCL_ERROR;
|
912 |
|
|
}
|
913 |
|
|
|
914 |
|
|
/*
|
915 |
|
|
* If there is no object context, then return an error.
|
916 |
|
|
*/
|
917 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
918 |
|
|
return TCL_ERROR;
|
919 |
|
|
}
|
920 |
|
|
if (!contextObj) {
|
921 |
|
|
Tcl_ResetResult(interp);
|
922 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
923 |
|
|
"cannot use \"virtual\" without an object context\n",
|
924 |
|
|
" This command will be removed soon.\n",
|
925 |
|
|
" Commands are now virtual by default.",
|
926 |
|
|
(char*)NULL);
|
927 |
|
|
return TCL_ERROR;
|
928 |
|
|
}
|
929 |
|
|
|
930 |
|
|
/*
|
931 |
|
|
* Install the most-specific namespace for this object, with
|
932 |
|
|
* the object context as clientData. Invoke the rest of the
|
933 |
|
|
* args as a command in that namespace.
|
934 |
|
|
*/
|
935 |
|
|
if (Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn,
|
936 |
|
|
contextObj, &context) != TCL_OK) {
|
937 |
|
|
|
938 |
|
|
return TCL_ERROR;
|
939 |
|
|
}
|
940 |
|
|
|
941 |
|
|
result = Itcl_EvalArgs(interp, objc-1, objv+1);
|
942 |
|
|
Itcl_PopContext(interp, &context);
|
943 |
|
|
|
944 |
|
|
return result;
|
945 |
|
|
}
|
946 |
|
|
|
947 |
|
|
|
948 |
|
|
/*
|
949 |
|
|
* ------------------------------------------------------------------------
|
950 |
|
|
* ItclOldPreviousCmd()
|
951 |
|
|
*
|
952 |
|
|
* Executes the remainder of its command line arguments in the
|
953 |
|
|
* previous class scope (i.e., the next scope up in the heritage
|
954 |
|
|
* list).
|
955 |
|
|
*
|
956 |
|
|
* NOTE: There are much better ways to manipulate scope. This
|
957 |
|
|
* command is only provided for backward-compatibility, and should
|
958 |
|
|
* be avoided.
|
959 |
|
|
*
|
960 |
|
|
* Returns a status TCL_OK/TCL_ERROR to indicate success/failure.
|
961 |
|
|
* ------------------------------------------------------------------------
|
962 |
|
|
*/
|
963 |
|
|
/* ARGSUSED */
|
964 |
|
|
static int
|
965 |
|
|
ItclOldBiPreviousCmd(dummy, interp, objc, objv)
|
966 |
|
|
ClientData dummy; /* not used */
|
967 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
968 |
|
|
int objc; /* number of arguments */
|
969 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
970 |
|
|
{
|
971 |
|
|
int result;
|
972 |
|
|
char *name;
|
973 |
|
|
ItclClass *contextClass, *base;
|
974 |
|
|
ItclObject *contextObj;
|
975 |
|
|
ItclMember *member;
|
976 |
|
|
ItclMemberFunc *mfunc;
|
977 |
|
|
Itcl_ListElem *elem;
|
978 |
|
|
Tcl_HashEntry *entry;
|
979 |
|
|
|
980 |
|
|
if (objc < 2) {
|
981 |
|
|
Tcl_WrongNumArgs(interp, 1, objv, "command ?args...?");
|
982 |
|
|
return TCL_ERROR;
|
983 |
|
|
}
|
984 |
|
|
|
985 |
|
|
/*
|
986 |
|
|
* If the current context is not a class namespace,
|
987 |
|
|
* return an error.
|
988 |
|
|
*/
|
989 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
990 |
|
|
return TCL_ERROR;
|
991 |
|
|
}
|
992 |
|
|
|
993 |
|
|
/*
|
994 |
|
|
* Get the heritage information for this class and move one
|
995 |
|
|
* level up in the hierarchy. If there is no base class,
|
996 |
|
|
* return an error.
|
997 |
|
|
*/
|
998 |
|
|
elem = Itcl_FirstListElem(&contextClass->bases);
|
999 |
|
|
if (!elem) {
|
1000 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1001 |
|
|
"no previous class in inheritance hierarchy for \"",
|
1002 |
|
|
contextClass->name, "\"",
|
1003 |
|
|
(char*)NULL);
|
1004 |
|
|
return TCL_ERROR;
|
1005 |
|
|
}
|
1006 |
|
|
base = (ItclClass*)Itcl_GetListValue(elem);
|
1007 |
|
|
|
1008 |
|
|
/*
|
1009 |
|
|
* Look in the command resolution table for the base class
|
1010 |
|
|
* to find the desired method.
|
1011 |
|
|
*/
|
1012 |
|
|
name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
|
1013 |
|
|
entry = Tcl_FindHashEntry(&base->resolveCmds, name);
|
1014 |
|
|
if (!entry) {
|
1015 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1016 |
|
|
"invalid command name \"", base->name, "::", name, "\"",
|
1017 |
|
|
(char*)NULL);
|
1018 |
|
|
return TCL_ERROR;
|
1019 |
|
|
}
|
1020 |
|
|
|
1021 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
1022 |
|
|
member = mfunc->member;
|
1023 |
|
|
|
1024 |
|
|
/*
|
1025 |
|
|
* Make sure that this method is accessible.
|
1026 |
|
|
*/
|
1027 |
|
|
if (mfunc->member->protection != ITCL_PUBLIC) {
|
1028 |
|
|
Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp,
|
1029 |
|
|
member->classDefn->info);
|
1030 |
|
|
|
1031 |
|
|
if (!Itcl_CanAccessFunc(mfunc, contextNs)) {
|
1032 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1033 |
|
|
"can't access \"", member->fullname, "\": ",
|
1034 |
|
|
Itcl_ProtectionStr(member->protection), " function",
|
1035 |
|
|
(char*)NULL);
|
1036 |
|
|
return TCL_ERROR;
|
1037 |
|
|
}
|
1038 |
|
|
}
|
1039 |
|
|
|
1040 |
|
|
/*
|
1041 |
|
|
* Invoke the desired method by calling Itcl_EvalMemberCode.
|
1042 |
|
|
* directly. This bypasses the virtual behavior built into
|
1043 |
|
|
* the usual Itcl_ExecMethod handler.
|
1044 |
|
|
*/
|
1045 |
|
|
result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj,
|
1046 |
|
|
objc-1, objv+1);
|
1047 |
|
|
|
1048 |
|
|
result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result);
|
1049 |
|
|
|
1050 |
|
|
return result;
|
1051 |
|
|
}
|
1052 |
|
|
|
1053 |
|
|
|
1054 |
|
|
/*
|
1055 |
|
|
* ------------------------------------------------------------------------
|
1056 |
|
|
* ItclOldBiInfoMethodsCmd()
|
1057 |
|
|
*
|
1058 |
|
|
* Returns information regarding methods for an object. This command
|
1059 |
|
|
* can be invoked with or without an object context:
|
1060 |
|
|
*
|
1061 |
|
|
* <objName> info... <= returns info for most-specific class
|
1062 |
|
|
* info... <= returns info for active namespace
|
1063 |
|
|
*
|
1064 |
|
|
* Handles the following syntax:
|
1065 |
|
|
*
|
1066 |
|
|
* info method ?methodName? ?-args? ?-body?
|
1067 |
|
|
*
|
1068 |
|
|
* If the ?methodName? is not specified, then a list of all known
|
1069 |
|
|
* methods is returned. Otherwise, the information (args/body) for
|
1070 |
|
|
* a specific method is returned. Returns a status TCL_OK/TCL_ERROR
|
1071 |
|
|
* to indicate success/failure.
|
1072 |
|
|
* ------------------------------------------------------------------------
|
1073 |
|
|
*/
|
1074 |
|
|
/* ARGSUSED */
|
1075 |
|
|
static int
|
1076 |
|
|
ItclOldBiInfoMethodsCmd(dummy, interp, objc, objv)
|
1077 |
|
|
ClientData dummy; /* not used */
|
1078 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
1079 |
|
|
int objc; /* number of arguments */
|
1080 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
1081 |
|
|
{
|
1082 |
|
|
char *methodName = NULL;
|
1083 |
|
|
int methodArgs = 0;
|
1084 |
|
|
int methodBody = 0;
|
1085 |
|
|
|
1086 |
|
|
char *token;
|
1087 |
|
|
ItclClass *contextClass, *cdefn;
|
1088 |
|
|
ItclObject *contextObj;
|
1089 |
|
|
ItclHierIter hier;
|
1090 |
|
|
Tcl_HashSearch place;
|
1091 |
|
|
Tcl_HashEntry *entry;
|
1092 |
|
|
ItclMemberFunc *mfunc;
|
1093 |
|
|
ItclMemberCode *mcode;
|
1094 |
|
|
Tcl_Obj *objPtr, *listPtr;
|
1095 |
|
|
|
1096 |
|
|
/*
|
1097 |
|
|
* If this command is not invoked within a class namespace,
|
1098 |
|
|
* signal an error.
|
1099 |
|
|
*/
|
1100 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
1101 |
|
|
return TCL_ERROR;
|
1102 |
|
|
}
|
1103 |
|
|
|
1104 |
|
|
/*
|
1105 |
|
|
* If there is an object context, then use the most-specific
|
1106 |
|
|
* class for the object. Otherwise, use the current class
|
1107 |
|
|
* namespace.
|
1108 |
|
|
*/
|
1109 |
|
|
if (contextObj) {
|
1110 |
|
|
contextClass = contextObj->classDefn;
|
1111 |
|
|
}
|
1112 |
|
|
|
1113 |
|
|
/*
|
1114 |
|
|
* Process args: ?methodName? ?-args? ?-body?
|
1115 |
|
|
*/
|
1116 |
|
|
objv++; /* skip over command name */
|
1117 |
|
|
objc--;
|
1118 |
|
|
|
1119 |
|
|
if (objc > 0) {
|
1120 |
|
|
methodName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1121 |
|
|
objc--; objv++;
|
1122 |
|
|
}
|
1123 |
|
|
for ( ; objc > 0; objc--, objv++) {
|
1124 |
|
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1125 |
|
|
if (strcmp(token, "-args") == 0)
|
1126 |
|
|
methodArgs = ~0;
|
1127 |
|
|
else if (strcmp(token, "-body") == 0)
|
1128 |
|
|
methodBody = ~0;
|
1129 |
|
|
else {
|
1130 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1131 |
|
|
"bad option \"", token, "\": should be -args or -body",
|
1132 |
|
|
(char*)NULL);
|
1133 |
|
|
return TCL_ERROR;
|
1134 |
|
|
}
|
1135 |
|
|
}
|
1136 |
|
|
|
1137 |
|
|
/*
|
1138 |
|
|
* Return info for a specific method.
|
1139 |
|
|
*/
|
1140 |
|
|
if (methodName) {
|
1141 |
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, methodName);
|
1142 |
|
|
if (entry) {
|
1143 |
|
|
int i, valc = 0;
|
1144 |
|
|
Tcl_Obj *valv[5];
|
1145 |
|
|
|
1146 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
1147 |
|
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
1148 |
|
|
return TCL_OK;
|
1149 |
|
|
}
|
1150 |
|
|
|
1151 |
|
|
/*
|
1152 |
|
|
* If the implementation has not yet been defined,
|
1153 |
|
|
* autoload it now.
|
1154 |
|
|
*/
|
1155 |
|
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
1156 |
|
|
return TCL_ERROR;
|
1157 |
|
|
}
|
1158 |
|
|
mcode = mfunc->member->code;
|
1159 |
|
|
|
1160 |
|
|
if (!methodArgs && !methodBody) {
|
1161 |
|
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
1162 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1163 |
|
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
1164 |
|
|
Tcl_IncrRefCount(objPtr);
|
1165 |
|
|
valv[valc++] = objPtr;
|
1166 |
|
|
methodArgs = methodBody = ~0;
|
1167 |
|
|
}
|
1168 |
|
|
if (methodArgs) {
|
1169 |
|
|
if (mcode->arglist) {
|
1170 |
|
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
1171 |
|
|
Tcl_IncrRefCount(objPtr);
|
1172 |
|
|
valv[valc++] = objPtr;
|
1173 |
|
|
}
|
1174 |
|
|
else {
|
1175 |
|
|
objPtr = Tcl_NewStringObj("", -1);
|
1176 |
|
|
Tcl_IncrRefCount(objPtr);
|
1177 |
|
|
valv[valc++] = objPtr;
|
1178 |
|
|
}
|
1179 |
|
|
}
|
1180 |
|
|
if (methodBody) {
|
1181 |
|
|
objPtr = mcode->procPtr->bodyPtr;
|
1182 |
|
|
Tcl_IncrRefCount(objPtr);
|
1183 |
|
|
valv[valc++] = objPtr;
|
1184 |
|
|
}
|
1185 |
|
|
|
1186 |
|
|
/*
|
1187 |
|
|
* If the result list has a single element, then
|
1188 |
|
|
* return it using Tcl_SetResult() so that it will
|
1189 |
|
|
* look like a string and not a list with one element.
|
1190 |
|
|
*/
|
1191 |
|
|
if (valc == 1) {
|
1192 |
|
|
objPtr = valv[0];
|
1193 |
|
|
} else {
|
1194 |
|
|
objPtr = Tcl_NewListObj(valc, valv);
|
1195 |
|
|
}
|
1196 |
|
|
Tcl_SetObjResult(interp, objPtr);
|
1197 |
|
|
|
1198 |
|
|
for (i=0; i < valc; i++) {
|
1199 |
|
|
Tcl_DecrRefCount(valv[i]);
|
1200 |
|
|
}
|
1201 |
|
|
}
|
1202 |
|
|
}
|
1203 |
|
|
|
1204 |
|
|
/*
|
1205 |
|
|
* Return the list of available methods.
|
1206 |
|
|
*/
|
1207 |
|
|
else {
|
1208 |
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
1209 |
|
|
|
1210 |
|
|
Itcl_InitHierIter(&hier, contextClass);
|
1211 |
|
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
1212 |
|
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
1213 |
|
|
while (entry) {
|
1214 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
1215 |
|
|
|
1216 |
|
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
1217 |
|
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
1218 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1219 |
|
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
1220 |
|
|
|
1221 |
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
1222 |
|
|
objPtr);
|
1223 |
|
|
}
|
1224 |
|
|
entry = Tcl_NextHashEntry(&place);
|
1225 |
|
|
}
|
1226 |
|
|
}
|
1227 |
|
|
Itcl_DeleteHierIter(&hier);
|
1228 |
|
|
|
1229 |
|
|
Tcl_SetObjResult(interp, listPtr);
|
1230 |
|
|
}
|
1231 |
|
|
return TCL_OK;
|
1232 |
|
|
}
|
1233 |
|
|
|
1234 |
|
|
|
1235 |
|
|
/*
|
1236 |
|
|
* ------------------------------------------------------------------------
|
1237 |
|
|
* ItclOldBiInfoProcsCmd()
|
1238 |
|
|
*
|
1239 |
|
|
* Returns information regarding procs for a class. This command
|
1240 |
|
|
* can be invoked with or without an object context:
|
1241 |
|
|
*
|
1242 |
|
|
* <objName> info... <= returns info for most-specific class
|
1243 |
|
|
* info... <= returns info for active namespace
|
1244 |
|
|
*
|
1245 |
|
|
* Handles the following syntax:
|
1246 |
|
|
*
|
1247 |
|
|
* info proc ?procName? ?-args? ?-body?
|
1248 |
|
|
*
|
1249 |
|
|
* If the ?procName? is not specified, then a list of all known
|
1250 |
|
|
* procs is returned. Otherwise, the information (args/body) for
|
1251 |
|
|
* a specific proc is returned. Returns a status TCL_OK/TCL_ERROR
|
1252 |
|
|
* to indicate success/failure.
|
1253 |
|
|
* ------------------------------------------------------------------------
|
1254 |
|
|
*/
|
1255 |
|
|
/* ARGSUSED */
|
1256 |
|
|
static int
|
1257 |
|
|
ItclOldBiInfoProcsCmd(dummy, interp, objc, objv)
|
1258 |
|
|
ClientData dummy; /* not used */
|
1259 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
1260 |
|
|
int objc; /* number of arguments */
|
1261 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
1262 |
|
|
{
|
1263 |
|
|
char *procName = NULL;
|
1264 |
|
|
int procArgs = 0;
|
1265 |
|
|
int procBody = 0;
|
1266 |
|
|
|
1267 |
|
|
char *token;
|
1268 |
|
|
ItclClass *contextClass, *cdefn;
|
1269 |
|
|
ItclObject *contextObj;
|
1270 |
|
|
ItclHierIter hier;
|
1271 |
|
|
Tcl_HashSearch place;
|
1272 |
|
|
Tcl_HashEntry *entry;
|
1273 |
|
|
ItclMemberFunc *mfunc;
|
1274 |
|
|
ItclMemberCode *mcode;
|
1275 |
|
|
Tcl_Obj *objPtr, *listPtr;
|
1276 |
|
|
|
1277 |
|
|
/*
|
1278 |
|
|
* If this command is not invoked within a class namespace,
|
1279 |
|
|
* signal an error.
|
1280 |
|
|
*/
|
1281 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
1282 |
|
|
return TCL_ERROR;
|
1283 |
|
|
}
|
1284 |
|
|
|
1285 |
|
|
/*
|
1286 |
|
|
* If there is an object context, then use the most-specific
|
1287 |
|
|
* class for the object. Otherwise, use the current class
|
1288 |
|
|
* namespace.
|
1289 |
|
|
*/
|
1290 |
|
|
if (contextObj) {
|
1291 |
|
|
contextClass = contextObj->classDefn;
|
1292 |
|
|
}
|
1293 |
|
|
|
1294 |
|
|
/*
|
1295 |
|
|
* Process args: ?procName? ?-args? ?-body?
|
1296 |
|
|
*/
|
1297 |
|
|
objv++; /* skip over command name */
|
1298 |
|
|
objc--;
|
1299 |
|
|
|
1300 |
|
|
if (objc > 0) {
|
1301 |
|
|
procName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1302 |
|
|
objc--; objv++;
|
1303 |
|
|
}
|
1304 |
|
|
for ( ; objc > 0; objc--, objv++) {
|
1305 |
|
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1306 |
|
|
if (strcmp(token, "-args") == 0)
|
1307 |
|
|
procArgs = ~0;
|
1308 |
|
|
else if (strcmp(token, "-body") == 0)
|
1309 |
|
|
procBody = ~0;
|
1310 |
|
|
else {
|
1311 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1312 |
|
|
"bad option \"", token, "\": should be -args or -body",
|
1313 |
|
|
(char*)NULL);
|
1314 |
|
|
return TCL_ERROR;
|
1315 |
|
|
}
|
1316 |
|
|
}
|
1317 |
|
|
|
1318 |
|
|
/*
|
1319 |
|
|
* Return info for a specific proc.
|
1320 |
|
|
*/
|
1321 |
|
|
if (procName) {
|
1322 |
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveCmds, procName);
|
1323 |
|
|
if (entry) {
|
1324 |
|
|
int i, valc = 0;
|
1325 |
|
|
Tcl_Obj *valv[5];
|
1326 |
|
|
|
1327 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
1328 |
|
|
if ((mfunc->member->flags & ITCL_COMMON) == 0) {
|
1329 |
|
|
return TCL_OK;
|
1330 |
|
|
}
|
1331 |
|
|
|
1332 |
|
|
/*
|
1333 |
|
|
* If the implementation has not yet been defined,
|
1334 |
|
|
* autoload it now.
|
1335 |
|
|
*/
|
1336 |
|
|
if (Itcl_GetMemberCode(interp, mfunc->member) != TCL_OK) {
|
1337 |
|
|
return TCL_ERROR;
|
1338 |
|
|
}
|
1339 |
|
|
mcode = mfunc->member->code;
|
1340 |
|
|
|
1341 |
|
|
if (!procArgs && !procBody) {
|
1342 |
|
|
objPtr = Tcl_NewStringObj(mfunc->member->fullname, -1);
|
1343 |
|
|
Tcl_IncrRefCount(objPtr);
|
1344 |
|
|
valv[valc++] = objPtr;
|
1345 |
|
|
procArgs = procBody = ~0;
|
1346 |
|
|
}
|
1347 |
|
|
if (procArgs) {
|
1348 |
|
|
if (mcode->arglist) {
|
1349 |
|
|
objPtr = Itcl_ArgList(mcode->argcount, mcode->arglist);
|
1350 |
|
|
Tcl_IncrRefCount(objPtr);
|
1351 |
|
|
valv[valc++] = objPtr;
|
1352 |
|
|
}
|
1353 |
|
|
else {
|
1354 |
|
|
objPtr = Tcl_NewStringObj("", -1);
|
1355 |
|
|
Tcl_IncrRefCount(objPtr);
|
1356 |
|
|
valv[valc++] = objPtr;
|
1357 |
|
|
}
|
1358 |
|
|
}
|
1359 |
|
|
if (procBody) {
|
1360 |
|
|
objPtr = mcode->procPtr->bodyPtr;
|
1361 |
|
|
Tcl_IncrRefCount(objPtr);
|
1362 |
|
|
valv[valc++] = objPtr;
|
1363 |
|
|
}
|
1364 |
|
|
|
1365 |
|
|
/*
|
1366 |
|
|
* If the result list has a single element, then
|
1367 |
|
|
* return it using Tcl_SetResult() so that it will
|
1368 |
|
|
* look like a string and not a list with one element.
|
1369 |
|
|
*/
|
1370 |
|
|
if (valc == 1) {
|
1371 |
|
|
objPtr = valv[0];
|
1372 |
|
|
} else {
|
1373 |
|
|
objPtr = Tcl_NewListObj(valc, valv);
|
1374 |
|
|
}
|
1375 |
|
|
Tcl_SetObjResult(interp, objPtr);
|
1376 |
|
|
|
1377 |
|
|
for (i=0; i < valc; i++) {
|
1378 |
|
|
Tcl_DecrRefCount(valv[i]);
|
1379 |
|
|
}
|
1380 |
|
|
}
|
1381 |
|
|
}
|
1382 |
|
|
|
1383 |
|
|
/*
|
1384 |
|
|
* Return the list of available procs.
|
1385 |
|
|
*/
|
1386 |
|
|
else {
|
1387 |
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
1388 |
|
|
|
1389 |
|
|
Itcl_InitHierIter(&hier, contextClass);
|
1390 |
|
|
while ((cdefn=Itcl_AdvanceHierIter(&hier)) != NULL) {
|
1391 |
|
|
entry = Tcl_FirstHashEntry(&cdefn->functions, &place);
|
1392 |
|
|
while (entry) {
|
1393 |
|
|
mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry);
|
1394 |
|
|
|
1395 |
|
|
if ((mfunc->member->flags & ITCL_COMMON) != 0) {
|
1396 |
|
|
objPtr = Tcl_NewStringObj(mfunc->member->classDefn->name, -1);
|
1397 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1398 |
|
|
Tcl_AppendToObj(objPtr, mfunc->member->name, -1);
|
1399 |
|
|
|
1400 |
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
1401 |
|
|
objPtr);
|
1402 |
|
|
}
|
1403 |
|
|
entry = Tcl_NextHashEntry(&place);
|
1404 |
|
|
}
|
1405 |
|
|
}
|
1406 |
|
|
Itcl_DeleteHierIter(&hier);
|
1407 |
|
|
|
1408 |
|
|
Tcl_SetObjResult(interp, listPtr);
|
1409 |
|
|
}
|
1410 |
|
|
return TCL_OK;
|
1411 |
|
|
}
|
1412 |
|
|
|
1413 |
|
|
|
1414 |
|
|
/*
|
1415 |
|
|
* ------------------------------------------------------------------------
|
1416 |
|
|
* ItclOldBiInfoPublicsCmd()
|
1417 |
|
|
*
|
1418 |
|
|
* Sets the interpreter result to contain information for public
|
1419 |
|
|
* variables in the class. Handles the following syntax:
|
1420 |
|
|
*
|
1421 |
|
|
* info public ?varName? ?-init? ?-value? ?-config?
|
1422 |
|
|
*
|
1423 |
|
|
* If the ?varName? is not specified, then a list of all known public
|
1424 |
|
|
* variables is returned. Otherwise, the information (init/value/config)
|
1425 |
|
|
* for a specific variable is returned. Returns a status
|
1426 |
|
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
1427 |
|
|
* ------------------------------------------------------------------------
|
1428 |
|
|
*/
|
1429 |
|
|
/* ARGSUSED */
|
1430 |
|
|
static int
|
1431 |
|
|
ItclOldBiInfoPublicsCmd(dummy, interp, objc, objv)
|
1432 |
|
|
ClientData dummy; /* not used */
|
1433 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
1434 |
|
|
int objc; /* number of arguments */
|
1435 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
1436 |
|
|
{
|
1437 |
|
|
char *varName = NULL;
|
1438 |
|
|
int varInit = 0;
|
1439 |
|
|
int varCheck = 0;
|
1440 |
|
|
int varValue = 0;
|
1441 |
|
|
|
1442 |
|
|
char *token, *val;
|
1443 |
|
|
ItclClass *contextClass;
|
1444 |
|
|
ItclObject *contextObj;
|
1445 |
|
|
|
1446 |
|
|
ItclClass *cdPtr;
|
1447 |
|
|
ItclVarLookup *vlookup;
|
1448 |
|
|
ItclVarDefn *vdefn;
|
1449 |
|
|
ItclMember *member;
|
1450 |
|
|
ItclHierIter hier;
|
1451 |
|
|
Tcl_HashEntry *entry;
|
1452 |
|
|
Tcl_HashSearch place;
|
1453 |
|
|
Tcl_Obj *objPtr, *listPtr;
|
1454 |
|
|
|
1455 |
|
|
/*
|
1456 |
|
|
* If this command is not invoked within a class namespace,
|
1457 |
|
|
* signal an error.
|
1458 |
|
|
*/
|
1459 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
1460 |
|
|
return TCL_ERROR;
|
1461 |
|
|
}
|
1462 |
|
|
|
1463 |
|
|
/*
|
1464 |
|
|
* Process args: ?varName? ?-init? ?-value? ?-config?
|
1465 |
|
|
*/
|
1466 |
|
|
objv++; /* skip over command name */
|
1467 |
|
|
objc--;
|
1468 |
|
|
|
1469 |
|
|
if (objc > 0) {
|
1470 |
|
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1471 |
|
|
objc--; objv++;
|
1472 |
|
|
}
|
1473 |
|
|
for ( ; objc > 0; objc--, objv++) {
|
1474 |
|
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1475 |
|
|
if (strcmp(token, "-init") == 0)
|
1476 |
|
|
varInit = ~0;
|
1477 |
|
|
else if (strcmp(token, "-value") == 0)
|
1478 |
|
|
varValue = ~0;
|
1479 |
|
|
else if (strcmp(token, "-config") == 0)
|
1480 |
|
|
varCheck = ~0;
|
1481 |
|
|
else {
|
1482 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1483 |
|
|
"bad option \"", token,
|
1484 |
|
|
"\": should be -init, -value or -config",
|
1485 |
|
|
(char*)NULL);
|
1486 |
|
|
return TCL_ERROR;
|
1487 |
|
|
}
|
1488 |
|
|
}
|
1489 |
|
|
|
1490 |
|
|
/*
|
1491 |
|
|
* Return info for a specific variable.
|
1492 |
|
|
*/
|
1493 |
|
|
if (varName) {
|
1494 |
|
|
vlookup = NULL;
|
1495 |
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
1496 |
|
|
if (entry) {
|
1497 |
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
1498 |
|
|
if (vlookup->vdefn->member->protection != ITCL_PUBLIC) {
|
1499 |
|
|
vlookup = NULL;
|
1500 |
|
|
}
|
1501 |
|
|
}
|
1502 |
|
|
|
1503 |
|
|
if (vlookup) {
|
1504 |
|
|
int i, valc = 0;
|
1505 |
|
|
Tcl_Obj *valv[5];
|
1506 |
|
|
|
1507 |
|
|
member = vlookup->vdefn->member;
|
1508 |
|
|
|
1509 |
|
|
if (!varInit && !varCheck && !varValue) {
|
1510 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1511 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1512 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1513 |
|
|
Tcl_IncrRefCount(objPtr);
|
1514 |
|
|
valv[valc++] = objPtr;
|
1515 |
|
|
varInit = varCheck = varValue = ~0;
|
1516 |
|
|
}
|
1517 |
|
|
if (varInit) {
|
1518 |
|
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
1519 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1520 |
|
|
Tcl_IncrRefCount(objPtr);
|
1521 |
|
|
valv[valc++] = objPtr;
|
1522 |
|
|
}
|
1523 |
|
|
if (varValue) {
|
1524 |
|
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
1525 |
|
|
contextObj, contextObj->classDefn);
|
1526 |
|
|
|
1527 |
|
|
if (!val) {
|
1528 |
|
|
val = "<undefined>";
|
1529 |
|
|
}
|
1530 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1531 |
|
|
Tcl_IncrRefCount(objPtr);
|
1532 |
|
|
valv[valc++] = objPtr;
|
1533 |
|
|
}
|
1534 |
|
|
|
1535 |
|
|
if (varCheck) {
|
1536 |
|
|
if (member->code && member->code->procPtr->bodyPtr) {
|
1537 |
|
|
objPtr = member->code->procPtr->bodyPtr;
|
1538 |
|
|
} else {
|
1539 |
|
|
objPtr = Tcl_NewStringObj("", -1);
|
1540 |
|
|
}
|
1541 |
|
|
Tcl_IncrRefCount(objPtr);
|
1542 |
|
|
valv[valc++] = objPtr;
|
1543 |
|
|
}
|
1544 |
|
|
|
1545 |
|
|
/*
|
1546 |
|
|
* If the result list has a single element, then
|
1547 |
|
|
* return it using Tcl_SetResult() so that it will
|
1548 |
|
|
* look like a string and not a list with one element.
|
1549 |
|
|
*/
|
1550 |
|
|
if (valc == 1) {
|
1551 |
|
|
objPtr = valv[0];
|
1552 |
|
|
} else {
|
1553 |
|
|
objPtr = Tcl_NewListObj(valc, valv);
|
1554 |
|
|
}
|
1555 |
|
|
Tcl_SetObjResult(interp, objPtr);
|
1556 |
|
|
|
1557 |
|
|
for (i=0; i < valc; i++) {
|
1558 |
|
|
Tcl_DecrRefCount(valv[i]);
|
1559 |
|
|
}
|
1560 |
|
|
}
|
1561 |
|
|
}
|
1562 |
|
|
|
1563 |
|
|
/*
|
1564 |
|
|
* Return the list of public variables.
|
1565 |
|
|
*/
|
1566 |
|
|
else {
|
1567 |
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
1568 |
|
|
|
1569 |
|
|
Itcl_InitHierIter(&hier, contextClass);
|
1570 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1571 |
|
|
while (cdPtr != NULL) {
|
1572 |
|
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
1573 |
|
|
while (entry) {
|
1574 |
|
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
1575 |
|
|
member = vdefn->member;
|
1576 |
|
|
|
1577 |
|
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
1578 |
|
|
member->protection == ITCL_PUBLIC) {
|
1579 |
|
|
|
1580 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1581 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1582 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1583 |
|
|
|
1584 |
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
1585 |
|
|
objPtr);
|
1586 |
|
|
}
|
1587 |
|
|
entry = Tcl_NextHashEntry(&place);
|
1588 |
|
|
}
|
1589 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1590 |
|
|
}
|
1591 |
|
|
Itcl_DeleteHierIter(&hier);
|
1592 |
|
|
|
1593 |
|
|
Tcl_SetObjResult(interp, listPtr);
|
1594 |
|
|
}
|
1595 |
|
|
return TCL_OK;
|
1596 |
|
|
}
|
1597 |
|
|
|
1598 |
|
|
/*
|
1599 |
|
|
* ------------------------------------------------------------------------
|
1600 |
|
|
* ItclOldBiInfoProtectedsCmd()
|
1601 |
|
|
*
|
1602 |
|
|
* Sets the interpreter result to contain information for protected
|
1603 |
|
|
* variables in the class. Handles the following syntax:
|
1604 |
|
|
*
|
1605 |
|
|
* info protected ?varName? ?-init? ?-value?
|
1606 |
|
|
*
|
1607 |
|
|
* If the ?varName? is not specified, then a list of all known public
|
1608 |
|
|
* variables is returned. Otherwise, the information (init/value)
|
1609 |
|
|
* for a specific variable is returned. Returns a status
|
1610 |
|
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
1611 |
|
|
* ------------------------------------------------------------------------
|
1612 |
|
|
*/
|
1613 |
|
|
/* ARGSUSED */
|
1614 |
|
|
static int
|
1615 |
|
|
ItclOldBiInfoProtectedsCmd(dummy, interp, objc, objv)
|
1616 |
|
|
ClientData dummy; /* not used */
|
1617 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
1618 |
|
|
int objc; /* number of arguments */
|
1619 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
1620 |
|
|
{
|
1621 |
|
|
char *varName = NULL;
|
1622 |
|
|
int varInit = 0;
|
1623 |
|
|
int varValue = 0;
|
1624 |
|
|
|
1625 |
|
|
char *token, *val;
|
1626 |
|
|
ItclClass *contextClass;
|
1627 |
|
|
ItclObject *contextObj;
|
1628 |
|
|
|
1629 |
|
|
ItclClass *cdPtr;
|
1630 |
|
|
ItclVarLookup *vlookup;
|
1631 |
|
|
ItclVarDefn *vdefn;
|
1632 |
|
|
ItclMember *member;
|
1633 |
|
|
ItclHierIter hier;
|
1634 |
|
|
Tcl_HashEntry *entry;
|
1635 |
|
|
Tcl_HashSearch place;
|
1636 |
|
|
Tcl_Obj *objPtr, *listPtr;
|
1637 |
|
|
|
1638 |
|
|
/*
|
1639 |
|
|
* If this command is not invoked within a class namespace,
|
1640 |
|
|
* signal an error.
|
1641 |
|
|
*/
|
1642 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
1643 |
|
|
return TCL_ERROR;
|
1644 |
|
|
}
|
1645 |
|
|
|
1646 |
|
|
/*
|
1647 |
|
|
* Process args: ?varName? ?-init? ?-value?
|
1648 |
|
|
*/
|
1649 |
|
|
objv++; /* skip over command name */
|
1650 |
|
|
objc--;
|
1651 |
|
|
|
1652 |
|
|
if (objc > 0) {
|
1653 |
|
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1654 |
|
|
objc--; objv++;
|
1655 |
|
|
}
|
1656 |
|
|
for ( ; objc > 0; objc--, objv++) {
|
1657 |
|
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1658 |
|
|
if (strcmp(token, "-init") == 0)
|
1659 |
|
|
varInit = ~0;
|
1660 |
|
|
else if (strcmp(token, "-value") == 0)
|
1661 |
|
|
varValue = ~0;
|
1662 |
|
|
else {
|
1663 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1664 |
|
|
"bad option \"", token, "\": should be -init or -value",
|
1665 |
|
|
(char*)NULL);
|
1666 |
|
|
return TCL_ERROR;
|
1667 |
|
|
}
|
1668 |
|
|
}
|
1669 |
|
|
|
1670 |
|
|
/*
|
1671 |
|
|
* Return info for a specific variable.
|
1672 |
|
|
*/
|
1673 |
|
|
if (varName) {
|
1674 |
|
|
vlookup = NULL;
|
1675 |
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
1676 |
|
|
if (entry) {
|
1677 |
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
1678 |
|
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
1679 |
|
|
vlookup = NULL;
|
1680 |
|
|
}
|
1681 |
|
|
}
|
1682 |
|
|
|
1683 |
|
|
if (vlookup) {
|
1684 |
|
|
int i, valc = 0;
|
1685 |
|
|
Tcl_Obj *valv[5];
|
1686 |
|
|
|
1687 |
|
|
member = vlookup->vdefn->member;
|
1688 |
|
|
|
1689 |
|
|
if (!varInit && !varValue) {
|
1690 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1691 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1692 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1693 |
|
|
Tcl_IncrRefCount(objPtr);
|
1694 |
|
|
valv[valc++] = objPtr;
|
1695 |
|
|
varInit = varValue = ~0;
|
1696 |
|
|
}
|
1697 |
|
|
|
1698 |
|
|
/*
|
1699 |
|
|
* If this is the built-in "this" variable, then
|
1700 |
|
|
* report the object name as its initialization string.
|
1701 |
|
|
*/
|
1702 |
|
|
if (varInit) {
|
1703 |
|
|
if ((member->flags & ITCL_THIS_VAR) != 0) {
|
1704 |
|
|
if (contextObj && contextObj->accessCmd) {
|
1705 |
|
|
objPtr = Tcl_NewStringObj("", -1);
|
1706 |
|
|
Tcl_IncrRefCount(objPtr);
|
1707 |
|
|
Tcl_GetCommandFullName(contextObj->classDefn->interp,
|
1708 |
|
|
contextObj->accessCmd, objPtr);
|
1709 |
|
|
valv[valc++] = objPtr;
|
1710 |
|
|
}
|
1711 |
|
|
else {
|
1712 |
|
|
objPtr = Tcl_NewStringObj("<objectName>", -1);
|
1713 |
|
|
Tcl_IncrRefCount(objPtr);
|
1714 |
|
|
valv[valc++] = objPtr;
|
1715 |
|
|
}
|
1716 |
|
|
}
|
1717 |
|
|
else {
|
1718 |
|
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
1719 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1720 |
|
|
Tcl_IncrRefCount(objPtr);
|
1721 |
|
|
valv[valc++] = objPtr;
|
1722 |
|
|
}
|
1723 |
|
|
}
|
1724 |
|
|
|
1725 |
|
|
if (varValue) {
|
1726 |
|
|
val = Itcl_GetInstanceVar(interp, member->fullname,
|
1727 |
|
|
contextObj, contextObj->classDefn);
|
1728 |
|
|
|
1729 |
|
|
if (!val) {
|
1730 |
|
|
val = "<undefined>";
|
1731 |
|
|
}
|
1732 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1733 |
|
|
Tcl_IncrRefCount(objPtr);
|
1734 |
|
|
valv[valc++] = objPtr;
|
1735 |
|
|
}
|
1736 |
|
|
|
1737 |
|
|
/*
|
1738 |
|
|
* If the result list has a single element, then
|
1739 |
|
|
* return it using Tcl_SetResult() so that it will
|
1740 |
|
|
* look like a string and not a list with one element.
|
1741 |
|
|
*/
|
1742 |
|
|
if (valc == 1) {
|
1743 |
|
|
objPtr = valv[0];
|
1744 |
|
|
} else {
|
1745 |
|
|
objPtr = Tcl_NewListObj(valc, valv);
|
1746 |
|
|
}
|
1747 |
|
|
Tcl_SetObjResult(interp, objPtr);
|
1748 |
|
|
|
1749 |
|
|
for (i=0; i < valc; i++) {
|
1750 |
|
|
Tcl_DecrRefCount(valv[i]);
|
1751 |
|
|
}
|
1752 |
|
|
}
|
1753 |
|
|
}
|
1754 |
|
|
|
1755 |
|
|
/*
|
1756 |
|
|
* Return the list of public variables.
|
1757 |
|
|
*/
|
1758 |
|
|
else {
|
1759 |
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
1760 |
|
|
|
1761 |
|
|
Itcl_InitHierIter(&hier, contextClass);
|
1762 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1763 |
|
|
while (cdPtr != NULL) {
|
1764 |
|
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
1765 |
|
|
while (entry) {
|
1766 |
|
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
1767 |
|
|
member = vdefn->member;
|
1768 |
|
|
|
1769 |
|
|
if ((member->flags & ITCL_COMMON) == 0 &&
|
1770 |
|
|
member->protection == ITCL_PROTECTED) {
|
1771 |
|
|
|
1772 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1773 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1774 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1775 |
|
|
|
1776 |
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
1777 |
|
|
objPtr);
|
1778 |
|
|
}
|
1779 |
|
|
entry = Tcl_NextHashEntry(&place);
|
1780 |
|
|
}
|
1781 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1782 |
|
|
}
|
1783 |
|
|
Itcl_DeleteHierIter(&hier);
|
1784 |
|
|
|
1785 |
|
|
Tcl_SetObjResult(interp, listPtr);
|
1786 |
|
|
}
|
1787 |
|
|
return TCL_OK;
|
1788 |
|
|
}
|
1789 |
|
|
|
1790 |
|
|
/*
|
1791 |
|
|
* ------------------------------------------------------------------------
|
1792 |
|
|
* ItclOldBiInfoCommonsCmd()
|
1793 |
|
|
*
|
1794 |
|
|
* Sets the interpreter result to contain information for common
|
1795 |
|
|
* variables in the class. Handles the following syntax:
|
1796 |
|
|
*
|
1797 |
|
|
* info common ?varName? ?-init? ?-value?
|
1798 |
|
|
*
|
1799 |
|
|
* If the ?varName? is not specified, then a list of all known common
|
1800 |
|
|
* variables is returned. Otherwise, the information (init/value)
|
1801 |
|
|
* for a specific variable is returned. Returns a status
|
1802 |
|
|
* TCL_OK/TCL_ERROR to indicate success/failure.
|
1803 |
|
|
* ------------------------------------------------------------------------
|
1804 |
|
|
*/
|
1805 |
|
|
/* ARGSUSED */
|
1806 |
|
|
static int
|
1807 |
|
|
ItclOldBiInfoCommonsCmd(dummy, interp, objc, objv)
|
1808 |
|
|
ClientData dummy; /* not used */
|
1809 |
|
|
Tcl_Interp *interp; /* current interpreter */
|
1810 |
|
|
int objc; /* number of arguments */
|
1811 |
|
|
Tcl_Obj *CONST objv[]; /* argument objects */
|
1812 |
|
|
{
|
1813 |
|
|
char *varName = NULL;
|
1814 |
|
|
int varInit = 0;
|
1815 |
|
|
int varValue = 0;
|
1816 |
|
|
|
1817 |
|
|
char *token, *val;
|
1818 |
|
|
ItclClass *contextClass;
|
1819 |
|
|
ItclObject *contextObj;
|
1820 |
|
|
|
1821 |
|
|
ItclClass *cdPtr;
|
1822 |
|
|
ItclVarDefn *vdefn;
|
1823 |
|
|
ItclVarLookup *vlookup;
|
1824 |
|
|
ItclMember *member;
|
1825 |
|
|
ItclHierIter hier;
|
1826 |
|
|
Tcl_HashEntry *entry;
|
1827 |
|
|
Tcl_HashSearch place;
|
1828 |
|
|
Tcl_Obj *objPtr, *listPtr;
|
1829 |
|
|
|
1830 |
|
|
/*
|
1831 |
|
|
* If this command is not invoked within a class namespace,
|
1832 |
|
|
* signal an error.
|
1833 |
|
|
*/
|
1834 |
|
|
if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) {
|
1835 |
|
|
return TCL_ERROR;
|
1836 |
|
|
}
|
1837 |
|
|
|
1838 |
|
|
/*
|
1839 |
|
|
* Process args: ?varName? ?-init? ?-value?
|
1840 |
|
|
*/
|
1841 |
|
|
objv++; /* skip over command name */
|
1842 |
|
|
objc--;
|
1843 |
|
|
|
1844 |
|
|
if (objc > 0) {
|
1845 |
|
|
varName = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1846 |
|
|
objc--; objv++;
|
1847 |
|
|
}
|
1848 |
|
|
for ( ; objc > 0; objc--, objv++) {
|
1849 |
|
|
token = Tcl_GetStringFromObj(*objv, (int*)NULL);
|
1850 |
|
|
if (strcmp(token, "-init") == 0)
|
1851 |
|
|
varInit = ~0;
|
1852 |
|
|
else if (strcmp(token, "-value") == 0)
|
1853 |
|
|
varValue = ~0;
|
1854 |
|
|
else {
|
1855 |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
1856 |
|
|
"bad option \"", token, "\": should be -init or -value",
|
1857 |
|
|
(char*)NULL);
|
1858 |
|
|
return TCL_ERROR;
|
1859 |
|
|
}
|
1860 |
|
|
}
|
1861 |
|
|
|
1862 |
|
|
/*
|
1863 |
|
|
* Return info for a specific variable.
|
1864 |
|
|
*/
|
1865 |
|
|
if (varName) {
|
1866 |
|
|
vlookup = NULL;
|
1867 |
|
|
entry = Tcl_FindHashEntry(&contextClass->resolveVars, varName);
|
1868 |
|
|
if (entry) {
|
1869 |
|
|
vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry);
|
1870 |
|
|
if (vlookup->vdefn->member->protection != ITCL_PROTECTED) {
|
1871 |
|
|
vlookup = NULL;
|
1872 |
|
|
}
|
1873 |
|
|
}
|
1874 |
|
|
|
1875 |
|
|
if (vlookup) {
|
1876 |
|
|
int i, valc = 0;
|
1877 |
|
|
Tcl_Obj *valv[5];
|
1878 |
|
|
|
1879 |
|
|
member = vlookup->vdefn->member;
|
1880 |
|
|
|
1881 |
|
|
if (!varInit && !varValue) {
|
1882 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1883 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1884 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1885 |
|
|
Tcl_IncrRefCount(objPtr);
|
1886 |
|
|
valv[valc++] = objPtr;
|
1887 |
|
|
varInit = varValue = ~0;
|
1888 |
|
|
}
|
1889 |
|
|
if (varInit) {
|
1890 |
|
|
val = (vlookup->vdefn->init) ? vlookup->vdefn->init : "";
|
1891 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1892 |
|
|
Tcl_IncrRefCount(objPtr);
|
1893 |
|
|
valv[valc++] = objPtr;
|
1894 |
|
|
}
|
1895 |
|
|
|
1896 |
|
|
if (varValue) {
|
1897 |
|
|
val = Itcl_GetCommonVar(interp, member->fullname,
|
1898 |
|
|
contextObj->classDefn);
|
1899 |
|
|
|
1900 |
|
|
if (!val) {
|
1901 |
|
|
val = "<undefined>";
|
1902 |
|
|
}
|
1903 |
|
|
objPtr = Tcl_NewStringObj(val, -1);
|
1904 |
|
|
Tcl_IncrRefCount(objPtr);
|
1905 |
|
|
valv[valc++] = objPtr;
|
1906 |
|
|
}
|
1907 |
|
|
|
1908 |
|
|
/*
|
1909 |
|
|
* If the result list has a single element, then
|
1910 |
|
|
* return it using Tcl_SetResult() so that it will
|
1911 |
|
|
* look like a string and not a list with one element.
|
1912 |
|
|
*/
|
1913 |
|
|
if (valc == 1) {
|
1914 |
|
|
objPtr = valv[0];
|
1915 |
|
|
} else {
|
1916 |
|
|
objPtr = Tcl_NewListObj(valc, valv);
|
1917 |
|
|
}
|
1918 |
|
|
Tcl_SetObjResult(interp, objPtr);
|
1919 |
|
|
|
1920 |
|
|
for (i=0; i < valc; i++) {
|
1921 |
|
|
Tcl_DecrRefCount(valv[i]);
|
1922 |
|
|
}
|
1923 |
|
|
}
|
1924 |
|
|
}
|
1925 |
|
|
|
1926 |
|
|
/*
|
1927 |
|
|
* Return the list of public variables.
|
1928 |
|
|
*/
|
1929 |
|
|
else {
|
1930 |
|
|
listPtr = Tcl_NewListObj(0, (Tcl_Obj* CONST*)NULL);
|
1931 |
|
|
|
1932 |
|
|
Itcl_InitHierIter(&hier, contextClass);
|
1933 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1934 |
|
|
while (cdPtr != NULL) {
|
1935 |
|
|
entry = Tcl_FirstHashEntry(&cdPtr->variables, &place);
|
1936 |
|
|
while (entry) {
|
1937 |
|
|
vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry);
|
1938 |
|
|
member = vdefn->member;
|
1939 |
|
|
|
1940 |
|
|
if ((member->flags & ITCL_COMMON) &&
|
1941 |
|
|
member->protection == ITCL_PROTECTED) {
|
1942 |
|
|
|
1943 |
|
|
objPtr = Tcl_NewStringObj(member->classDefn->name, -1);
|
1944 |
|
|
Tcl_AppendToObj(objPtr, "::", -1);
|
1945 |
|
|
Tcl_AppendToObj(objPtr, member->name, -1);
|
1946 |
|
|
|
1947 |
|
|
Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr,
|
1948 |
|
|
objPtr);
|
1949 |
|
|
}
|
1950 |
|
|
entry = Tcl_NextHashEntry(&place);
|
1951 |
|
|
}
|
1952 |
|
|
cdPtr = Itcl_AdvanceHierIter(&hier);
|
1953 |
|
|
}
|
1954 |
|
|
Itcl_DeleteHierIter(&hier);
|
1955 |
|
|
|
1956 |
|
|
Tcl_SetObjResult(interp, listPtr);
|
1957 |
|
|
}
|
1958 |
|
|
return TCL_OK;
|
1959 |
|
|
}
|