util/src/TclTk/tcl8.6.12/generic/tclOOBasic.c

   1 /*
   2  * tclOOBasic.c --
   3  *
   4  *      This file contains implementations of the "simple" commands and
   5  *      methods from the object-system core.
   6  *
   7  * Copyright (c) 2005-2013 by Donal K. Fellows
   8  *
   9  * See the file "license.terms" for information on usage and redistribution of
  10  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  */
  12
  13 #ifdef HAVE_CONFIG_H
  14 #include "config.h"
  15 #endif
  16 #include "tclInt.h"
  17 #include "tclOOInt.h"
  18
  19 static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp);
  20 static Tcl_NRPostProc   AfterNRDestructor;
  21 static Tcl_NRPostProc   DecrRefsPostClassConstructor;
  22 static Tcl_NRPostProc   FinalizeConstruction;
  23 static Tcl_NRPostProc   FinalizeEval;
  24 static Tcl_NRPostProc   NextRestoreFrame;
  25 \f
  26 /*
  27  * ----------------------------------------------------------------------
  28  *
  29  * AddCreateCallback, FinalizeConstruction --
  30  *
  31  *      Special version of TclNRAddCallback that allows the caller to splice
  32  *      the object created later on. Always calls FinalizeConstruction, which
  33  *      converts the object into its name and stores that in the interpreter
  34  *      result. This is shared by all the construction methods (create,
  35  *      createWithNamespace, new).
  36  *
  37  *      Note that this is the only code in this file (or, indeed, the whole of
  38  *      TclOO) that uses NRE internals; it is the only code that does
  39  *      non-standard poking in the NRE guts.
  40  *
  41  * ----------------------------------------------------------------------
  42  */
  43
  44 static inline Tcl_Object *
  45 AddConstructionFinalizer(
  46     Tcl_Interp *interp)
  47 {
  48     TclNRAddCallback(interp, FinalizeConstruction, NULL, NULL, NULL, NULL);
  49     return (Tcl_Object *) &(TOP_CB(interp)->data[0]);
  50 }
  51
  52 static int
  53 FinalizeConstruction(
  54     ClientData data[],
  55     Tcl_Interp *interp,
  56     int result)
  57 {
  58     Object *oPtr = data[0];
  59
  60     if (result != TCL_OK) {
  61         return result;
  62     }
  63     Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
  64     return TCL_OK;
  65 }
  66 \f
  67 /*
  68  * ----------------------------------------------------------------------
  69  *
  70  * TclOO_Class_Constructor --
  71  *
  72  *      Implementation for oo::class constructor.
  73  *
  74  * ----------------------------------------------------------------------
  75  */
  76
  77 int
  78 TclOO_Class_Constructor(
  79     ClientData clientData,
  80     Tcl_Interp *interp,
  81     Tcl_ObjectContext context,
  82     int objc,
  83     Tcl_Obj *const *objv)
  84 {
  85     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
  86     Tcl_Obj **invoke;
  87
  88     if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
  89         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
  90                 "?definitionScript?");
  91         return TCL_ERROR;
  92     } else if (objc == Tcl_ObjectContextSkippedArgs(context)) {
  93         return TCL_OK;
  94     }
  95
  96     /*
  97      * Delegate to [oo::define] to do the work.
  98      */
  99
 100     invoke = ckalloc(3 * sizeof(Tcl_Obj *));
 101     invoke[0] = oPtr->fPtr->defineName;
 102     invoke[1] = TclOOObjectName(interp, oPtr);
 103     invoke[2] = objv[objc-1];
 104
 105     /*
 106      * Must add references or errors in configuration script will cause
 107      * trouble.
 108      */
 109
 110     Tcl_IncrRefCount(invoke[0]);
 111     Tcl_IncrRefCount(invoke[1]);
 112     Tcl_IncrRefCount(invoke[2]);
 113     TclNRAddCallback(interp, DecrRefsPostClassConstructor,
 114             invoke, NULL, NULL, NULL);
 115
 116     /*
 117      * Tricky point: do not want the extra reported level in the Tcl stack
 118      * trace, so use TCL_EVAL_NOERR.
 119      */
 120
 121     return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL);
 122 }
 123
 124 static int
 125 DecrRefsPostClassConstructor(
 126     ClientData data[],
 127     Tcl_Interp *interp,
 128     int result)
 129 {
 130     Tcl_Obj **invoke = data[0];
 131
 132     TclDecrRefCount(invoke[0]);
 133     TclDecrRefCount(invoke[1]);
 134     TclDecrRefCount(invoke[2]);
 135     ckfree(invoke);
 136     return result;
 137 }
 138 \f
 139 /*
 140  * ----------------------------------------------------------------------
 141  *
 142  * TclOO_Class_Create --
 143  *
 144  *      Implementation for oo::class->create method.
 145  *
 146  * ----------------------------------------------------------------------
 147  */
 148
 149 int
 150 TclOO_Class_Create(
 151     ClientData clientData,      /* Ignored. */
 152     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 153                                  * also used for error reporting. */
 154     Tcl_ObjectContext context,  /* The object/call context. */
 155     int objc,                   /* Number of arguments. */
 156     Tcl_Obj *const *objv)       /* The actual arguments. */
 157 {
 158     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
 159     const char *objName;
 160     int len;
 161
 162     /*
 163      * Sanity check; should not be possible to invoke this method on a
 164      * non-class.
 165      */
 166
 167     if (oPtr->classPtr == NULL) {
 168         Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 169
 170         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 171                 "object \"%s\" is not a class", TclGetString(cmdnameObj)));
 172         Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 173         return TCL_ERROR;
 174     }
 175
 176     /*
 177      * Check we have the right number of (sensible) arguments.
 178      */
 179
 180     if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
 181         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 182                 "objectName ?arg ...?");
 183         return TCL_ERROR;
 184     }
 185     objName = Tcl_GetStringFromObj(
 186             objv[Tcl_ObjectContextSkippedArgs(context)], &len);
 187     if (len == 0) {
 188         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 189                 "object name must not be empty", -1));
 190         Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 191         return TCL_ERROR;
 192     }
 193
 194     /*
 195      * Make the object and return its name.
 196      */
 197
 198     return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
 199             objName, NULL, objc, objv,
 200             Tcl_ObjectContextSkippedArgs(context)+1,
 201             AddConstructionFinalizer(interp));
 202 }
 203 \f
 204 /*
 205  * ----------------------------------------------------------------------
 206  *
 207  * TclOO_Class_CreateNs --
 208  *
 209  *      Implementation for oo::class->createWithNamespace method.
 210  *
 211  * ----------------------------------------------------------------------
 212  */
 213
 214 int
 215 TclOO_Class_CreateNs(
 216     ClientData clientData,      /* Ignored. */
 217     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 218                                  * also used for error reporting. */
 219     Tcl_ObjectContext context,  /* The object/call context. */
 220     int objc,                   /* Number of arguments. */
 221     Tcl_Obj *const *objv)       /* The actual arguments. */
 222 {
 223     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
 224     const char *objName, *nsName;
 225     int len;
 226
 227     /*
 228      * Sanity check; should not be possible to invoke this method on a
 229      * non-class.
 230      */
 231
 232     if (oPtr->classPtr == NULL) {
 233         Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 234
 235         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 236                 "object \"%s\" is not a class", TclGetString(cmdnameObj)));
 237         Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 238         return TCL_ERROR;
 239     }
 240
 241     /*
 242      * Check we have the right number of (sensible) arguments.
 243      */
 244
 245     if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
 246         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 247                 "objectName namespaceName ?arg ...?");
 248         return TCL_ERROR;
 249     }
 250     objName = Tcl_GetStringFromObj(
 251             objv[Tcl_ObjectContextSkippedArgs(context)], &len);
 252     if (len == 0) {
 253         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 254                 "object name must not be empty", -1));
 255         Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 256         return TCL_ERROR;
 257     }
 258     nsName = Tcl_GetStringFromObj(
 259             objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
 260     if (len == 0) {
 261         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 262                 "namespace name must not be empty", -1));
 263         Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
 264         return TCL_ERROR;
 265     }
 266
 267     /*
 268      * Make the object and return its name.
 269      */
 270
 271     return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
 272             objName, nsName, objc, objv,
 273             Tcl_ObjectContextSkippedArgs(context)+2,
 274             AddConstructionFinalizer(interp));
 275 }
 276 \f
 277 /*
 278  * ----------------------------------------------------------------------
 279  *
 280  * TclOO_Class_New --
 281  *
 282  *      Implementation for oo::class->new method.
 283  *
 284  * ----------------------------------------------------------------------
 285  */
 286
 287 int
 288 TclOO_Class_New(
 289     ClientData clientData,      /* Ignored. */
 290     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 291                                  * also used for error reporting. */
 292     Tcl_ObjectContext context,  /* The object/call context. */
 293     int objc,                   /* Number of arguments. */
 294     Tcl_Obj *const *objv)       /* The actual arguments. */
 295 {
 296     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
 297
 298     /*
 299      * Sanity check; should not be possible to invoke this method on a
 300      * non-class.
 301      */
 302
 303     if (oPtr->classPtr == NULL) {
 304         Tcl_Obj *cmdnameObj = TclOOObjectName(interp, oPtr);
 305
 306         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 307                 "object \"%s\" is not a class", TclGetString(cmdnameObj)));
 308         Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 309         return TCL_ERROR;
 310     }
 311
 312     /*
 313      * Make the object and return its name.
 314      */
 315
 316     return TclNRNewObjectInstance(interp, (Tcl_Class) oPtr->classPtr,
 317             NULL, NULL, objc, objv, Tcl_ObjectContextSkippedArgs(context),
 318             AddConstructionFinalizer(interp));
 319 }
 320 \f
 321 /*
 322  * ----------------------------------------------------------------------
 323  *
 324  * TclOO_Object_Destroy --
 325  *
 326  *      Implementation for oo::object->destroy method.
 327  *
 328  * ----------------------------------------------------------------------
 329  */
 330
 331 int
 332 TclOO_Object_Destroy(
 333     ClientData clientData,      /* Ignored. */
 334     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 335                                  * also used for error reporting. */
 336     Tcl_ObjectContext context,  /* The object/call context. */
 337     int objc,                   /* Number of arguments. */
 338     Tcl_Obj *const *objv)       /* The actual arguments. */
 339 {
 340     Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
 341     CallContext *contextPtr;
 342
 343     if (objc != Tcl_ObjectContextSkippedArgs(context)) {
 344         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 345                 NULL);
 346         return TCL_ERROR;
 347     }
 348     if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
 349         oPtr->flags |= DESTRUCTOR_CALLED;
 350         contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
 351         if (contextPtr != NULL) {
 352             contextPtr->callPtr->flags |= DESTRUCTOR;
 353             contextPtr->skip = 0;
 354             TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
 355                     NULL, NULL, NULL);
 356             TclPushTailcallPoint(interp);
 357             return TclOOInvokeContext(contextPtr, interp, 0, NULL);
 358         }
 359     }
 360     if (oPtr->command) {
 361         Tcl_DeleteCommandFromToken(interp, oPtr->command);
 362     }
 363     return TCL_OK;
 364 }
 365
 366 static int
 367 AfterNRDestructor(
 368     ClientData data[],
 369     Tcl_Interp *interp,
 370     int result)
 371 {
 372     CallContext *contextPtr = data[0];
 373
 374     if (contextPtr->oPtr->command) {
 375         Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
 376     }
 377     TclOODeleteContext(contextPtr);
 378     return result;
 379 }
 380 \f
 381 /*
 382  * ----------------------------------------------------------------------
 383  *
 384  * TclOO_Object_Eval --
 385  *
 386  *      Implementation for oo::object->eval method.
 387  *
 388  * ----------------------------------------------------------------------
 389  */
 390
 391 int
 392 TclOO_Object_Eval(
 393     ClientData clientData,      /* Ignored. */
 394     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 395                                  * also used for error reporting. */
 396     Tcl_ObjectContext context,  /* The object/call context. */
 397     int objc,                   /* Number of arguments. */
 398     Tcl_Obj *const *objv)       /* The actual arguments. */
 399 {
 400     CallContext *contextPtr = (CallContext *) context;
 401     Tcl_Object object = Tcl_ObjectContextObject(context);
 402     const int skip = Tcl_ObjectContextSkippedArgs(context);
 403     CallFrame *framePtr, **framePtrPtr = &framePtr;
 404     Tcl_Obj *scriptPtr;
 405     CmdFrame *invoker;
 406
 407     if (objc-1 < skip) {
 408         Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
 409         return TCL_ERROR;
 410     }
 411
 412     /*
 413      * Make the object's namespace the current namespace and evaluate the
 414      * command(s).
 415      */
 416
 417     (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
 418             Tcl_GetObjectNamespace(object), 0);
 419     framePtr->objc = objc;
 420     framePtr->objv = objv;      /* Reference counts do not need to be
 421                                  * incremented here. */
 422
 423     if (!(contextPtr->callPtr->flags & PUBLIC_METHOD)) {
 424         object = NULL;          /* Now just for error mesage printing. */
 425     }
 426
 427     /*
 428      * Work out what script we are actually going to evaluate.
 429      *
 430      * When there's more than one argument, we concatenate them together with
 431      * spaces between, then evaluate the result. Tcl_EvalObjEx will delete the
 432      * object when it decrements its refcount after eval'ing it.
 433      */
 434
 435     if (objc != skip+1) {
 436         scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip);
 437         invoker = NULL;
 438     } else {
 439         scriptPtr = objv[skip];
 440         invoker = ((Interp *) interp)->cmdFramePtr;
 441     }
 442
 443     /*
 444      * Evaluate the script now, with FinalizeEval to do the processing after
 445      * the script completes.
 446      */
 447
 448     TclNRAddCallback(interp, FinalizeEval, object, NULL, NULL, NULL);
 449     return TclNREvalObjEx(interp, scriptPtr, 0, invoker, skip);
 450 }
 451
 452 static int
 453 FinalizeEval(
 454     ClientData data[],
 455     Tcl_Interp *interp,
 456     int result)
 457 {
 458     if (result == TCL_ERROR) {
 459         Object *oPtr = data[0];
 460         const char *namePtr;
 461
 462         if (oPtr) {
 463             namePtr = TclGetString(TclOOObjectName(interp, oPtr));
 464         } else {
 465             namePtr = "my";
 466         }
 467
 468         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 469                 "\n    (in \"%s eval\" script line %d)",
 470                 namePtr, Tcl_GetErrorLine(interp)));
 471     }
 472
 473     /*
 474      * Restore the previous "current" namespace.
 475      */
 476
 477     TclPopStackFrame(interp);
 478     return result;
 479 }
 480 \f
 481 /*
 482  * ----------------------------------------------------------------------
 483  *
 484  * TclOO_Object_Unknown --
 485  *
 486  *      Default unknown method handler method (defined in oo::object). This
 487  *      just creates a suitable error message.
 488  *
 489  * ----------------------------------------------------------------------
 490  */
 491
 492 int
 493 TclOO_Object_Unknown(
 494     ClientData clientData,      /* Ignored. */
 495     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 496                                  * also used for error reporting. */
 497     Tcl_ObjectContext context,  /* The object/call context. */
 498     int objc,                   /* Number of arguments. */
 499     Tcl_Obj *const *objv)       /* The actual arguments. */
 500 {
 501     CallContext *contextPtr = (CallContext *) context;
 502     Object *oPtr = contextPtr->oPtr;
 503     const char **methodNames;
 504     int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
 505     Tcl_Obj *errorMsg;
 506
 507     /*
 508      * If no method name, generate an error asking for a method name. (Only by
 509      * overriding *this* method can an object handle the absence of a method
 510      * name without an error).
 511      */
 512
 513     if (objc < skip+1) {
 514         Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
 515         return TCL_ERROR;
 516     }
 517
 518     /*
 519      * Get the list of methods that we want to know about.
 520      */
 521
 522     numMethodNames = TclOOGetSortedMethodList(oPtr,
 523             contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
 524
 525     /*
 526      * Special message when there are no visible methods at all.
 527      */
 528
 529     if (numMethodNames == 0) {
 530         Tcl_Obj *tmpBuf = TclOOObjectName(interp, oPtr);
 531         const char *piece;
 532
 533         if (contextPtr->callPtr->flags & PUBLIC_METHOD) {
 534             piece = "visible methods";
 535         } else {
 536             piece = "methods";
 537         }
 538         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 539                 "object \"%s\" has no %s", TclGetString(tmpBuf), piece));
 540         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 541                 TclGetString(objv[skip]), NULL);
 542         return TCL_ERROR;
 543     }
 544
 545     errorMsg = Tcl_ObjPrintf("unknown method \"%s\": must be ",
 546             TclGetString(objv[skip]));
 547     for (i=0 ; i<numMethodNames-1 ; i++) {
 548         if (i) {
 549             Tcl_AppendToObj(errorMsg, ", ", -1);
 550         }
 551         Tcl_AppendToObj(errorMsg, methodNames[i], -1);
 552     }
 553     if (i) {
 554         Tcl_AppendToObj(errorMsg, " or ", -1);
 555     }
 556     Tcl_AppendToObj(errorMsg, methodNames[i], -1);
 557     ckfree(methodNames);
 558     Tcl_SetObjResult(interp, errorMsg);
 559     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 560             TclGetString(objv[skip]), NULL);
 561     return TCL_ERROR;
 562 }
 563 \f
 564 /*
 565  * ----------------------------------------------------------------------
 566  *
 567  * TclOO_Object_LinkVar --
 568  *
 569  *      Implementation of oo::object->variable method.
 570  *
 571  * ----------------------------------------------------------------------
 572  */
 573
 574 int
 575 TclOO_Object_LinkVar(
 576     ClientData clientData,      /* Ignored. */
 577     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 578                                  * also used for error reporting. */
 579     Tcl_ObjectContext context,  /* The object/call context. */
 580     int objc,                   /* Number of arguments. */
 581     Tcl_Obj *const *objv)       /* The actual arguments. */
 582 {
 583     Interp *iPtr = (Interp *) interp;
 584     Tcl_Object object = Tcl_ObjectContextObject(context);
 585     Namespace *savedNsPtr;
 586     int i;
 587
 588     if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) {
 589         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 590                 "?varName ...?");
 591         return TCL_ERROR;
 592     }
 593
 594     /*
 595      * A sanity check. Shouldn't ever happen. (This is all that remains of a
 596      * more complex check inherited from [global] after we have applied the
 597      * fix for [Bug 2903811]; note that the fix involved *removing* code.)
 598      */
 599
 600     if (iPtr->varFramePtr == NULL) {
 601         return TCL_OK;
 602     }
 603
 604     for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) {
 605         Var *varPtr, *aryPtr;
 606         const char *varName = TclGetString(objv[i]);
 607
 608         /*
 609          * The variable name must not contain a '::' since that's illegal in
 610          * local names.
 611          */
 612
 613         if (strstr(varName, "::") != NULL) {
 614             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 615                     "variable name \"%s\" illegal: must not contain namespace"
 616                     " separator", varName));
 617             Tcl_SetErrorCode(interp, "TCL", "UPVAR", "INVERTED", NULL);
 618             return TCL_ERROR;
 619         }
 620
 621         /*
 622          * Switch to the object's namespace for the duration of this call.
 623          * Like this, the variable is looked up in the namespace of the
 624          * object, and not in the namespace of the caller. Otherwise this
 625          * would only work if the caller was a method of the object itself,
 626          * which might not be true if the method was exported. This is a bit
 627          * of a hack, but the simplest way to do this (pushing a stack frame
 628          * would be horribly expensive by comparison).
 629          */
 630
 631         savedNsPtr = iPtr->varFramePtr->nsPtr;
 632         iPtr->varFramePtr->nsPtr = (Namespace *)
 633                 Tcl_GetObjectNamespace(object);
 634         varPtr = TclObjLookupVar(interp, objv[i], NULL, TCL_NAMESPACE_ONLY,
 635                 "define", 1, 0, &aryPtr);
 636         iPtr->varFramePtr->nsPtr = savedNsPtr;
 637
 638         if (varPtr == NULL || aryPtr != NULL) {
 639             /*
 640              * Variable cannot be an element in an array. If aryPtr is not
 641              * NULL, it is an element, so throw up an error and return.
 642              */
 643
 644             TclVarErrMsg(interp, varName, NULL, "define",
 645                     "name refers to an element in an array");
 646             Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
 647             return TCL_ERROR;
 648         }
 649
 650         /*
 651          * Arrange for the lifetime of the variable to be correctly managed.
 652          * This is copied out of Tcl_VariableObjCmd...
 653          */
 654
 655         if (!TclIsVarNamespaceVar(varPtr)) {
 656             TclSetVarNamespaceVar(varPtr);
 657         }
 658
 659         if (TclPtrMakeUpvar(interp, varPtr, varName, 0, -1) != TCL_OK) {
 660             return TCL_ERROR;
 661         }
 662     }
 663     return TCL_OK;
 664 }
 665 \f
 666 /*
 667  * ----------------------------------------------------------------------
 668  *
 669  * TclOO_Object_VarName --
 670  *
 671  *      Implementation of the oo::object->varname method.
 672  *
 673  * ----------------------------------------------------------------------
 674  */
 675
 676 int
 677 TclOO_Object_VarName(
 678     ClientData clientData,      /* Ignored. */
 679     Tcl_Interp *interp,         /* Interpreter in which to create the object;
 680                                  * also used for error reporting. */
 681     Tcl_ObjectContext context,  /* The object/call context. */
 682     int objc,                   /* Number of arguments. */
 683     Tcl_Obj *const *objv)       /* The actual arguments. */
 684 {
 685     Var *varPtr, *aryVar;
 686     Tcl_Obj *varNamePtr, *argPtr;
 687     const char *arg;
 688
 689     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
 690         Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 691                 "varName");
 692         return TCL_ERROR;
 693     }
 694     argPtr = objv[objc-1];
 695     arg = Tcl_GetString(argPtr);
 696
 697     /*
 698      * Convert the variable name to fully-qualified form if it wasn't already.
 699      * This has to be done prior to lookup because we can run into problems
 700      * with resolvers otherwise. [Bug 3603695]
 701      *
 702      * We still need to do the lookup; the variable could be linked to another
 703      * variable and we want the target's name.
 704      */
 705
 706     if (arg[0] == ':' && arg[1] == ':') {
 707         varNamePtr = argPtr;
 708     } else {
 709         Tcl_Namespace *namespacePtr =
 710                 Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
 711
 712         varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
 713         Tcl_AppendToObj(varNamePtr, "::", 2);
 714         Tcl_AppendObjToObj(varNamePtr, argPtr);
 715     }
 716     Tcl_IncrRefCount(varNamePtr);
 717     varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
 718             TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
 719     Tcl_DecrRefCount(varNamePtr);
 720     if (varPtr == NULL) {
 721         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
 722         return TCL_ERROR;
 723     }
 724
 725     /*
 726      * Now that we've pinned down what variable we're really talking about
 727      * (including traversing variable links), convert back to a name.
 728      */
 729
 730     varNamePtr = Tcl_NewObj();
 731     if (aryVar != NULL) {
 732         Tcl_HashEntry *hPtr;
 733         Tcl_HashSearch search;
 734
 735         Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
 736
 737         /*
 738          * WARNING! This code pokes inside the implementation of hash tables!
 739          */
 740
 741         hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
 742                 &search);
 743         while (hPtr != NULL) {
 744             if (varPtr == Tcl_GetHashValue(hPtr)) {
 745                 Tcl_AppendToObj(varNamePtr, "(", -1);
 746                 Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
 747                 Tcl_AppendToObj(varNamePtr, ")", -1);
 748                 break;
 749             }
 750             hPtr = Tcl_NextHashEntry(&search);
 751         }
 752     } else {
 753         Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
 754     }
 755     Tcl_SetObjResult(interp, varNamePtr);
 756     return TCL_OK;
 757 }
 758 \f
 759 /*
 760  * ----------------------------------------------------------------------
 761  *
 762  * TclOONextObjCmd, TclOONextToObjCmd --
 763  *
 764  *      Implementation of the [next] and [nextto] commands. Note that these
 765  *      commands are only ever to be used inside the body of a procedure-like
 766  *      method.
 767  *
 768  * ----------------------------------------------------------------------
 769  */
 770
 771 int
 772 TclOONextObjCmd(
 773     ClientData clientData,
 774     Tcl_Interp *interp,
 775     int objc,
 776     Tcl_Obj *const *objv)
 777 {
 778     Interp *iPtr = (Interp *) interp;
 779     CallFrame *framePtr = iPtr->varFramePtr;
 780     Tcl_ObjectContext context;
 781
 782     /*
 783      * Start with sanity checks on the calling context to make sure that we
 784      * are invoked from a suitable method context. If so, we can safely
 785      * retrieve the handle to the object call context.
 786      */
 787
 788     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
 789         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 790                 "%s may only be called from inside a method",
 791                 TclGetString(objv[0])));
 792         Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 793         return TCL_ERROR;
 794     }
 795     context = framePtr->clientData;
 796
 797     /*
 798      * Invoke the (advanced) method call context in the caller context. Note
 799      * that this is like [uplevel 1] and not [eval].
 800      */
 801
 802     TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
 803     iPtr->varFramePtr = framePtr->callerVarPtr;
 804     return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
 805 }
 806
 807 int
 808 TclOONextToObjCmd(
 809     ClientData clientData,
 810     Tcl_Interp *interp,
 811     int objc,
 812     Tcl_Obj *const *objv)
 813 {
 814     Interp *iPtr = (Interp *) interp;
 815     CallFrame *framePtr = iPtr->varFramePtr;
 816     Class *classPtr;
 817     CallContext *contextPtr;
 818     int i;
 819     Tcl_Object object;
 820     const char *methodType;
 821
 822     /*
 823      * Start with sanity checks on the calling context to make sure that we
 824      * are invoked from a suitable method context. If so, we can safely
 825      * retrieve the handle to the object call context.
 826      */
 827
 828     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
 829         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 830                 "%s may only be called from inside a method",
 831                 TclGetString(objv[0])));
 832         Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 833         return TCL_ERROR;
 834     }
 835     contextPtr = framePtr->clientData;
 836
 837     /*
 838      * Sanity check the arguments; we need the first one to refer to a class.
 839      */
 840
 841     if (objc < 2) {
 842         Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
 843         return TCL_ERROR;
 844     }
 845     object = Tcl_GetObjectFromObj(interp, objv[1]);
 846     if (object == NULL) {
 847         return TCL_ERROR;
 848     }
 849     classPtr = ((Object *)object)->classPtr;
 850     if (classPtr == NULL) {
 851         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 852                 "\"%s\" is not a class", TclGetString(objv[1])));
 853         Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
 854         return TCL_ERROR;
 855     }
 856
 857     /*
 858      * Search for an implementation of a method associated with the current
 859      * call on the call chain past the point where we currently are. Do not
 860      * allow jumping backwards!
 861      */
 862
 863     for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
 864         struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
 865
 866         if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 867             /*
 868              * Invoke the (advanced) method call context in the caller
 869              * context. Note that this is like [uplevel 1] and not [eval].
 870              */
 871
 872             TclNRAddCallback(interp, NextRestoreFrame, framePtr,
 873                     contextPtr, INT2PTR(contextPtr->index), NULL);
 874             contextPtr->index = i-1;
 875             iPtr->varFramePtr = framePtr->callerVarPtr;
 876             return TclNRObjectContextInvokeNext(interp,
 877                     (Tcl_ObjectContext) contextPtr, objc, objv, 2);
 878         }
 879     }
 880
 881     /*
 882      * Generate an appropriate error message, depending on whether the value
 883      * is on the chain but unreachable, or not on the chain at all.
 884      */
 885
 886     if (contextPtr->callPtr->flags & CONSTRUCTOR) {
 887         methodType = "constructor";
 888     } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
 889         methodType = "destructor";
 890     } else {
 891         methodType = "method";
 892     }
 893
 894     for (i=contextPtr->index ; i>=0 ; i--) {
 895         struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
 896
 897         if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
 898             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 899                     "%s implementation by \"%s\" not reachable from here",
 900                     methodType, TclGetString(objv[1])));
 901             Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
 902                     NULL);
 903             return TCL_ERROR;
 904         }
 905     }
 906     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 907             "%s has no non-filter implementation by \"%s\"",
 908             methodType, TclGetString(objv[1])));
 909     Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
 910     return TCL_ERROR;
 911 }
 912
 913 static int
 914 NextRestoreFrame(
 915     ClientData data[],
 916     Tcl_Interp *interp,
 917     int result)
 918 {
 919     Interp *iPtr = (Interp *) interp;
 920     CallContext *contextPtr = data[1];
 921
 922     iPtr->varFramePtr = data[0];
 923     if (contextPtr != NULL) {
 924         contextPtr->index = PTR2INT(data[2]);
 925     }
 926     return result;
 927 }
 928 \f
 929 /*
 930  * ----------------------------------------------------------------------
 931  *
 932  * TclOOSelfObjCmd --
 933  *
 934  *      Implementation of the [self] command, which provides introspection of
 935  *      the call context.
 936  *
 937  * ----------------------------------------------------------------------
 938  */
 939
 940 int
 941 TclOOSelfObjCmd(
 942     ClientData clientData,
 943     Tcl_Interp *interp,
 944     int objc,
 945     Tcl_Obj *const *objv)
 946 {
 947     static const char *const subcmds[] = {
 948         "call", "caller", "class", "filter", "method", "namespace", "next",
 949         "object", "target", NULL
 950     };
 951     enum SelfCmds {
 952         SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
 953         SELF_NEXT, SELF_OBJECT, SELF_TARGET
 954     };
 955     Interp *iPtr = (Interp *) interp;
 956     CallFrame *framePtr = iPtr->varFramePtr;
 957     CallContext *contextPtr;
 958     Tcl_Obj *result[3];
 959     int index;
 960
 961 #define CurrentlyInvoked(contextPtr) \
 962     ((contextPtr)->callPtr->chain[(contextPtr)->index])
 963
 964     /*
 965      * Start with sanity checks on the calling context and the method context.
 966      */
 967
 968     if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
 969         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 970                 "%s may only be called from inside a method",
 971                 TclGetString(objv[0])));
 972         Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
 973         return TCL_ERROR;
 974     }
 975
 976     contextPtr = framePtr->clientData;
 977
 978     /*
 979      * Now we do "conventional" argument parsing for a while. Note that no
 980      * subcommand takes arguments.
 981      */
 982
 983     if (objc > 2) {
 984         Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
 985         return TCL_ERROR;
 986     } else if (objc == 1) {
 987         index = SELF_OBJECT;
 988     } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0,
 989             &index) != TCL_OK) {
 990         return TCL_ERROR;
 991     }
 992
 993     switch ((enum SelfCmds) index) {
 994     case SELF_OBJECT:
 995         Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr));
 996         return TCL_OK;
 997     case SELF_NS:
 998         Tcl_SetObjResult(interp, Tcl_NewStringObj(
 999                 contextPtr->oPtr->namespacePtr->fullName,-1));
