[175] | 1 | /*
|
---|
| 2 | * bltNsUtil.c --
|
---|
| 3 | *
|
---|
| 4 | * This module implements utility procedures for namespaces
|
---|
| 5 | * in the BLT toolkit.
|
---|
| 6 | *
|
---|
| 7 | * Copyright 1991-1998 Lucent Technologies, Inc.
|
---|
| 8 | *
|
---|
| 9 | * Permission to use, copy, modify, and distribute this software and
|
---|
| 10 | * its documentation for any purpose and without fee is hereby
|
---|
| 11 | * granted, provided that the above copyright notice appear in all
|
---|
| 12 | * copies and that both that the copyright notice and warranty
|
---|
| 13 | * disclaimer appear in supporting documentation, and that the names
|
---|
| 14 | * of Lucent Technologies any of their entities not be used in
|
---|
| 15 | * advertising or publicity pertaining to distribution of the software
|
---|
| 16 | * without specific, written prior permission.
|
---|
| 17 | *
|
---|
| 18 | * Lucent Technologies disclaims all warranties with regard to this
|
---|
| 19 | * software, including all implied warranties of merchantability and
|
---|
| 20 | * fitness. In no event shall Lucent Technologies be liable for any
|
---|
| 21 | * special, indirect or consequential damages or any damages
|
---|
| 22 | * whatsoever resulting from loss of use, data or profits, whether in
|
---|
| 23 | * an action of contract, negligence or other tortuous action, arising
|
---|
| 24 | * out of or in connection with the use or performance of this
|
---|
| 25 | * software.
|
---|
| 26 | */
|
---|
| 27 |
|
---|
| 28 | #include "bltInt.h"
|
---|
| 29 | #include "bltList.h"
|
---|
| 30 |
|
---|
| 31 | /* Namespace related routines */
|
---|
| 32 |
|
---|
| 33 | typedef struct {
|
---|
| 34 | char *result;
|
---|
| 35 | Tcl_FreeProc *freeProc;
|
---|
| 36 | int errorLine;
|
---|
| 37 | Tcl_HashTable commandTable;
|
---|
| 38 | Tcl_HashTable mathFuncTable;
|
---|
| 39 |
|
---|
| 40 | Tcl_HashTable globalTable; /* This is the only field we care about */
|
---|
| 41 |
|
---|
| 42 | int nLevels;
|
---|
| 43 | int maxNestingDepth;
|
---|
| 44 | } TclInterp;
|
---|
| 45 |
|
---|
| 46 |
|
---|
| 47 |
|
---|
| 48 | /*
|
---|
| 49 | * ----------------------------------------------------------------------
|
---|
| 50 | *
|
---|
| 51 | * Blt_GetVariableNamespace --
|
---|
| 52 | *
|
---|
| 53 | * Returns the namespace context of the vector variable. If NULL,
|
---|
| 54 | * this indicates that the variable is local to the call frame.
|
---|
| 55 | *
|
---|
| 56 | * Note the ever-dangerous manner in which we get this information.
|
---|
| 57 | * All of these structures are "private". Now who's calling Tcl
|
---|
| 58 | * an "extension" language?
|
---|
| 59 | *
|
---|
| 60 | * Results:
|
---|
| 61 | * Returns the context of the namespace in an opaque type.
|
---|
| 62 | *
|
---|
| 63 | * ----------------------------------------------------------------------
|
---|
| 64 | */
|
---|
| 65 |
|
---|
| 66 | #if (TCL_MAJOR_VERSION == 7)
|
---|
| 67 |
|
---|
| 68 | #ifdef ITCL_NAMESPACES
|
---|
| 69 |
|
---|
| 70 | struct VarTrace;
|
---|
| 71 | struct ArraySearch;
|
---|
| 72 | struct NamespCacheRef;
|
---|
| 73 |
|
---|
| 74 | typedef struct VarStruct Var;
|
---|
| 75 |
|
---|
| 76 | struct VarStruct {
|
---|
| 77 | int valueLength;
|
---|
| 78 | int valueSpace;
|
---|
| 79 | union {
|
---|
| 80 | char *string;
|
---|
| 81 | Tcl_HashTable *tablePtr;
|
---|
| 82 | Var *upvarPtr;
|
---|
| 83 | } value;
|
---|
| 84 | Tcl_HashEntry *hPtr;
|
---|
| 85 | int refCount;
|
---|
| 86 | struct VarTrace *tracePtr;
|
---|
| 87 | struct ArraySearch *searchPtr;
|
---|
| 88 | int flags;
|
---|
| 89 |
|
---|
| 90 | /* >>>>>>>>>> stuff for [incr Tcl] namespaces <<<<<<<<<< */
|
---|
| 91 |
|
---|
| 92 | char *name;
|
---|
| 93 | int protection;
|
---|
| 94 |
|
---|
| 95 | Itcl_Namespace *namesp;
|
---|
| 96 | struct NamespCacheRef *cacheInfo;
|
---|
| 97 |
|
---|
| 98 | } Var;
|
---|
| 99 |
|
---|
| 100 |
|
---|
| 101 | Tcl_Namespace *
|
---|
| 102 | Tcl_FindNamespace(interp, name)
|
---|
| 103 | Tcl_Interp *interp;
|
---|
| 104 | char *name;
|
---|
| 105 | {
|
---|
| 106 | Itcl_Namespace nsToken;
|
---|
| 107 |
|
---|
| 108 | if (Itcl_FindNamesp(interp, name, 0, &nsToken) != TCL_OK) {
|
---|
| 109 | Tcl_ResetResult(interp);
|
---|
| 110 | return NULL;
|
---|
| 111 | }
|
---|
| 112 | return (Tcl_Namespace *) nsToken;
|
---|
| 113 | }
|
---|
| 114 |
|
---|
| 115 | Tcl_Namespace *
|
---|
| 116 | Tcl_GetGlobalNamespace(interp)
|
---|
| 117 | Tcl_Interp *interp;
|
---|
| 118 | {
|
---|
| 119 | return (Tcl_Namespace *) Itcl_GetGlobalNamesp(interp);
|
---|
| 120 | }
|
---|
| 121 |
|
---|
| 122 | Tcl_Namespace *
|
---|
| 123 | Tcl_GetCurrentNamespace(interp)
|
---|
| 124 | Tcl_Interp *interp;
|
---|
| 125 | {
|
---|
| 126 | return (Tcl_Namespace *) Itcl_GetActiveNamesp(interp);
|
---|
| 127 | }
|
---|
| 128 |
|
---|
| 129 | Tcl_Namespace *
|
---|
| 130 | Blt_GetCommandNamespace(interp, cmdToken)
|
---|
| 131 | Tcl_Interp *interp;
|
---|
| 132 | Tcl_Command cmdToken;
|
---|
| 133 | {
|
---|
| 134 | return (Tcl_Namespace *)interp;
|
---|
| 135 | }
|
---|
| 136 |
|
---|
| 137 | Tcl_Namespace *
|
---|
| 138 | Blt_GetVariableNamespace(interp, name)
|
---|
| 139 | Tcl_Interp *interp;
|
---|
| 140 | CONST char *name;
|
---|
| 141 | {
|
---|
| 142 | Tcl_Var varToken;
|
---|
| 143 | Var *varPtr;
|
---|
| 144 |
|
---|
| 145 | if (Itcl_FindVariable(interp, name, 0, &varToken) != TCL_OK) {
|
---|
| 146 | return NULL;
|
---|
| 147 | }
|
---|
| 148 | varPtr = (Var *) varToken;
|
---|
| 149 | if (varPtr == NULL) {
|
---|
| 150 | return NULL;
|
---|
| 151 | }
|
---|
| 152 | return (Tcl_Namespace *) varPtr->namesp;
|
---|
| 153 | }
|
---|
| 154 |
|
---|
| 155 | Tcl_CallFrame *
|
---|
| 156 | Blt_EnterNamespace(interp, nsPtr)
|
---|
| 157 | Tcl_Interp *interp;
|
---|
| 158 | Tcl_Namespace *nsPtr;
|
---|
| 159 | {
|
---|
| 160 | Itcl_Namespace nsToken = (Itcl_Namespace) nsPtr;
|
---|
| 161 |
|
---|
| 162 | return (Tcl_CallFrame *) Itcl_ActivateNamesp(interp, nsToken);
|
---|
| 163 | }
|
---|
| 164 |
|
---|
| 165 | void
|
---|
| 166 | Blt_LeaveNamespace(interp, framePtr)
|
---|
| 167 | Tcl_Interp *interp;
|
---|
| 168 | Tcl_CallFrame *framePtr;
|
---|
| 169 | {
|
---|
| 170 | Itcl_DeactivateNamesp(interp, (Itcl_ActiveNamespace) framePtr);
|
---|
| 171 | }
|
---|
| 172 |
|
---|
| 173 | #else
|
---|
| 174 |
|
---|
| 175 | Tcl_Namespace *
|
---|
| 176 | Blt_GetCommandNamespace(interp, cmdToken)
|
---|
| 177 | Tcl_Interp *interp;
|
---|
| 178 | Tcl_Command cmdToken;
|
---|
| 179 | {
|
---|
| 180 | return (Tcl_Namespace *)interp;
|
---|
| 181 | }
|
---|
| 182 |
|
---|
| 183 | Tcl_Namespace *
|
---|
| 184 | Blt_GetVariableNamespace(interp, name)
|
---|
| 185 | Tcl_Interp *interp;
|
---|
| 186 | CONST char *name;
|
---|
| 187 | {
|
---|
| 188 | TclInterp *iPtr = (TclInterp *) interp;
|
---|
| 189 |
|
---|
| 190 | return (Tcl_Namespace *)
|
---|
| 191 | Tcl_FindHashEntry(&(iPtr->globalTable), (char *)name);
|
---|
| 192 | }
|
---|
| 193 |
|
---|
| 194 | Tcl_CallFrame *
|
---|
| 195 | Blt_EnterNamespace(interp, nsPtr)
|
---|
| 196 | Tcl_Interp *interp;
|
---|
| 197 | Tcl_Namespace *nsPtr; /* Not used. */
|
---|
| 198 | {
|
---|
| 199 | return NULL;
|
---|
| 200 | }
|
---|
| 201 |
|
---|
| 202 | void
|
---|
| 203 | Blt_LeaveNamespace(interp, framePtr)
|
---|
| 204 | Tcl_Interp *interp;
|
---|
| 205 | Tcl_CallFrame *framePtr;
|
---|
| 206 | {
|
---|
| 207 | /* empty */
|
---|
| 208 | }
|
---|
| 209 |
|
---|
| 210 | Tcl_Namespace *
|
---|
| 211 | Tcl_GetGlobalNamespace(interp)
|
---|
| 212 | Tcl_Interp *interp;
|
---|
| 213 | {
|
---|
| 214 | return (Tcl_Namespace *) interp;
|
---|
| 215 | }
|
---|
| 216 |
|
---|
| 217 | Tcl_Namespace *
|
---|
| 218 | Tcl_GetCurrentNamespace(interp)
|
---|
| 219 | Tcl_Interp *interp;
|
---|
| 220 | {
|
---|
| 221 | return (Tcl_Namespace *) interp;
|
---|
| 222 | }
|
---|
| 223 |
|
---|
| 224 | Tcl_Namespace *
|
---|
| 225 | Tcl_FindNamespace(interp, name)
|
---|
| 226 | Tcl_Interp *interp;
|
---|
| 227 | char *name;
|
---|
| 228 | {
|
---|
| 229 | return (Tcl_Namespace *) interp;
|
---|
| 230 | }
|
---|
| 231 |
|
---|
| 232 | #endif /* ITCL_NAMESPACES */
|
---|
| 233 |
|
---|
| 234 | #else
|
---|
| 235 |
|
---|
| 236 | /*
|
---|
| 237 | * A Command structure exists for each command in a namespace. The
|
---|
| 238 | * Tcl_Command opaque type actually refers to these structures.
|
---|
| 239 | */
|
---|
| 240 |
|
---|
| 241 | typedef struct CompileProcStruct CompileProc;
|
---|
| 242 | typedef struct ImportRefStruct ImportRef;
|
---|
| 243 |
|
---|
| 244 | typedef struct {
|
---|
| 245 | Tcl_HashEntry *hPtr; /* Pointer to the hash table entry that
|
---|
| 246 | * refers to this command. The hash table is
|
---|
| 247 | * either a namespace's command table or an
|
---|
| 248 | * interpreter's hidden command table. This
|
---|
| 249 | * pointer is used to get a command's name
|
---|
| 250 | * from its Tcl_Command handle. NULL means
|
---|
| 251 | * that the hash table entry has been
|
---|
| 252 | * removed already (this can happen if
|
---|
| 253 | * deleteProc causes the command to be
|
---|
| 254 | * deleted or recreated). */
|
---|
| 255 | Tcl_Namespace *nsPtr; /* Points to the namespace containing this
|
---|
| 256 | * command. */
|
---|
| 257 | int refCount; /* 1 if in command hashtable plus 1 for each
|
---|
| 258 | * reference from a CmdName Tcl object
|
---|
| 259 | * representing a command's name in a
|
---|
| 260 | * ByteCode instruction sequence. This
|
---|
| 261 | * structure can be freed when refCount
|
---|
| 262 | * becomes zero. */
|
---|
| 263 | int cmdEpoch; /* Incremented to invalidate any references
|
---|
| 264 | * that point to this command when it is
|
---|
| 265 | * renamed, deleted, hidden, or exposed. */
|
---|
| 266 | CompileProc *compileProc; /* Procedure called to compile command. NULL
|
---|
| 267 | * if no compile proc exists for command. */
|
---|
| 268 | Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
|
---|
| 269 | ClientData objClientData; /* Arbitrary value passed to object proc. */
|
---|
| 270 | Tcl_CmdProc *proc; /* String-based command procedure. */
|
---|
| 271 | ClientData clientData; /* Arbitrary value passed to string proc. */
|
---|
| 272 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 273 | /* Procedure invoked when deleting command
|
---|
| 274 | * to, e.g., free all client data. */
|
---|
| 275 | ClientData deleteData; /* Arbitrary value passed to deleteProc. */
|
---|
| 276 | int deleted; /* Means that the command is in the process
|
---|
| 277 | * of being deleted (its deleteProc is
|
---|
| 278 | * currently executing). Other attempts to
|
---|
| 279 | * delete the command should be ignored. */
|
---|
| 280 | ImportRef *importRefPtr; /* List of each imported Command created in
|
---|
| 281 | * another namespace when this command is
|
---|
| 282 | * imported. These imported commands
|
---|
| 283 | * redirect invocations back to this
|
---|
| 284 | * command. The list is used to remove all
|
---|
| 285 | * those imported commands when deleting
|
---|
| 286 | * this "real" command. */
|
---|
| 287 | } Command;
|
---|
| 288 |
|
---|
| 289 |
|
---|
| 290 | struct VarTrace;
|
---|
| 291 | struct ArraySearch;
|
---|
| 292 |
|
---|
| 293 | typedef struct VarStruct Var;
|
---|
| 294 |
|
---|
| 295 | struct VarStruct {
|
---|
| 296 | union {
|
---|
| 297 | Tcl_Obj *objPtr;
|
---|
| 298 | Tcl_HashTable *tablePtr;
|
---|
| 299 | Var *linkPtr;
|
---|
| 300 | } value;
|
---|
| 301 | char *name;
|
---|
| 302 | Tcl_Namespace *nsPtr;
|
---|
| 303 | Tcl_HashEntry *hPtr;
|
---|
| 304 | int refCount;
|
---|
| 305 | struct VarTrace *tracePtr;
|
---|
| 306 | struct ArraySearch *searchPtr;
|
---|
| 307 | int flags;
|
---|
| 308 | };
|
---|
| 309 |
|
---|
| 310 | extern Var *TclLookupVar _ANSI_ARGS_((Tcl_Interp *interp, CONST char *part1,
|
---|
| 311 | CONST char *part2, int flags, char *mesg, int p1Flags, int p2Flags,
|
---|
| 312 | Var ** varPtrPtr));
|
---|
| 313 |
|
---|
| 314 | #define VAR_SCALAR 0x1
|
---|
| 315 | #define VAR_ARRAY 0x2
|
---|
| 316 | #define VAR_LINK 0x4
|
---|
| 317 | #define VAR_UNDEFINED 0x8
|
---|
| 318 | #define VAR_IN_HASHTABLE 0x10
|
---|
| 319 | #define VAR_TRACE_ACTIVE 0x20
|
---|
| 320 | #define VAR_ARRAY_ELEMENT 0x40
|
---|
| 321 | #define VAR_NAMESPACE_VAR 0x80
|
---|
| 322 |
|
---|
| 323 | #define VAR_ARGUMENT 0x100
|
---|
| 324 | #define VAR_TEMPORARY 0x200
|
---|
| 325 | #define VAR_RESOLVED 0x400
|
---|
| 326 |
|
---|
| 327 |
|
---|
| 328 | Tcl_HashTable *
|
---|
| 329 | Blt_GetArrayVariableTable(interp, varName, flags)
|
---|
| 330 | Tcl_Interp *interp;
|
---|
| 331 | CONST char *varName;
|
---|
| 332 | int flags;
|
---|
| 333 | {
|
---|
| 334 | Var *varPtr, *arrayPtr;
|
---|
| 335 |
|
---|
| 336 | varPtr = TclLookupVar(interp, varName, (char *)NULL, flags, "read",
|
---|
| 337 | FALSE, FALSE, &arrayPtr);
|
---|
| 338 | if ((varPtr == NULL) || ((varPtr->flags & VAR_ARRAY) == 0)) {
|
---|
| 339 | return NULL;
|
---|
| 340 | }
|
---|
| 341 | return varPtr->value.tablePtr;
|
---|
| 342 | }
|
---|
| 343 |
|
---|
| 344 | Tcl_Namespace *
|
---|
| 345 | Blt_GetVariableNamespace(interp, name)
|
---|
| 346 | Tcl_Interp *interp;
|
---|
| 347 | CONST char *name;
|
---|
| 348 | {
|
---|
| 349 | Var *varPtr;
|
---|
| 350 |
|
---|
| 351 | varPtr = (Var *)Tcl_FindNamespaceVar(interp, (char *)name,
|
---|
| 352 | (Tcl_Namespace *)NULL, 0);
|
---|
| 353 | if (varPtr == NULL) {
|
---|
| 354 | return NULL;
|
---|
| 355 | }
|
---|
| 356 | return varPtr->nsPtr;
|
---|
| 357 | }
|
---|
| 358 |
|
---|
| 359 | /*ARGSUSED*/
|
---|
| 360 | Tcl_Namespace *
|
---|
| 361 | Blt_GetCommandNamespace(interp, cmdToken)
|
---|
| 362 | Tcl_Interp *interp; /* Not used. */
|
---|
| 363 | Tcl_Command cmdToken;
|
---|
| 364 | {
|
---|
| 365 | Command *cmdPtr = (Command *)cmdToken;
|
---|
| 366 |
|
---|
| 367 | return (Tcl_Namespace *)cmdPtr->nsPtr;
|
---|
| 368 | }
|
---|
| 369 |
|
---|
| 370 | Tcl_CallFrame *
|
---|
| 371 | Blt_EnterNamespace(interp, nsPtr)
|
---|
| 372 | Tcl_Interp *interp;
|
---|
| 373 | Tcl_Namespace *nsPtr;
|
---|
| 374 | {
|
---|
| 375 | Tcl_CallFrame *framePtr;
|
---|
| 376 |
|
---|
| 377 | framePtr = Blt_Malloc(sizeof(Tcl_CallFrame));
|
---|
| 378 | assert(framePtr);
|
---|
| 379 | if (Tcl_PushCallFrame(interp, framePtr, (Tcl_Namespace *)nsPtr, 0)
|
---|
| 380 | != TCL_OK) {
|
---|
| 381 | Blt_Free(framePtr);
|
---|
| 382 | return NULL;
|
---|
| 383 | }
|
---|
| 384 | return framePtr;
|
---|
| 385 | }
|
---|
| 386 |
|
---|
| 387 | void
|
---|
| 388 | Blt_LeaveNamespace(interp, framePtr)
|
---|
| 389 | Tcl_Interp *interp;
|
---|
| 390 | Tcl_CallFrame *framePtr;
|
---|
| 391 | {
|
---|
| 392 | Tcl_PopCallFrame(interp);
|
---|
| 393 | Blt_Free(framePtr);
|
---|
| 394 | }
|
---|
| 395 |
|
---|
| 396 | #endif /* TCL_MAJOR_VERSION == 7 */
|
---|
| 397 |
|
---|
| 398 | int
|
---|
| 399 | Blt_ParseQualifiedName(interp, qualName, nsPtrPtr, namePtrPtr)
|
---|
| 400 | Tcl_Interp *interp;
|
---|
| 401 | CONST char *qualName;
|
---|
| 402 | Tcl_Namespace **nsPtrPtr;
|
---|
| 403 | CONST char **namePtrPtr;
|
---|
| 404 | {
|
---|
| 405 | register char *p, *colon;
|
---|
| 406 | Tcl_Namespace *nsPtr;
|
---|
| 407 |
|
---|
| 408 | colon = NULL;
|
---|
| 409 | p = (char *)(qualName + strlen(qualName));
|
---|
| 410 | while (--p > qualName) {
|
---|
| 411 | if ((*p == ':') && (*(p - 1) == ':')) {
|
---|
| 412 | p++; /* just after the last "::" */
|
---|
| 413 | colon = p - 2;
|
---|
| 414 | break;
|
---|
| 415 | }
|
---|
| 416 | }
|
---|
| 417 | if (colon == NULL) {
|
---|
| 418 | *nsPtrPtr = NULL;
|
---|
| 419 | *namePtrPtr = (char *)qualName;
|
---|
| 420 | return TCL_OK;
|
---|
| 421 | }
|
---|
| 422 | *colon = '\0';
|
---|
| 423 | if (qualName[0] == '\0') {
|
---|
| 424 | nsPtr = Tcl_GetGlobalNamespace(interp);
|
---|
| 425 | } else {
|
---|
| 426 | nsPtr = Tcl_FindNamespace(interp, (char *)qualName,
|
---|
| 427 | (Tcl_Namespace *)NULL, 0);
|
---|
| 428 | }
|
---|
| 429 | *colon = ':';
|
---|
| 430 | if (nsPtr == NULL) {
|
---|
| 431 | return TCL_ERROR;
|
---|
| 432 | }
|
---|
| 433 | *nsPtrPtr = nsPtr;
|
---|
| 434 | *namePtrPtr = p;
|
---|
| 435 | return TCL_OK;
|
---|
| 436 | }
|
---|
| 437 |
|
---|
| 438 | char *
|
---|
| 439 | Blt_GetQualifiedName(nsPtr, name, resultPtr)
|
---|
| 440 | Tcl_Namespace *nsPtr;
|
---|
| 441 | CONST char *name;
|
---|
| 442 | Tcl_DString *resultPtr;
|
---|
| 443 | {
|
---|
| 444 | Tcl_DStringInit(resultPtr);
|
---|
| 445 | #if (TCL_MAJOR_VERSION > 7)
|
---|
| 446 | if ((nsPtr->fullName[0] != ':') || (nsPtr->fullName[1] != ':') ||
|
---|
| 447 | (nsPtr->fullName[2] != '\0')) {
|
---|
| 448 | Tcl_DStringAppend(resultPtr, nsPtr->fullName, -1);
|
---|
| 449 | }
|
---|
| 450 | #endif
|
---|
| 451 | Tcl_DStringAppend(resultPtr, "::", -1);
|
---|
| 452 | Tcl_DStringAppend(resultPtr, (char *)name, -1);
|
---|
| 453 | return Tcl_DStringValue(resultPtr);
|
---|
| 454 | }
|
---|
| 455 |
|
---|
| 456 |
|
---|
| 457 | #if (TCL_MAJOR_VERSION > 7)
|
---|
| 458 |
|
---|
| 459 | typedef struct {
|
---|
| 460 | Tcl_HashTable clientTable;
|
---|
| 461 |
|
---|
| 462 | /* Original clientdata and delete procedure. */
|
---|
| 463 | ClientData origClientData;
|
---|
| 464 | Tcl_NamespaceDeleteProc *origDeleteProc;
|
---|
| 465 |
|
---|
| 466 | } Callback;
|
---|
| 467 |
|
---|
| 468 | static Tcl_CmdProc NamespaceDeleteCmd;
|
---|
| 469 | static Tcl_NamespaceDeleteProc NamespaceDeleteNotify;
|
---|
| 470 |
|
---|
| 471 | #define NS_DELETE_CMD "#NamespaceDeleteNotifier"
|
---|
| 472 |
|
---|
| 473 | /*ARGSUSED*/
|
---|
| 474 | static int
|
---|
| 475 | NamespaceDeleteCmd(clientData, interp, argc, argv)
|
---|
| 476 | ClientData clientData; /* Not used. */
|
---|
| 477 | Tcl_Interp *interp; /* */
|
---|
| 478 | int argc;
|
---|
| 479 | char **argv;
|
---|
| 480 | {
|
---|
| 481 | Tcl_AppendResult(interp, "command \"", argv[0], "\" shouldn't be invoked",
|
---|
| 482 | (char *)NULL);
|
---|
| 483 | return TCL_ERROR;
|
---|
| 484 | }
|
---|
| 485 |
|
---|
| 486 | static void
|
---|
| 487 | NamespaceDeleteNotify(clientData)
|
---|
| 488 | ClientData clientData;
|
---|
| 489 | {
|
---|
| 490 | Blt_List list;
|
---|
| 491 | Blt_ListNode node;
|
---|
| 492 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 493 |
|
---|
| 494 | list = (Blt_List)clientData;
|
---|
| 495 | for (node = Blt_ListFirstNode(list); node != NULL;
|
---|
| 496 | node = Blt_ListNextNode(node)) {
|
---|
| 497 | deleteProc = (Tcl_CmdDeleteProc *)Blt_ListGetValue(node);
|
---|
| 498 | clientData = (ClientData)Blt_ListGetKey(node);
|
---|
| 499 | (*deleteProc) (clientData);
|
---|
| 500 | }
|
---|
| 501 | Blt_ListDestroy(list);
|
---|
| 502 | }
|
---|
| 503 |
|
---|
| 504 | void
|
---|
| 505 | Blt_DestroyNsDeleteNotify(interp, nsPtr, clientData)
|
---|
| 506 | Tcl_Interp *interp;
|
---|
| 507 | Tcl_Namespace *nsPtr;
|
---|
| 508 | ClientData clientData;
|
---|
| 509 | {
|
---|
| 510 | Blt_List list;
|
---|
| 511 | Blt_ListNode node;
|
---|
| 512 | char *string;
|
---|
| 513 | Tcl_CmdInfo cmdInfo;
|
---|
| 514 |
|
---|
| 515 | string = Blt_Malloc(sizeof(nsPtr->fullName) + strlen(NS_DELETE_CMD) + 4);
|
---|
| 516 | strcpy(string, nsPtr->fullName);
|
---|
| 517 | strcat(string, "::");
|
---|
| 518 | strcat(string, NS_DELETE_CMD);
|
---|
| 519 | if (!Tcl_GetCommandInfo(interp, string, &cmdInfo)) {
|
---|
| 520 | goto done;
|
---|
| 521 | }
|
---|
| 522 | list = (Blt_List)cmdInfo.clientData;
|
---|
| 523 | node = Blt_ListGetNode(list, clientData);
|
---|
| 524 | if (node != NULL) {
|
---|
| 525 | Blt_ListDeleteNode(node);
|
---|
| 526 | }
|
---|
| 527 | done:
|
---|
| 528 | Blt_Free(string);
|
---|
| 529 | }
|
---|
| 530 |
|
---|
| 531 | int
|
---|
| 532 | Blt_CreateNsDeleteNotify(interp, nsPtr, clientData, deleteProc)
|
---|
| 533 | Tcl_Interp *interp;
|
---|
| 534 | Tcl_Namespace *nsPtr;
|
---|
| 535 | ClientData clientData;
|
---|
| 536 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 537 | {
|
---|
| 538 | Blt_List list;
|
---|
| 539 | char *string;
|
---|
| 540 | Tcl_CmdInfo cmdInfo;
|
---|
| 541 |
|
---|
| 542 | string = Blt_Malloc(sizeof(nsPtr->fullName) + strlen(NS_DELETE_CMD) + 4);
|
---|
| 543 | strcpy(string, nsPtr->fullName);
|
---|
| 544 | strcat(string, "::");
|
---|
| 545 | strcat(string, NS_DELETE_CMD);
|
---|
| 546 | if (!Tcl_GetCommandInfo(interp, string, &cmdInfo)) {
|
---|
| 547 | list = Blt_ListCreate(BLT_ONE_WORD_KEYS);
|
---|
| 548 | Blt_CreateCommand(interp, string, NamespaceDeleteCmd, list,
|
---|
| 549 | NamespaceDeleteNotify);
|
---|
| 550 | } else {
|
---|
| 551 | list = (Blt_List)cmdInfo.clientData;
|
---|
| 552 | }
|
---|
| 553 | Blt_Free(string);
|
---|
| 554 | Blt_ListAppend(list, clientData, (ClientData)deleteProc);
|
---|
| 555 | return TCL_OK;
|
---|
| 556 | }
|
---|
| 557 |
|
---|
| 558 | #endif /* TCL_MAJOR_VERSION > 7 */
|
---|
| 559 |
|
---|
| 560 | #if (TCL_VERSION_NUMBER < _VERSION(8,0,0))
|
---|
| 561 |
|
---|
| 562 | /*
|
---|
| 563 | *----------------------------------------------------------------------
|
---|
| 564 | *
|
---|
| 565 | * Blt_CreateCommand --
|
---|
| 566 | *
|
---|
| 567 | * Like Tcl_CreateCommand, but creates command in current namespace
|
---|
| 568 | * instead of global, if one isn't defined. Not a problem with
|
---|
| 569 | * [incr Tcl] namespaces.
|
---|
| 570 | *
|
---|
| 571 | * Results:
|
---|
| 572 | * The return value is a token for the command, which can
|
---|
| 573 | * be used in future calls to Tcl_GetCommandName.
|
---|
| 574 | *
|
---|
| 575 | *----------------------------------------------------------------------
|
---|
| 576 | */
|
---|
| 577 | Tcl_Command
|
---|
| 578 | Blt_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
|
---|
| 579 | Tcl_Interp *interp; /* Token for command interpreter returned by
|
---|
| 580 | * a previous call to Tcl_CreateInterp. */
|
---|
| 581 | CONST char *cmdName; /* Name of command. If it contains namespace
|
---|
| 582 | * qualifiers, the new command is put in the
|
---|
| 583 | * specified namespace; otherwise it is put
|
---|
| 584 | * in the global namespace. */
|
---|
| 585 | Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
|
---|
| 586 | ClientData clientData; /* Arbitrary value passed to string proc. */
|
---|
| 587 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 588 | /* If not NULL, gives a procedure to call
|
---|
| 589 | * when this command is deleted. */
|
---|
| 590 | {
|
---|
| 591 | return Tcl_CreateCommand(interp, (char *)cmdName, proc, clientData,
|
---|
| 592 | deleteProc);
|
---|
| 593 | }
|
---|
| 594 |
|
---|
| 595 | /*ARGSUSED*/
|
---|
| 596 | Tcl_Command
|
---|
| 597 | Tcl_FindCommand(interp, cmdName, nsPtr, flags)
|
---|
| 598 | Tcl_Interp *interp;
|
---|
| 599 | char *cmdName;
|
---|
| 600 | Tcl_Namespace *nsPtr; /* Not used. */
|
---|
| 601 | int flags; /* Not used. */
|
---|
| 602 | {
|
---|
| 603 | Tcl_HashEntry *hPtr;
|
---|
| 604 | TclInterp *iPtr = (TclInterp *) interp;
|
---|
| 605 |
|
---|
| 606 | hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
|
---|
| 607 | if (hPtr == NULL) {
|
---|
| 608 | return NULL;
|
---|
| 609 | }
|
---|
| 610 | return (Tcl_Command) Tcl_GetHashValue(hPtr);
|
---|
| 611 | }
|
---|
| 612 |
|
---|
| 613 | #endif /* TCL_MAJOR_VERSION <= 7 */
|
---|
| 614 |
|
---|
| 615 | #if (TCL_VERSION_NUMBER >= _VERSION(8,0,0))
|
---|
| 616 | /*
|
---|
| 617 | *----------------------------------------------------------------------
|
---|
| 618 | *
|
---|
| 619 | * Blt_CreateCommand --
|
---|
| 620 | *
|
---|
| 621 | * Like Tcl_CreateCommand, but creates command in current namespace
|
---|
| 622 | * instead of global, if one isn't defined. Not a problem with
|
---|
| 623 | * [incr Tcl] namespaces.
|
---|
| 624 | *
|
---|
| 625 | * Results:
|
---|
| 626 | * The return value is a token for the command, which can
|
---|
| 627 | * be used in future calls to Tcl_GetCommandName.
|
---|
| 628 | *
|
---|
| 629 | *----------------------------------------------------------------------
|
---|
| 630 | */
|
---|
| 631 | Tcl_Command
|
---|
| 632 | Blt_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
|
---|
| 633 | Tcl_Interp *interp; /* Token for command interpreter returned by
|
---|
| 634 | * a previous call to Tcl_CreateInterp. */
|
---|
| 635 | CONST char *cmdName; /* Name of command. If it contains namespace
|
---|
| 636 | * qualifiers, the new command is put in the
|
---|
| 637 | * specified namespace; otherwise it is put
|
---|
| 638 | * in the global namespace. */
|
---|
| 639 | Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
|
---|
| 640 | ClientData clientData; /* Arbitrary value passed to string proc. */
|
---|
| 641 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 642 | /* If not NULL, gives a procedure to call
|
---|
| 643 |
|
---|
| 644 | * when this command is deleted. */
|
---|
| 645 | {
|
---|
| 646 | register CONST char *p;
|
---|
| 647 |
|
---|
| 648 | p = cmdName + strlen(cmdName);
|
---|
| 649 | while (--p > cmdName) {
|
---|
| 650 | if ((*p == ':') && (*(p - 1) == ':')) {
|
---|
| 651 | p++; /* just after the last "::" */
|
---|
| 652 | break;
|
---|
| 653 | }
|
---|
| 654 | }
|
---|
| 655 | if (cmdName == p) {
|
---|
| 656 | Tcl_DString dString;
|
---|
| 657 | Tcl_Namespace *nsPtr;
|
---|
| 658 | Tcl_Command cmdToken;
|
---|
| 659 |
|
---|
| 660 | Tcl_DStringInit(&dString);
|
---|
| 661 | nsPtr = Tcl_GetCurrentNamespace(interp);
|
---|
| 662 | Tcl_DStringAppend(&dString, nsPtr->fullName, -1);
|
---|
| 663 | Tcl_DStringAppend(&dString, "::", -1);
|
---|
| 664 | Tcl_DStringAppend(&dString, cmdName, -1);
|
---|
| 665 | cmdToken = Tcl_CreateCommand(interp, Tcl_DStringValue(&dString), proc,
|
---|
| 666 | clientData, deleteProc);
|
---|
| 667 | Tcl_DStringFree(&dString);
|
---|
| 668 | return cmdToken;
|
---|
| 669 | }
|
---|
| 670 | return Tcl_CreateCommand(interp, (char *)cmdName, proc, clientData,
|
---|
| 671 | deleteProc);
|
---|
| 672 | }
|
---|
| 673 |
|
---|
| 674 | /*
|
---|
| 675 | *----------------------------------------------------------------------
|
---|
| 676 | *
|
---|
| 677 | * Blt_CreateCommandObj --
|
---|
| 678 | *
|
---|
| 679 | * Like Tcl_CreateCommand, but creates command in current namespace
|
---|
| 680 | * instead of global, if one isn't defined. Not a problem with
|
---|
| 681 | * [incr Tcl] namespaces.
|
---|
| 682 | *
|
---|
| 683 | * Results:
|
---|
| 684 | * The return value is a token for the command, which can
|
---|
| 685 | * be used in future calls to Tcl_GetCommandName.
|
---|
| 686 | *
|
---|
| 687 | *----------------------------------------------------------------------
|
---|
| 688 | */
|
---|
| 689 | Tcl_Command
|
---|
| 690 | Blt_CreateCommandObj(interp, cmdName, proc, clientData, deleteProc)
|
---|
| 691 | Tcl_Interp *interp; /* Token for command interpreter returned by
|
---|
| 692 | * a previous call to Tcl_CreateInterp. */
|
---|
| 693 | CONST char *cmdName; /* Name of command. If it contains namespace
|
---|
| 694 | * qualifiers, the new command is put in the
|
---|
| 695 | * specified namespace; otherwise it is put
|
---|
| 696 | * in the global namespace. */
|
---|
| 697 | Tcl_ObjCmdProc *proc; /* Procedure to associate with cmdName. */
|
---|
| 698 | ClientData clientData; /* Arbitrary value passed to string proc. */
|
---|
| 699 | Tcl_CmdDeleteProc *deleteProc;
|
---|
| 700 | /* If not NULL, gives a procedure to call
|
---|
| 701 | * when this command is deleted. */
|
---|
| 702 | {
|
---|
| 703 | register CONST char *p;
|
---|
| 704 |
|
---|
| 705 | p = cmdName + strlen(cmdName);
|
---|
| 706 | while (--p > cmdName) {
|
---|
| 707 | if ((*p == ':') && (*(p - 1) == ':')) {
|
---|
| 708 | p++; /* just after the last "::" */
|
---|
| 709 | break;
|
---|
| 710 | }
|
---|
| 711 | }
|
---|
| 712 | if (cmdName == p) {
|
---|
| 713 | Tcl_DString dString;
|
---|
| 714 | Tcl_Namespace *nsPtr;
|
---|
| 715 | Tcl_Command cmdToken;
|
---|
| 716 |
|
---|
| 717 | Tcl_DStringInit(&dString);
|
---|
| 718 | nsPtr = Tcl_GetCurrentNamespace(interp);
|
---|
| 719 | Tcl_DStringAppend(&dString, nsPtr->fullName, -1);
|
---|
| 720 | Tcl_DStringAppend(&dString, "::", -1);
|
---|
| 721 | Tcl_DStringAppend(&dString, cmdName, -1);
|
---|
| 722 | cmdToken = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&dString),
|
---|
| 723 | proc, clientData, deleteProc);
|
---|
| 724 | Tcl_DStringFree(&dString);
|
---|
| 725 | return cmdToken;
|
---|
| 726 | }
|
---|
| 727 | return Tcl_CreateObjCommand(interp, (char *)cmdName, proc, clientData,
|
---|
| 728 | deleteProc);
|
---|
| 729 | }
|
---|
| 730 | #endif /* TCL_VERSION_NUMBER < 8.0.0 */
|
---|