0001: /*
0002: * ------------------------------------------------------------------------
0003: * PACKAGE: [incr Tcl]
0004: * DESCRIPTION: Object-Oriented Extensions to Tcl
0005: *
0006: * [incr Tcl] provides object-oriented extensions to Tcl, much as
0007: * C++ provides object-oriented extensions to C. It provides a means
0008: * of encapsulating related procedures together with their shared data
0009: * in a local namespace that is hidden from the outside world. It
0010: * promotes code re-use through inheritance. More than anything else,
0011: * it encourages better organization of Tcl applications through the
0012: * object-oriented paradigm, leading to code that is easier to
0013: * understand and maintain.
0014: *
0015: * This segment handles "objects" which are instantiated from class
0016: * definitions. Objects contain public/protected/private data members
0017: * from all classes in a derivation hierarchy.
0018: *
0019: * ========================================================================
0020: * AUTHOR: Michael J. McLennan
0021: * Bell Labs Innovations for Lucent Technologies
0022: * mmclennan@lucent.com
0023: * http://www.tcltk.com/itcl
0024: *
0025: * RCS: $Id: Objects.java,v 1.3 2006/01/26 19:49:18 mdejong Exp $
0026: * ========================================================================
0027: * Copyright (c) 1993-1998 Lucent Technologies, Inc.
0028: * ------------------------------------------------------------------------
0029: * See the file "license.itcl" for information on usage and redistribution
0030: * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
0031: */
0032:
0033: package itcl.lang;
0034:
0035: import tcl.lang.*;
0036:
0037: import java.util.Map;
0038: import java.util.HashMap;
0039: import java.util.Iterator;
0040:
0041: class Objects {
0042: static HashMap dangleTable = new HashMap();
0043:
0044: /*
0045: * ------------------------------------------------------------------------
0046: * Itcl_CreateObject -> Objects.CreateObject
0047: *
0048: * Creates a new object instance belonging to the given class.
0049: * Supports complex object names like "namesp::namesp::name" by
0050: * following the namespace path and creating the object in the
0051: * desired namespace.
0052: *
0053: * Automatically creates and initializes data members, including the
0054: * built-in protected "this" variable containing the object name.
0055: * Installs an access command in the current namespace, and invokes
0056: * the constructor to initialize the object.
0057: *
0058: * If any errors are encountered, the object is destroyed and this
0059: * procedure raises a TclException. Otherwise a reference to a
0060: * new object is returned.
0061: * ------------------------------------------------------------------------
0062: */
0063:
0064: static ItclObject CreateObject(Interp interp, // interpreter mananging new object
0065: String name, // name of new object
0066: ItclClass cdefn, // class for new object
0067: TclObject[] objv) // argument objects
0068: throws TclException {
0069: int result;
0070: boolean ctorErr;
0071: TclException ctorEx = null;
0072:
0073: String head, tail;
0074: StringBuffer objName;
0075: Namespace parentNs;
0076: ItclContext context;
0077: ItclObject newObj;
0078: ItclClass cd;
0079: ItclVarDefn vdefn;
0080: ItclHierIter hier;
0081: Itcl_InterpState istate;
0082:
0083: // If installing an object access command will clobber another
0084: // command, signal an error. Be careful to look for the object
0085: // only in the current namespace context. Otherwise, we might
0086: // find a global command, but that wouldn't be clobbered!
0087:
0088: WrappedCommand wcmd = Namespace.findCommand(interp, name, null,
0089: TCL.NAMESPACE_ONLY);
0090: //cmd = wcmd.cmd;
0091:
0092: if (wcmd != null && !Cmds.IsStub(wcmd)) {
0093: throw new TclException(interp, "command \"" + name
0094: + "\" already exists in namespace \""
0095: + Namespace.getCurrentNamespace(interp).fullName
0096: + "\"");
0097: }
0098:
0099: // Extract the namespace context and the simple object
0100: // name for the new object.
0101:
0102: Util.ParseNamespPathResult res = Util.ParseNamespPath(name);
0103: head = res.head;
0104: tail = res.tail;
0105:
0106: if (head != null) {
0107: parentNs = Class.FindClassNamespace(interp, head);
0108:
0109: if (parentNs == null) {
0110: throw new TclException(
0111: interp,
0112: "namespace \""
0113: + head
0114: + "\" not found in context \""
0115: + Namespace.getCurrentNamespace(interp).fullName
0116: + "\"");
0117: }
0118: } else {
0119: parentNs = Namespace.getCurrentNamespace(interp);
0120: }
0121:
0122: objName = new StringBuffer();
0123: if (parentNs != Namespace.getGlobalNamespace(interp)) {
0124: objName.append(parentNs.fullName);
0125: }
0126: objName.append("::");
0127: objName.append(tail);
0128:
0129: // Create a new object and initialize it.
0130:
0131: newObj = new ItclObject();
0132: newObj.classDefn = cdefn;
0133: Util.PreserveData(cdefn);
0134:
0135: newObj.dataSize = cdefn.numInstanceVars;
0136: newObj.data = new Var[newObj.dataSize];
0137:
0138: newObj.constructed = new HashMap();
0139: newObj.destructed = null;
0140:
0141: // Add a command to the current namespace with the object name.
0142: // This is done before invoking the constructors so that the
0143: // command can be used during construction to query info.
0144:
0145: Util.PreserveData(newObj);
0146: interp.createCommand(objName.toString(), new HandleInstanceCmd(
0147: newObj));
0148: wcmd = Namespace.findCommand(interp, name, null,
0149: TCL.NAMESPACE_ONLY);
0150: newObj.w_accessCmd = wcmd;
0151: newObj.accessCmd = wcmd.cmd;
0152:
0153: Util.PreserveData(newObj); // while cmd exists in the interp
0154: //Itcl_EventuallyFree((ClientData)newObj, ItclFreeObject);
0155:
0156: // Install the class namespace and object context so that
0157: // the object's data members can be initialized via simple
0158: // "set" commands.
0159:
0160: context = new ItclContext(interp);
0161: Methods.PushContext(interp, null, cdefn, newObj, context);
0162:
0163: hier = new ItclHierIter();
0164: Class.InitHierIter(hier, cdefn);
0165:
0166: cd = Class.AdvanceHierIter(hier);
0167: while (cd != null) {
0168: for (Iterator iter = cd.variables.entrySet().iterator(); iter
0169: .hasNext();) {
0170: Map.Entry entry = (Map.Entry) iter.next();
0171: vdefn = (ItclVarDefn) entry.getValue();
0172:
0173: if ((vdefn.member.flags & ItclInt.THIS_VAR) != 0) {
0174: if (cd == cdefn) {
0175: CreateObjVar(interp, vdefn, newObj);
0176: interp.setVar("this",
0177: TclString.newInstance(""), 0);
0178: interp.traceVar("this", newObj, TCL.TRACE_READS
0179: | TCL.TRACE_WRITES);
0180: }
0181: } else if ((vdefn.member.flags & ItclInt.COMMON) == 0) {
0182: CreateObjVar(interp, vdefn, newObj);
0183: }
0184: }
0185: cd = Class.AdvanceHierIter(hier);
0186: }
0187: Class.DeleteHierIter(hier);
0188:
0189: Methods.PopContext(interp, context); // back to calling context
0190:
0191: // Now construct the object. Look for a constructor in the
0192: // most-specific class, and if there is one, invoke it.
0193: // This will cause a chain reaction, making sure that all
0194: // base classes constructors are invoked as well, in order
0195: // from least- to most-specific. Any constructors that are
0196: // not called out explicitly in "initCode" code fragments are
0197: // invoked implicitly without arguments.
0198:
0199: ctorErr = true;
0200: try {
0201: Methods.InvokeMethodIfExists(interp, "constructor", cdefn,
0202: newObj, objv);
0203: ctorErr = false;
0204: } catch (TclException ex) {
0205: ctorEx = ex;
0206: }
0207:
0208: // If there is no constructor, construct the base classes
0209: // in case they have constructors. This will cause the
0210: // same chain reaction.
0211:
0212: if (cdefn.functions.get("constructor") == null) {
0213: ctorErr = true;
0214: try {
0215: Methods.ConstructBase(interp, newObj, cdefn);
0216: ctorErr = false;
0217: } catch (TclException ex) {
0218: ctorEx = ex;
0219: }
0220: }
0221:
0222: // If construction failed, then delete the object access
0223: // command. This will destruct the object and delete the
0224: // object data. Be careful to save and restore the interpreter
0225: // state, since the destructors may generate errors of their own.
0226:
0227: if (ctorErr) {
0228: istate = Util.SaveInterpState(interp, 0);
0229:
0230: // Bug 227824.
0231: // The constructor may destroy the object, possibly indirectly
0232: // through the destruction of the main widget in the iTk
0233: // megawidget it tried to construct. If this happens we must
0234: // not try to destroy the access command a second time.
0235:
0236: if (newObj.accessCmd != null) {
0237: if (interp.deleteCommandFromToken(newObj.w_accessCmd) != 0) {
0238: throw new TclRuntimeError(
0239: "could not delete instance command from token");
0240: }
0241: newObj.accessCmd = null;
0242: }
0243: result = Util.RestoreInterpState(interp, istate);
0244: }
0245:
0246: // At this point, the object is fully constructed.
0247: // Destroy the "constructed" table in the object data, since
0248: // it is no longer needed.
0249:
0250: newObj.constructed.clear();
0251: newObj.constructed = null;
0252:
0253: // Add it to the list of all known objects. The only
0254: // tricky thing to watch out for is the case where the
0255: // object deleted itself inside its own constructor.
0256: // In that case, we don't want to add the object to
0257: // the list of valid objects. We can determine that
0258: // the object deleted itself by checking to see if
0259: // its accessCmd member is NULL.
0260:
0261: if (!ctorErr && (newObj.accessCmd != null)) {
0262: cdefn.info.objects.put(newObj.accessCmd, newObj);
0263: }
0264:
0265: // Release the object. If it was destructed above, it will
0266: // die at this point.
0267:
0268: Util.ReleaseData(newObj);
0269:
0270: if (ctorErr) {
0271: throw ctorEx;
0272: }
0273:
0274: return newObj;
0275: }
0276:
0277: /*
0278: * ------------------------------------------------------------------------
0279: * Itcl_DeleteObject -> Objects.DeleteObject
0280: *
0281: * Attempts to delete an object by invoking its destructor.
0282: *
0283: * If the destructor is successful, then the object is deleted by
0284: * removing its access command, and this procedure returns normally.
0285: * Otherwise, the object will remain alive, and this procedure
0286: * raises a TclException.
0287: * ------------------------------------------------------------------------
0288: */
0289:
0290: static void DeleteObject(Interp interp, // interpreter mananging object
0291: ItclObject contextObj) // object to be deleted
0292: throws TclException {
0293: ItclClass cdefn = contextObj.classDefn;
0294:
0295: Util.PreserveData(contextObj);
0296:
0297: // Invoke the object's destructors.
0298:
0299: try {
0300: Objects.DestructObject(interp, contextObj, 0);
0301: } catch (TclException ex) {
0302: Util.ReleaseData(contextObj);
0303: throw ex;
0304: }
0305:
0306: // Remove the object from the global list.
0307:
0308: cdefn.info.objects.remove(contextObj.accessCmd);
0309:
0310: // Change the object's access command so that it can be
0311: // safely deleted without attempting to destruct the object
0312: // again. Then delete the access command. If this is
0313: // the last use of the object data, the object will die here.
0314:
0315: ((HandleInstanceCmd) contextObj.accessCmd).deleteToken = true;
0316:
0317: if (interp.deleteCommandFromToken(contextObj.w_accessCmd) != 0) {
0318: throw new TclRuntimeError(
0319: "could not delete instance command from token");
0320: }
0321: contextObj.accessCmd = null;
0322:
0323: Util.ReleaseData(contextObj); // object should die here
0324: }
0325:
0326: /*
0327: * ------------------------------------------------------------------------
0328: * Itcl_DestructObject -> Objects.DestructObject
0329: *
0330: * Invokes the destructor for a particular object. Usually invoked
0331: * by DeleteObject() or DestroyObject() as a part of the
0332: * object destruction process. If the ItclInt.IGNORE_ERRS flag is
0333: * included, all destructors are invoked even if errors are
0334: * encountered.
0335: *
0336: * Raises a TclException if anything goes wrong.
0337: * ------------------------------------------------------------------------
0338: */
0339:
0340: static void DestructObject(Interp interp, // interpreter mananging new object
0341: ItclObject contextObj, // object to be destructed
0342: int flags) // flags: ItclInt.IGNORE_ERRS
0343: throws TclException {
0344: int result;
0345:
0346: // If there is a "destructed" table, then this object is already
0347: // being destructed. Flag an error, unless errors are being
0348: // ignored.
0349:
0350: if (contextObj.destructed != null) {
0351: if ((flags & ItclInt.IGNORE_ERRS) == 0) {
0352: throw new TclException(interp,
0353: "can't delete an object while it is being destructed");
0354: }
0355: return;
0356: }
0357:
0358: // Create a "destructed" table to keep track of which destructors
0359: // have been invoked. This is used in DestructBase to make
0360: // sure that all base class destructors have been called,
0361: // explicitly or implicitly.
0362:
0363: contextObj.destructed = new HashMap();
0364:
0365: // Destruct the object starting from the most-specific class.
0366: // If all goes well, return the null string as the result.
0367:
0368: TclException dtorEx = null;
0369:
0370: try {
0371: Objects.DestructBase(interp, contextObj,
0372: contextObj.classDefn, flags);
0373: } catch (TclException ex) {
0374: dtorEx = ex;
0375: }
0376:
0377: if (dtorEx == null) {
0378: interp.resetResult();
0379: }
0380:
0381: contextObj.destructed.clear();
0382: contextObj.destructed = null;
0383:
0384: if (dtorEx != null) {
0385: throw dtorEx;
0386: }
0387: }
0388:
0389: /*
0390: * ------------------------------------------------------------------------
0391: * ItclDestructBase -> Objects.DestructBase
0392: *
0393: * Invoked by DestructObject() to recursively destruct an object
0394: * from the specified class level. Finds and invokes the destructor
0395: * for the specified class, and then recursively destructs all base
0396: * classes. If the ItclInt.IGNORE_ERRS flag is included, all destructors
0397: * are invoked even if errors are encountered.
0398: *
0399: * Raises a TclException if anything goes wrong.
0400: * ------------------------------------------------------------------------
0401: */
0402:
0403: static void DestructBase(Interp interp, // interpreter
0404: ItclObject contextObj, // object being destructed
0405: ItclClass contextClass, // current class being destructed
0406: int flags) // flags: ItclInt.IGNORE_ERRS
0407: throws TclException {
0408: Itcl_ListElem elem;
0409: ItclClass cdefn;
0410:
0411: // Look for a destructor in this class, and if found,
0412: // invoke it.
0413:
0414: if (contextObj.destructed.get(contextClass.name) == null) {
0415: Methods.InvokeMethodIfExists(interp, "destructor",
0416: contextClass, contextObj, null);
0417: }
0418:
0419: // Scan through the list of base classes recursively and destruct
0420: // them. Traverse the list in normal order, so that we destruct
0421: // from most- to least-specific.
0422:
0423: elem = Util.FirstListElem(contextClass.bases);
0424: while (elem != null) {
0425: cdefn = (ItclClass) Util.GetListValue(elem);
0426:
0427: Objects.DestructBase(interp, contextObj, cdefn, flags);
0428: elem = Util.NextListElem(elem);
0429: }
0430:
0431: // Throw away any result from the destructors and return.
0432:
0433: interp.resetResult();
0434: }
0435:
0436: /*
0437: * ------------------------------------------------------------------------
0438: * Itcl_FindObject -> Objects.FindObject
0439: *
0440: * Searches for an object with the specified name, which have
0441: * namespace scope qualifiers like "namesp::namesp::name", or may
0442: * be a scoped value such as "namespace inscope ::foo obj".
0443: *
0444: * Raises a TclException if anything goes wrong. If an object
0445: * was found, it is returned. Otherwise, null is returned.
0446: * ------------------------------------------------------------------------
0447: */
0448:
0449: static ItclObject FindObject(Interp interp, // interpreter containing this object
0450: String name) // name of the object
0451: throws TclException {
0452: Namespace contextNs = null;
0453:
0454: String cmdName;
0455: WrappedCommand wcmd;
0456: ItclObject ro;
0457:
0458: // The object name may be a scoped value of the form
0459: // "namespace inscope <namesp> <command>". If it is,
0460: // decode it.
0461:
0462: Util.DecodeScopedCommandResult res = Util.DecodeScopedCommand(
0463: interp, name);
0464: contextNs = res.rNS;
0465: cmdName = res.rCmd;
0466:
0467: // Look for the object's access command, and see if it has
0468: // the appropriate command handler.
0469:
0470: try {
0471: wcmd = Namespace.findCommand(interp, cmdName, contextNs, 0);
0472: } catch (TclException ex) {
0473: wcmd = null;
0474: }
0475:
0476: if (wcmd != null && Objects.IsObject(wcmd)) {
0477: return Objects.GetContextFromObject(wcmd);
0478: } else {
0479: return null;
0480: }
0481: }
0482:
0483: /*
0484: * ------------------------------------------------------------------------
0485: * Itcl_IsObject -> Objects.IsObject
0486: *
0487: * Checks the given Tcl command to see if it represents an itcl object.
0488: * Returns true if the command is associated with an object.
0489: * ------------------------------------------------------------------------
0490: */
0491:
0492: static boolean IsObject(WrappedCommand wcmd) // command being tested
0493: {
0494: if (wcmd.cmd instanceof HandleInstanceCmd) {
0495: return true;
0496: }
0497:
0498: // This may be an imported command. Try to get the real
0499: // command and see if it represents an object.
0500:
0501: wcmd = Namespace.getOriginalCommand(wcmd);
0502: if ((wcmd != null) && (wcmd.cmd instanceof HandleInstanceCmd)) {
0503: return true;
0504: }
0505: return false;
0506: }
0507:
0508: /*
0509: * ------------------------------------------------------------------------
0510: * Objects.GetContextFromObject
0511: *
0512: * Return the ItclObject context object associated with a given
0513: * This function assumes that IsObject() returns
0514: * true for this command.
0515: * ------------------------------------------------------------------------
0516: */
0517:
0518: static ItclObject GetContextFromObject(WrappedCommand wcmd) // command that represents the object
0519: {
0520: return ((HandleInstanceCmd) wcmd.cmd).contextObj;
0521: }
0522:
0523: /*
0524: * ------------------------------------------------------------------------
0525: * Itcl_ObjectIsa -> Objects.ObjectIsa
0526: *
0527: * Checks to see if an object belongs to the given class. An object
0528: * "is-a" member of the class if the class appears anywhere in its
0529: * inheritance hierarchy. Returns true if the object belongs to
0530: * the class, and false otherwise.
0531: * ------------------------------------------------------------------------
0532: */
0533:
0534: static boolean ObjectIsa(ItclObject contextObj, // object being tested
0535: ItclClass cdefn) // class to test for "is-a" relationship
0536: {
0537: return (contextObj.classDefn.heritage.get(cdefn) != null);
0538: }
0539:
0540: /*
0541: * ------------------------------------------------------------------------
0542: * Itcl_HandleInstance -> Object.HandleInstanceCmd.cmdProc
0543: *
0544: * Invoked by Tcl whenever the user issues a command associated with
0545: * an object instance. Handles the following syntax:
0546: *
0547: * <objName> <method> <args>...
0548: *
0549: * ------------------------------------------------------------------------
0550: */
0551:
0552: static class HandleInstanceCmd implements CommandWithDispose {
0553: ItclObject contextObj;
0554: boolean deleteToken;
0555:
0556: HandleInstanceCmd(ItclObject contextObj) {
0557: this .contextObj = contextObj;
0558: deleteToken = false;
0559: }
0560:
0561: // Invoked when the instance command is deleted in the Tcl interp.
0562:
0563: public void disposeCmd() {
0564: if (deleteToken == false) {
0565: Objects.DestroyObject(contextObj);
0566: } else {
0567: Util.ReleaseData(contextObj);
0568: }
0569: }
0570:
0571: public void cmdProc(Interp interp, // Current interp.
0572: TclObject[] objv) // Args passed to the command.
0573: throws TclException {
0574: String token;
0575: ItclMemberFunc mfunc;
0576: ItclObjectInfo info;
0577: ItclContext context;
0578: CallFrame frame;
0579:
0580: if (objv.length < 2) {
0581: throw new TclException(interp,
0582: "wrong # args: should be one of..."
0583: + ReportObjectUsage(interp, contextObj));
0584: }
0585:
0586: // Make sure that the specified operation is really an
0587: // object method, and it is accessible. If not, return usage
0588: // information for the object.
0589:
0590: token = objv[1].toString();
0591:
0592: mfunc = (ItclMemberFunc) contextObj.classDefn.resolveCmds
0593: .get(token);
0594: if (mfunc != null) {
0595: if ((mfunc.member.flags & ItclInt.COMMON) != 0) {
0596: mfunc = null;
0597: } else if (mfunc.member.protection != Itcl.PUBLIC) {
0598: Namespace contextNs = Util.GetTrueNamespace(interp,
0599: mfunc.member.classDefn.info);
0600:
0601: if (!Util.CanAccessFunc(mfunc, contextNs)) {
0602: mfunc = null;
0603: }
0604: }
0605: }
0606:
0607: if (mfunc == null && !token.equals("info")) {
0608: throw new TclException(interp, "bad option \"" + token
0609: + "\": should be one of..."
0610: + ReportObjectUsage(interp, contextObj));
0611: }
0612:
0613: // Install an object context and invoke the method.
0614: //
0615: // TRICKY NOTE: We need to pass the object context into the
0616: // method, but activating the context here puts us one level
0617: // down, and when the method is called, it will activate its
0618: // own context, putting us another level down. If anyone
0619: // were to execute an "uplevel" command in the method, they
0620: // would notice the extra call frame. So we mark this frame
0621: // as "transparent" and Itcl_EvalMemberCode will automatically
0622: // do an "uplevel" operation to correct the problem.
0623:
0624: info = contextObj.classDefn.info;
0625:
0626: context = new ItclContext(interp);
0627: Methods.PushContext(interp, null, contextObj.classDefn,
0628: contextObj, context);
0629:
0630: try { // start context release block
0631:
0632: frame = context.frame;
0633: Util.PushStack(frame, info.transparentFrames);
0634:
0635: // Bug 227824
0636: // The tcl core will blow up in 'TclLookupVar' if we don't reset
0637: // the 'isProcCallFrame'. This happens because without the
0638: // callframe refered to by 'framePtr' will be inconsistent
0639: // ('isProcCallFrame' set, but 'procPtr' not set).
0640:
0641: if (token.equals("info")) {
0642: ItclAccess.setProcCallFrameFalse(frame);
0643: }
0644:
0645: TclObject cmdline = Util.CreateArgs(interp, null, objv,
0646: 1);
0647: TclObject[] cmdlinev = TclList.getElements(interp,
0648: cmdline);
0649: Util.EvalArgs(interp, cmdlinev);
0650:
0651: } finally { // end context release block
0652: Util.PopStack(info.transparentFrames);
0653: Methods.PopContext(interp, context);
0654: }
0655: }
0656: } // end class HandleInstanceCmd
0657:
0658: /*
0659: * ------------------------------------------------------------------------
0660: * Itcl_GetInstanceVar -> Object.GetInstanceVar
0661: *
0662: * Returns the current value for an object data member. The member
0663: * name is interpreted with respect to the given class scope, which
0664: * is usually the most-specific class for the object.
0665: *
0666: * If successful, this procedure returns a pointer to a string value
0667: * which remains alive until the variable changes it value. If
0668: * anything goes wrong, this returns null.
0669: * ------------------------------------------------------------------------
0670: */
0671:
0672: static String GetInstanceVar(Interp interp, // current interpreter
0673: String name, // name of desired instance variable
0674: ItclObject contextObj, // current object
0675: ItclClass contextClass) // name is interpreted in this scope
0676: {
0677: ItclContext context;
0678: TclObject val = null;
0679:
0680: // Make sure that the current namespace context includes an
0681: // object that is being manipulated.
0682:
0683: if (contextObj == null) {
0684: interp
0685: .setResult("cannot access object-specific info without an object context");
0686: return null;
0687: }
0688:
0689: // Install the object context and access the data member
0690: // like any other variable.
0691:
0692: context = new ItclContext(interp);
0693: try {
0694: Methods.PushContext(interp, null, contextClass, contextObj,
0695: context);
0696: } catch (TclException ex) {
0697: return null;
0698: }
0699:
0700: try {
0701: val = interp.getVar(name, TCL.LEAVE_ERR_MSG);
0702: } catch (TclException ex) {
0703: // No-op
0704: } finally {
0705: Methods.PopContext(interp, context);
0706: }
0707:
0708: if (val != null) {
0709: return val.toString();
0710: } else {
0711: return null;
0712: }
0713: }
0714:
0715: /*
0716: * ------------------------------------------------------------------------
0717: * ItclReportObjectUsage -> ReportObjectUsage
0718: *
0719: * Returns a String object summarizing the usage
0720: * for all of the methods available for this object. Useful when
0721: * reporting errors in Itcl_HandleInstance().
0722: * ------------------------------------------------------------------------
0723: */
0724:
0725: static String ReportObjectUsage(Interp interp, // current interpreter
0726: ItclObject contextObj) // current object
0727: {
0728: ItclClass cdefn = contextObj.classDefn;
0729: int ignore = ItclInt.CONSTRUCTOR | ItclInt.DESTRUCTOR
0730: | ItclInt.COMMON;
0731:
0732: int cmp;
0733: String name;
0734: Itcl_List cmdList;
0735: Itcl_ListElem elem;
0736: ItclMemberFunc mfunc, cmpDefn;
0737:
0738: // Scan through all methods in the virtual table and sort
0739: // them in alphabetical order. Report only the methods
0740: // that have simple names (no ::'s) and are accessible.
0741:
0742: cmdList = new Itcl_List();
0743: Util.InitList(cmdList);
0744:
0745: for (Iterator iter = cdefn.resolveCmds.entrySet().iterator(); iter
0746: .hasNext();) {
0747: Map.Entry entry = (Map.Entry) iter.next();
0748: name = (String) entry.getKey();
0749: mfunc = (ItclMemberFunc) entry.getValue();
0750:
0751: if ((name.indexOf("::") != -1)
0752: || (mfunc.member.flags & ignore) != 0) {
0753: mfunc = null;
0754: } else if (mfunc.member.protection != Itcl.PUBLIC) {
0755: Namespace contextNs = Util.GetTrueNamespace(interp,
0756: mfunc.member.classDefn.info);
0757:
0758: if (!Util.CanAccessFunc(mfunc, contextNs)) {
0759: mfunc = null;
0760: }
0761: }
0762:
0763: if (mfunc != null) {
0764: elem = Util.FirstListElem(cmdList);
0765: while (elem != null) {
0766: cmpDefn = (ItclMemberFunc) Util.GetListValue(elem);
0767: cmp = mfunc.member.name
0768: .compareTo(cmpDefn.member.name);
0769: if (cmp < 0) {
0770: Util.InsertListElem(elem, mfunc);
0771: mfunc = null;
0772: break;
0773: } else if (cmp == 0) {
0774: mfunc = null;
0775: break;
0776: }
0777: elem = Util.NextListElem(elem);
0778: }
0779: if (mfunc != null) {
0780: Util.AppendList(cmdList, mfunc);
0781: }
0782: }
0783: }
0784:
0785: // Add a series of statements showing usage info.
0786:
0787: StringBuffer buffer = new StringBuffer(64);
0788:
0789: elem = Util.FirstListElem(cmdList);
0790: while (elem != null) {
0791: mfunc = (ItclMemberFunc) Util.GetListValue(elem);
0792: buffer.append("\n ");
0793: Methods.GetMemberFuncUsage(mfunc, contextObj, buffer);
0794:
0795: elem = Util.NextListElem(elem);
0796: }
0797: Util.DeleteList(cmdList);
0798:
0799: return buffer.toString();
0800: }
0801:
0802: /*
0803: * ------------------------------------------------------------------------
0804: * ItclTraceThisVar -> Objects.TraceThisVar
0805: *
0806: * Invoked to handle read/write traces on the "this" variable built
0807: * into each object.
0808: *
0809: * On read, this procedure updates the "this" variable to contain the
0810: * current object name. This is done dynamically, since an object's
0811: * identity can change if its access command is renamed.
0812: *
0813: * On write, this procedure returns an error string, warning that
0814: * the "this" variable cannot be set.
0815: * ------------------------------------------------------------------------
0816: */
0817:
0818: static void TraceThisVar(ItclObject contextObj, // object instance data
0819: Interp interp, // interpreter managing this variable
0820: String name1, // variable name
0821: String name2, // unused
0822: int flags) // flags indicating read/write
0823: throws TclException {
0824: String objName;
0825:
0826: // Handle read traces on "this"
0827:
0828: if ((flags & TCL.TRACE_READS) != 0) {
0829: if (contextObj.accessCmd != null) {
0830: objName = interp
0831: .getCommandFullName(contextObj.w_accessCmd);
0832: } else {
0833: objName = "";
0834: }
0835:
0836: interp.setVar(name1, TclString.newInstance(objName), 0);
0837:
0838: return;
0839: }
0840:
0841: // Handle write traces on "this"
0842:
0843: if ((flags & TCL.TRACE_WRITES) != 0) {
0844: throw new TclException(interp,
0845: "variable \"this\" cannot be modified");
0846: }
0847: }
0848:
0849: /*
0850: * ------------------------------------------------------------------------
0851: * ItclDestroyObject -> Objects.DestroyObject
0852: *
0853: * Invoked when the object access command is deleted to implicitly
0854: * destroy the object. Invokes the object's destructors, ignoring
0855: * any errors encountered along the way. Removes the object from
0856: * the list of all known objects and releases the access command's
0857: * claim to the object data.
0858: *
0859: * Note that the usual way to delete an object is via DeleteObject().
0860: * This procedure is provided as a back-up, to handle the case when
0861: * an object is deleted by removing its access command.
0862: * ------------------------------------------------------------------------
0863: */
0864:
0865: static void DestroyObject(ItclObject contextObj) // object instance data
0866: {
0867: ItclClass cdefn = contextObj.classDefn;
0868: Itcl_InterpState istate;
0869:
0870: // Attempt to destruct the object, but ignore any errors.
0871:
0872: istate = Util.SaveInterpState(cdefn.interp, 0);
0873: try {
0874: Objects.DestructObject(cdefn.interp, contextObj,
0875: ItclInt.IGNORE_ERRS);
0876: } catch (TclException ex) {
0877: // Ignore any TclException that comes from DestructObject.
0878: // The code does not actually check IGNORE_ERRS and
0879: // avoid throwing an exception, so just ignore it here.
0880: }
0881: Util.RestoreInterpState(cdefn.interp, istate);
0882:
0883: // Now, remove the object from the global object list.
0884: // We're careful to do this here, after calling the destructors.
0885: // Once the access command is nulled out, the "this" variable
0886: // won't work properly.
0887:
0888: if (contextObj.accessCmd != null) {
0889: cdefn.info.objects.remove(contextObj.accessCmd);
0890: contextObj.accessCmd = null;
0891: }
0892:
0893: Util.ReleaseData(contextObj);
0894: }
0895:
0896: /*
0897: * ------------------------------------------------------------------------
0898: * ItclFreeObject -> Objects.FreeObject
0899: *
0900: * Deletes all instance variables and frees all memory associated with
0901: * the given object instance. This is usually invoked automatically
0902: * by Itcl_ReleaseData(), when an object's data is no longer being used.
0903: * ------------------------------------------------------------------------
0904: */
0905:
0906: static void FreeObject(ItclObject contextObj) // object instance data
0907: {
0908: Interp interp = contextObj.classDefn.interp;
0909:
0910: ItclClass cd;
0911: ItclHierIter hier;
0912: ItclVarDefn vdefn;
0913: ItclContext context;
0914: Itcl_InterpState istate;
0915:
0916: // Install the class namespace and object context so that
0917: // the object's data members can be destroyed via simple
0918: // "unset" commands. This makes sure that traces work properly
0919: // and all memory gets cleaned up.
0920: //
0921: // NOTE: Be careful to save and restore the interpreter state.
0922: // Data can get freed in the middle of any operation, and
0923: // we can't affort to clobber the interpreter with any errors
0924: // from below.
0925:
0926: istate = Util.SaveInterpState(interp, 0);
0927:
0928: // Scan through all object-specific data members and destroy the
0929: // actual variables that maintain the object state. Do this
0930: // by unsetting each variable, so that traces are fired off
0931: // correctly. Make sure that the built-in "this" variable is
0932: // only destroyed once. Also, be careful to activate the
0933: // namespace for each class, so that private variables can
0934: // be accessed.
0935:
0936: hier = new ItclHierIter();
0937: Class.InitHierIter(hier, contextObj.classDefn);
0938: cd = Class.AdvanceHierIter(hier);
0939: while (cd != null) {
0940:
0941: boolean pushErr = false;
0942:
0943: context = new ItclContext(interp);
0944:
0945: try {
0946: Methods.PushContext(interp, null, cd, contextObj,
0947: context);
0948: } catch (TclException ex) {
0949: pushErr = true;
0950: }
0951:
0952: if (!pushErr) {
0953: for (Iterator iter = cd.variables.entrySet().iterator(); iter
0954: .hasNext();) {
0955: Map.Entry entry = (Map.Entry) iter.next();
0956: String key = (String) entry.getKey();
0957: vdefn = (ItclVarDefn) entry.getValue();
0958:
0959: if ((vdefn.member.flags & ItclInt.THIS_VAR) != 0) {
0960: if (cd == contextObj.classDefn) {
0961: try {
0962: interp.unsetVar(vdefn.member.fullname,
0963: 0);
0964: } catch (TclException ex) {
0965: }
0966: }
0967: } else if ((vdefn.member.flags & ItclInt.COMMON) == 0) {
0968: try {
0969: interp.unsetVar(vdefn.member.fullname, 0);
0970: } catch (TclException ex) {
0971: }
0972: }
0973: }
0974: Methods.PopContext(interp, context);
0975: }
0976:
0977: cd = Class.AdvanceHierIter(hier);
0978: }
0979: Class.DeleteHierIter(hier);
0980:
0981: // Free the memory associated with object-specific variables.
0982: // For normal variables this would be done automatically by
0983: // CleanupVar() when the variable is unset. But object-specific
0984: // variables are protected by an extra reference count, and they
0985: // must be deleted explicitly here.
0986:
0987: for (int i = 0; i < contextObj.dataSize; i++) {
0988: if (contextObj.data[i] != null) {
0989: contextObj.data[i] = null;
0990: }
0991: }
0992:
0993: Util.RestoreInterpState(interp, istate);
0994:
0995: // Free any remaining memory associated with the object.
0996:
0997: contextObj.data = null;
0998:
0999: if (contextObj.constructed != null) {
1000: contextObj.constructed.clear();
1001: contextObj.constructed = null;
1002: }
1003: if (contextObj.destructed != null) {
1004: contextObj.destructed.clear();
1005: contextObj.destructed = null;
1006: }
1007: Util.ReleaseData(contextObj.classDefn);
1008: }
1009:
1010: /*
1011: * ------------------------------------------------------------------------
1012: * ItclCreateObjVar -> Objects.CreateObjVar
1013: *
1014: * Creates one variable acting as a data member for a specific
1015: * object. Initializes the variable according to its definition,
1016: * and sets up its reference count so that it cannot be deleted
1017: * by ordinary means. Installs the new variable directly into
1018: * the data array for the specified object.
1019: * ------------------------------------------------------------------------
1020: */
1021:
1022: static void CreateObjVar(Interp interp, // interpreter managing this object
1023: ItclVarDefn vdefn, // variable definition
1024: ItclObject contextObj) // object being updated
1025: {
1026: Var var;
1027: ItclVarLookup vlookup;
1028: ItclContext context;
1029:
1030: var = Migrate.NewVar();
1031: ItclAccess.createObjVar(var, vdefn.member.name,
1032: vdefn.member.classDefn.namesp, dangleTable);
1033:
1034: // Install the new variable in the object's data array.
1035: // Look up the appropriate index for the object using
1036: // the data table in the class definition.
1037:
1038: vlookup = (ItclVarLookup) contextObj.classDefn.resolveVars
1039: .get(vdefn.member.fullname);
1040:
1041: if (vlookup != null) {
1042: contextObj.data[vlookup.index] = var;
1043: }
1044:
1045: // If this variable has an initial value, initialize it
1046: // here using a "set" command.
1047: //
1048: // TRICKY NOTE: We push an object context for the class that
1049: // owns the variable, so that we don't have any trouble
1050: // accessing it.
1051:
1052: if (vdefn.init != null) {
1053: context = new ItclContext(interp);
1054: try {
1055: Methods.PushContext(interp, null,
1056: vdefn.member.classDefn, contextObj, context);
1057: interp.setVar(vdefn.member.fullname, TclString
1058: .newInstance(vdefn.init), 0);
1059: } catch (TclException ex) {
1060: // No-op
1061: } finally {
1062: Methods.PopContext(interp, context);
1063: }
1064: }
1065: }
1066:
1067: /*
1068: * ------------------------------------------------------------------------
1069: * Itcl_ScopedVarResolver -> Objects.ScopedVarResolver
1070: *
1071: * This procedure is installed to handle variable resolution throughout
1072: * an entire interpreter. It looks for scoped variable references of
1073: * the form:
1074: *
1075: * @itcl ::namesp::namesp::object variable
1076: *
1077: * If a reference like this is recognized, this procedure finds the
1078: * desired variable in the object and returns the variable. If the
1079: * variable does not start with "@itcl", this procedure returns
1080: * null and variable resolution continues using the normal rules.
1081: * If anything goes wrong, this procedure raises a TclException
1082: * and variable access is denied.
1083: * ------------------------------------------------------------------------
1084: */
1085:
1086: static Var ScopedVarResolver(Interp interp, // current interpreter
1087: String name, // variable name being resolved
1088: Namespace contextNs, // current namespace context
1089: int flags) // TCL.LEAVE_ERR_MSG => leave error message
1090: throws TclException {
1091: ItclObject contextObj;
1092: ItclVarLookup vlookup;
1093:
1094: // See if the variable starts with "@itcl". If not, then
1095: // let the variable resolution process continue.
1096:
1097: if (!name.startsWith("@itcl")) {
1098: return null;
1099: }
1100:
1101: // Break the variable name into parts and extract the object
1102: // name and the variable name.
1103:
1104: // Note: Always assume that an exception should be raised on error
1105: // which ignores TCL.LEAVE_ERR_MSG.
1106:
1107: TclObject list = TclString.newInstance(name);
1108: TclObject[] elems = TclList.getElements(interp, list);
1109:
1110: if (elems.length != 3) {
1111: throw new TclException(interp, "scoped variable \"" + name
1112: + "\" is malformed: "
1113: + "should be: @itcl object variable");
1114: }
1115:
1116: // Look for the command representing the object and extract
1117: // the object context.
1118:
1119: WrappedCommand wcmd = Namespace.findCommand(interp, elems[1]
1120: .toString(), null, 0);
1121: if (Objects.IsObject(wcmd)) {
1122: contextObj = Objects.GetContextFromObject(wcmd);
1123: } else {
1124: throw new TclException(interp,
1125: "can't resolve scoped variable \"" + name + "\": "
1126: + "can't find object " + elems[1]);
1127: }
1128:
1129: // Resolve the variable with respect to the most-specific
1130: // class definition.
1131:
1132: vlookup = (ItclVarLookup) contextObj.classDefn.resolveVars
1133: .get(elems[2].toString());
1134: if (vlookup == null) {
1135: throw new TclException(interp,
1136: "can't resolve scoped variable \"" + name + "\": "
1137: + "no such data member " + elems[2]);
1138: }
1139:
1140: return contextObj.data[vlookup.index];
1141: }
1142:
1143: static class ScopedVarResolverImpl implements Resolver {
1144: public WrappedCommand resolveCmd(Interp interp, // The current interpreter.
1145: String name, // Command name to resolve.
1146: Namespace context, // The namespace to look in.
1147: int flags) // 0 or TCL.LEAVE_ERR_MSG.
1148: throws TclException // Tcl exceptions are thrown for Tcl errors.
1149: {
1150: return null; // Do not resolve anything
1151: }
1152:
1153: public Var resolveVar(Interp interp, // The current interpreter.
1154: String name, // Variable name to resolve.
1155: Namespace context, // The namespace to look in.
1156: int flags) // 0 or TCL.LEAVE_ERR_MSG.
1157: throws TclException // Tcl exceptions are thrown for Tcl errors.
1158: {
1159: return Objects.ScopedVarResolver(interp, name, context,
1160: flags);
1161: }
1162: }
1163:
1164: } // end class Objects
|