1000         return TCL_OK;
1001     case SELF_CLASS: {
1002         Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
1003
1004         if (clsPtr == NULL) {
1005             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1006                     "method not defined by a class", -1));
1007             Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
1008             return TCL_ERROR;
1009         }
1010
1011         Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
1012         return TCL_OK;
1013     }
1014     case SELF_METHOD:
1015         if (contextPtr->callPtr->flags & CONSTRUCTOR) {
1016             Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->constructorName);
1017         } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
1018             Tcl_SetObjResult(interp, contextPtr->oPtr->fPtr->destructorName);
1019         } else {
1020             Tcl_SetObjResult(interp,
1021                     CurrentlyInvoked(contextPtr).mPtr->namePtr);
1022         }
1023         return TCL_OK;
1024     case SELF_FILTER:
1025         if (!CurrentlyInvoked(contextPtr).isFilter) {
1026             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1027                     "not inside a filtering context", -1));
1028             Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
1029             return TCL_ERROR;
1030         } else {
1031             struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
1032             Object *oPtr;
1033             const char *type;
1034
1035             if (miPtr->filterDeclarer != NULL) {
1036                 oPtr = miPtr->filterDeclarer->thisPtr;
1037                 type = "class";
1038             } else {
1039                 oPtr = contextPtr->oPtr;
1040                 type = "object";
1041             }
1042
1043             result[0] = TclOOObjectName(interp, oPtr);
1044             result[1] = Tcl_NewStringObj(type, -1);
1045             result[2] = miPtr->mPtr->namePtr;
1046             Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
1047             return TCL_OK;
1048         }
1049     case SELF_CALLER:
1050         if ((framePtr->callerVarPtr == NULL) ||
1051                 !(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
1052             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1053                     "caller is not an object", -1));
1054             Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
1055             return TCL_ERROR;
1056         } else {
1057             CallContext *callerPtr = framePtr->callerVarPtr->clientData;
1058             Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
1059             Object *declarerPtr;
1060
1061             if (mPtr->declaringClassPtr != NULL) {
1062                 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1063             } else if (mPtr->declaringObjectPtr != NULL) {
1064                 declarerPtr = mPtr->declaringObjectPtr;
1065             } else {
1066                 /*
1067                  * This should be unreachable code.
1068                  */
1069
1070                 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1071                         "method without declarer!", -1));
1072                 return TCL_ERROR;
1073             }
1074
1075             result[0] = TclOOObjectName(interp, declarerPtr);
1076             result[1] = TclOOObjectName(interp, callerPtr->oPtr);
1077             if (callerPtr->callPtr->flags & CONSTRUCTOR) {
1078                 result[2] = declarerPtr->fPtr->constructorName;
1079             } else if (callerPtr->callPtr->flags & DESTRUCTOR) {
1080                 result[2] = declarerPtr->fPtr->destructorName;
1081             } else {
1082                 result[2] = mPtr->namePtr;
1083             }
1084             Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
1085             return TCL_OK;
1086         }
1087     case SELF_NEXT:
1088         if (contextPtr->index < contextPtr->callPtr->numChain-1) {
1089             Method *mPtr =
1090                     contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
1091             Object *declarerPtr;
1092
1093             if (mPtr->declaringClassPtr != NULL) {
1094                 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1095             } else if (mPtr->declaringObjectPtr != NULL) {
1096                 declarerPtr = mPtr->declaringObjectPtr;
1097             } else {
1098                 /*
1099                  * This should be unreachable code.
1100                  */
1101
1102                 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1103                         "method without declarer!", -1));
1104                 return TCL_ERROR;
1105             }
1106
1107             result[0] = TclOOObjectName(interp, declarerPtr);
1108             if (contextPtr->callPtr->flags & CONSTRUCTOR) {
1109                 result[1] = declarerPtr->fPtr->constructorName;
1110             } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
1111                 result[1] = declarerPtr->fPtr->destructorName;
1112             } else {
1113                 result[1] = mPtr->namePtr;
1114             }
1115             Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
1116         }
1117         return TCL_OK;
1118     case SELF_TARGET:
1119         if (!CurrentlyInvoked(contextPtr).isFilter) {
1120             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1121                     "not inside a filtering context", -1));
1122             Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
1123             return TCL_ERROR;
1124         } else {
1125             Method *mPtr;
1126             Object *declarerPtr;
1127             int i;
1128
1129             for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
1130                 if (!contextPtr->callPtr->chain[i].isFilter) {
1131                     break;
1132                 }
1133             }
1134             if (i == contextPtr->callPtr->numChain) {
1135                 Tcl_Panic("filtering call chain without terminal non-filter");
1136             }
1137             mPtr = contextPtr->callPtr->chain[i].mPtr;
1138             if (mPtr->declaringClassPtr != NULL) {
1139                 declarerPtr = mPtr->declaringClassPtr->thisPtr;
1140             } else if (mPtr->declaringObjectPtr != NULL) {
1141                 declarerPtr = mPtr->declaringObjectPtr;
1142             } else {
1143                 /*
1144                  * This should be unreachable code.
1145                  */
1146
1147                 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1148                         "method without declarer!", -1));
1149                 return TCL_ERROR;
1150             }
1151             result[0] = TclOOObjectName(interp, declarerPtr);
1152             result[1] = mPtr->namePtr;
1153             Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
1154             return TCL_OK;
1155         }
1156     case SELF_CALL:
1157         result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
1158         TclNewIntObj(result[1], contextPtr->index);
1159         Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
1160         return TCL_OK;
1161     }
1162     return TCL_ERROR;
1163 }
1164 \f
1165 /*
1166  * ----------------------------------------------------------------------
1167  *
1168  * CopyObjectCmd --
1169  *
1170  *      Implementation of the [oo::copy] command, which clones an object (but
1171  *      not its namespace). Note that no constructors are called during this
1172  *      process.
1173  *
1174  * ----------------------------------------------------------------------
1175  */
1176
1177 int
1178 TclOOCopyObjectCmd(
1179     ClientData clientData,
1180     Tcl_Interp *interp,
1181     int objc,
1182     Tcl_Obj *const *objv)
1183 {
1184     Tcl_Object oPtr, o2Ptr;
1185
1186     if (objc < 2 || objc > 4) {
1187         Tcl_WrongNumArgs(interp, 1, objv,
1188                          "sourceName ?targetName? ?targetNamespace?");
1189         return TCL_ERROR;
1190     }
1191
1192     oPtr = Tcl_GetObjectFromObj(interp, objv[1]);
1193     if (oPtr == NULL) {
1194         return TCL_ERROR;
1195     }
1196
1197     /*
1198      * Create a cloned object of the correct class. Note that constructors are
1199      * not called. Also note that we must resolve the object name ourselves
1200      * because we do not want to create the object in the current namespace,
1201      * but rather in the context of the namespace of the caller of the overall
1202      * [oo::define] command.
1203      */
1204
1205     if (objc == 2) {
1206         o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
1207     } else {
1208         const char *name, *namespaceName;
1209
1210         name = TclGetString(objv[2]);
1211         if (name[0] == '\0') {
1212             name = NULL;
1213         }
1214
1215         /*
1216          * Choose a unique namespace name if the user didn't supply one.
1217          */
1218
1219         namespaceName = NULL;
1220         if (objc == 4) {
1221             namespaceName = TclGetString(objv[3]);
1222
1223             if (namespaceName[0] == '\0') {
1224                 namespaceName = NULL;
1225             } else if (Tcl_FindNamespace(interp, namespaceName, NULL,
1226                     0) != NULL) {
1227                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1228                         "%s refers to an existing namespace", namespaceName));
1229                 return TCL_ERROR;
1230             }
1231         }
1232
1233         o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
1234     }
1235
1236     if (o2Ptr == NULL) {
1237         return TCL_ERROR;
1238     }
1239
1240     /*
1241      * Return the name of the cloned object.
1242      */
1243
1244     Tcl_SetObjResult(interp, TclOOObjectName(interp, (Object *) o2Ptr));
1245     return TCL_OK;
1246 }
1247 \f
1248 /*
1249  * Local Variables:
1250  * mode: c
1251  * c-basic-offset: 4
1252  * fill-column: 78
1253  * End:
1254  */