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 file defines information that tracks classes and objects
0016: * at a global level for a given interpreter.
0017: *
0018: * ========================================================================
0019: * AUTHOR: Michael J. McLennan
0020: * Bell Labs Innovations for Lucent Technologies
0021: * mmclennan@lucent.com
0022: * http://www.tcltk.com/itcl
0023: *
0024: * RCS: $Id: Cmds.java,v 1.4 2006/01/26 19:49:18 mdejong Exp $
0025: * ========================================================================
0026: * Copyright (c) 1993-1998 Lucent Technologies, Inc.
0027: * ------------------------------------------------------------------------
0028: * See the file "license.itcl" for information on usage and redistribution
0029: * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
0030: */
0031:
0032: package itcl.lang;
0033:
0034: import tcl.lang.*;
0035:
0036: import java.util.Map;
0037: import java.util.HashMap;
0038: import java.util.Iterator;
0039:
0040: class Cmds {
0041:
0042: // The following string is the startup script executed in new
0043: // interpreters. It locates the Tcl code in the [incr Tcl] library
0044: // directory and loads it in.
0045:
0046: static String initScript = "namespace eval ::itcl { source resource:/itcl/lang/library/itcl.tcl }";
0047:
0048: // The following script is used to initialize Itcl in a safe interpreter.
0049:
0050: static String safeInitScript = "proc ::itcl::local {class name args} {\n"
0051: + " set ptr [uplevel [list $class $name] $args]\n"
0052: + " uplevel [list set itcl-local-$ptr $ptr]\n"
0053: + " set cmd [uplevel namespace which -command $ptr]\n"
0054: + " uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n"
0055: + " return $ptr\n" + "}";
0056:
0057: static int itclCompatFlags = -1;
0058:
0059: /*
0060: * ------------------------------------------------------------------------
0061: * Initialize -> Cmds.Initialize
0062: *
0063: * Invoked whenever a new interpeter is created to install the
0064: * [incr Tcl] package. Usually invoked within Tcl_AppInit() at
0065: * the start of execution.
0066: *
0067: * Creates the "::itcl" namespace and installs access commands for
0068: * creating classes and querying info.
0069: *
0070: * Will raise a TclException to indicate failure.
0071: * ------------------------------------------------------------------------
0072: */
0073:
0074: static void Initialize(Interp interp) // interpreter to be updated
0075: throws TclException {
0076: Namespace itclNs;
0077: ItclObjectInfo info;
0078:
0079: String TCL_VERSION = "8.0";
0080: interp.pkgRequire("Tcl", TCL_VERSION, false);
0081:
0082: // See if [incr Tcl] is already installed.
0083:
0084: if (interp.getCommand("::itcl::class") != null) {
0085: throw new TclException(interp,
0086: "already installed: [incr Tcl]");
0087: }
0088:
0089: // Skip compatability options stuff
0090:
0091: itclCompatFlags = 0;
0092:
0093: // Initialize the ensemble package first, since we need this
0094: // for other parts of [incr Tcl].
0095:
0096: Ensemble.EnsembleInit(interp);
0097:
0098: // Create the top-level data structure for tracking objects.
0099: // Store this as "associated data" for easy access, but link
0100: // it to the itcl namespace for ownership.
0101:
0102: info = new ItclObjectInfo();
0103: info.interp = interp;
0104: info.objects = new HashMap();
0105: info.transparentFrames = new Itcl_Stack();
0106: Util.InitStack(info.transparentFrames);
0107: info.contextFrames = new HashMap();
0108: info.protection = Itcl.DEFAULT_PROTECT;
0109: info.cdefnStack = new Itcl_Stack();
0110: Util.InitStack(info.cdefnStack);
0111:
0112: interp.setAssocData(ItclInt.INTERP_DATA, info);
0113:
0114: // Install commands into the "::itcl" namespace.
0115:
0116: interp.createCommand("::itcl::class", new Parse.ClassCmd(info));
0117: Util.PreserveData(info);
0118:
0119: interp.createCommand("::itcl::body", new Methods.BodyCmd());
0120: interp.createCommand("::itcl::configbody",
0121: new Methods.ConfigBodyCmd());
0122:
0123: //Util.EventuallyFree(info, ItclDelObjectInfo);
0124:
0125: // Create the "itcl::find" command for high-level queries.
0126:
0127: Ensemble.CreateEnsemble(interp, "::itcl::find");
0128: Ensemble.AddEnsemblePart(interp, "::itcl::find", "classes",
0129: "?pattern?", new FindClassesCmd(info));
0130: Util.PreserveData(info);
0131:
0132: Ensemble.AddEnsemblePart(interp, "::itcl::find", "objects",
0133: "?-class className? ?-isa className? ?pattern?",
0134: new FindObjectsCmd(info));
0135: Util.PreserveData(info);
0136:
0137: // Create the "itcl::delete" command to delete objects
0138: // and classes.
0139:
0140: Ensemble.CreateEnsemble(interp, "::itcl::delete");
0141: Ensemble.AddEnsemblePart(interp, "::itcl::delete", "class",
0142: "name ?name...?", new DelClassCmd(info));
0143: Util.PreserveData(info);
0144:
0145: Ensemble.AddEnsemblePart(interp, "::itcl::delete", "object",
0146: "name ?name...?", new DelObjectCmd(info));
0147: Util.PreserveData(info);
0148:
0149: // Create the "itcl::is" command to test object
0150: // and classes existence.
0151:
0152: Ensemble.CreateEnsemble(interp, "::itcl::is");
0153: Ensemble.AddEnsemblePart(interp, "::itcl::is", "class", "name",
0154: new IsClassCmd(info));
0155: Util.PreserveData(info);
0156:
0157: Ensemble.AddEnsemblePart(interp, "::itcl::is", "object",
0158: "?-class classname? name", new IsObjectCmd(info));
0159: Util.PreserveData(info);
0160:
0161: // Add "code" and "scope" commands for handling scoped values.
0162:
0163: interp.createCommand("::itcl::code", new CodeCmd());
0164: interp.createCommand("::itcl::scope", new ScopeCmd());
0165:
0166: // Add commands for handling import stubs at the Tcl level.
0167:
0168: Ensemble.CreateEnsemble(interp, "::itcl::import::stub");
0169: Ensemble.AddEnsemblePart(interp, "::itcl::import::stub",
0170: "create", "name", new StubCreateCmd());
0171: Ensemble.AddEnsemblePart(interp, "::itcl::import::stub",
0172: "exists", "name", new StubExistsCmd());
0173:
0174: // Install a variable resolution procedure to handle scoped
0175: // values everywhere within the interpreter.
0176:
0177: Resolver resolver = new Objects.ScopedVarResolverImpl();
0178: interp.addInterpResolver("itcl", resolver);
0179:
0180: // Install the "itcl::parser" namespace used to parse the
0181: // class definitions.
0182:
0183: Parse.ParseInit(interp, info);
0184:
0185: // Create "itcl::builtin" namespace for commands that
0186: // are automatically built into class definitions.
0187:
0188: BiCmds.BiInit(interp);
0189:
0190: // Export all commands in the "itcl" namespace so that they
0191: // can be imported with something like "namespace import itcl::*"
0192:
0193: itclNs = Namespace.findNamespace(interp, "::itcl", null,
0194: TCL.LEAVE_ERR_MSG);
0195:
0196: if (itclNs == null) {
0197: throw new TclException(interp, interp.getResult()
0198: .toString());
0199: }
0200:
0201: // This was changed from a glob export (itcl::*) to explicit
0202: // command exports, so that the itcl::is command can *not* be
0203: // exported. This is done for concern that the itcl::is command
0204: // imported might be confusing ("is").
0205:
0206: Namespace.exportList(interp, itclNs, "body", true);
0207: Namespace.exportList(interp, itclNs, "class", false);
0208: Namespace.exportList(interp, itclNs, "code", false);
0209: Namespace.exportList(interp, itclNs, "configbody", false);
0210: Namespace.exportList(interp, itclNs, "delete", false);
0211: Namespace.exportList(interp, itclNs, "delete_helper", false);
0212: Namespace.exportList(interp, itclNs, "ensemble", false);
0213: Namespace.exportList(interp, itclNs, "find", false);
0214: Namespace.exportList(interp, itclNs, "local", false);
0215: Namespace.exportList(interp, itclNs, "scope", false);
0216:
0217: // Set up the variables containing version info.
0218:
0219: interp.setVar("::itcl::patchLevel", TclString
0220: .newInstance(Itcl.PATCH_LEVEL), TCL.NAMESPACE_ONLY);
0221:
0222: interp.setVar("::itcl::version", TclString
0223: .newInstance(Itcl.VERSION), TCL.NAMESPACE_ONLY);
0224:
0225: // Package is now loaded.
0226: // Note that we don't run a pkgProvide here since it is done as
0227: // part of the package ifneeded script and so that Itcl can
0228: // be loaded via the java::load command.
0229:
0230: //interp.pkgProvide("Itcl", Itcl.PATCH_LEVEL);
0231: }
0232:
0233: /*
0234: * ------------------------------------------------------------------------
0235: * Itcl_Init -> Cmds.Init
0236: *
0237: * Invoked whenever a new INTERPRETER is created to install the
0238: * [incr Tcl] package. Usually invoked within Tcl_AppInit() at
0239: * the start of execution.
0240: *
0241: * Creates the "::itcl" namespace and installs access commands for
0242: * creating classes and querying info.
0243: *
0244: * Will raise a TclException to indicate failure.
0245: * ------------------------------------------------------------------------
0246: */
0247:
0248: static void Init(Interp interp) // interpreter to be updated
0249: throws TclException {
0250: Initialize(interp);
0251: interp.eval(initScript);
0252: }
0253:
0254: /*
0255: * ------------------------------------------------------------------------
0256: * Itcl_SafeInit -> Cmds.SafeInit
0257: *
0258: * Invoked whenever a new SAFE INTERPRETER is created to install
0259: * the [incr Tcl] package.
0260: *
0261: * Creates the "::itcl" namespace and installs access commands for
0262: * creating classes and querying info.
0263: *
0264: * Will raise a TclException to indicate failure.
0265: * ------------------------------------------------------------------------
0266: */
0267:
0268: static void SafeInit(Interp interp) // interpreter to be updated
0269: throws TclException {
0270: Initialize(interp);
0271: interp.eval(safeInitScript);
0272: }
0273:
0274: /*
0275: * ------------------------------------------------------------------------
0276: * ItclDelObjectInfo -> Cmds.DelObjectInfo
0277: *
0278: * Invoked when the management info for [incr Tcl] is no longer being
0279: * used in an interpreter. This will only occur when all class
0280: * manipulation commands are removed from the interpreter.
0281: * ------------------------------------------------------------------------
0282: */
0283:
0284: static void DelObjectInfo(ItclObjectInfo info) // client data for class command
0285: {
0286: ItclObject contextObj;
0287:
0288: // Destroy all known objects by deleting their access
0289: // commands. Use FirstHashEntry to always reset the
0290: // search after deleteCommandFromToken() (Fix 227804).
0291:
0292: while ((contextObj = (ItclObject) ItclAccess
0293: .FirstHashEntry(info.objects)) != null) {
0294: info.interp.deleteCommandFromToken(contextObj.w_accessCmd);
0295: }
0296: info.objects.clear();
0297: info.objects = null;
0298:
0299: // Discard all known object contexts.
0300:
0301: for (Iterator iter = info.contextFrames.entrySet().iterator(); iter
0302: .hasNext();) {
0303: Map.Entry entry = (Map.Entry) iter.next();
0304: contextObj = (ItclObject) entry.getValue();
0305: Util.ReleaseData(contextObj);
0306: }
0307: info.contextFrames.clear();
0308: info.contextFrames = null;
0309:
0310: Util.DeleteStack(info.transparentFrames);
0311: info.transparentFrames = null;
0312: Util.DeleteStack(info.cdefnStack);
0313: info.cdefnStack = null;
0314: }
0315:
0316: /*
0317: * ------------------------------------------------------------------------
0318: * Itcl_FindClassesCmd -> Cmds.FindClassesCmd.cmdProc
0319: *
0320: * Invoked by Tcl whenever the user issues an "itcl::find classes"
0321: * command to query the list of known classes. Handles the following
0322: * syntax:
0323: *
0324: * find classes ?<pattern>?
0325: *
0326: * Will raise a TclException to indicate failure.
0327: * ------------------------------------------------------------------------
0328: */
0329:
0330: static class FindClassesCmd implements CommandWithDispose {
0331: ItclObjectInfo info;
0332:
0333: FindClassesCmd(ItclObjectInfo info) {
0334: this .info = info;
0335: }
0336:
0337: public void disposeCmd() {
0338: Util.ReleaseData(info);
0339: }
0340:
0341: public void cmdProc(Interp interp, // Current interp.
0342: TclObject[] objv) // Args passed to the command.
0343: throws TclException {
0344: Namespace activeNs = Namespace.getCurrentNamespace(interp);
0345: Namespace globalNs = Namespace.getGlobalNamespace(interp);
0346: boolean forceFullNames = false;
0347:
0348: String pattern;
0349: String cmdName;
0350: boolean newEntry, handledActiveNs;
0351: // Maps WrappedCommand to the empty string
0352: HashMap unique;
0353: Itcl_Stack search;
0354: WrappedCommand cmd, originalCmd;
0355: Namespace ns;
0356: TclObject obj, result;
0357:
0358: if (objv.length > 2) {
0359: throw new TclNumArgsException(interp, 1, objv,
0360: "?pattern?");
0361: }
0362:
0363: if (objv.length == 2) {
0364: pattern = objv[1].toString();
0365: forceFullNames = (pattern.indexOf("::") != -1);
0366: } else {
0367: pattern = null;
0368: }
0369:
0370: // Search through all commands in the current namespace first,
0371: // in the global namespace next, then in all child namespaces
0372: // in this interpreter. If we find any commands that
0373: // represent classes, report them.
0374:
0375: search = new Itcl_Stack();
0376: Util.InitStack(search);
0377: Util.PushStack(globalNs, search);
0378: Util.PushStack(activeNs, search); // last in, first out!
0379:
0380: unique = new HashMap();
0381: result = TclList.newInstance();
0382:
0383: handledActiveNs = false;
0384: while (Util.GetStackSize(search) > 0) {
0385: ns = (Namespace) Util.PopStack(search);
0386: if (ns == activeNs && handledActiveNs) {
0387: continue;
0388: }
0389:
0390: for (Iterator iter = ns.cmdTable.entrySet().iterator(); iter
0391: .hasNext();) {
0392: Map.Entry entry = (Map.Entry) iter.next();
0393: String key = (String) entry.getKey();
0394: cmd = (WrappedCommand) entry.getValue();
0395:
0396: if (Class.IsClass(cmd)) {
0397: originalCmd = Namespace.getOriginalCommand(cmd);
0398:
0399: // Report full names if:
0400: // - the pattern has namespace qualifiers
0401: // - the class namespace is not in the current namespace
0402: // - the class's object creation command is imported from
0403: // another namespace.
0404: //
0405: // Otherwise, report short names.
0406:
0407: if (forceFullNames || ns != activeNs
0408: || originalCmd != null) {
0409: cmdName = interp.getCommandFullName(cmd);
0410: obj = TclString.newInstance(cmdName);
0411: } else {
0412: cmdName = interp.getCommandName(cmd);
0413: obj = TclString.newInstance(cmdName);
0414: }
0415:
0416: if (originalCmd != null) {
0417: cmd = originalCmd;
0418: }
0419: newEntry = (unique.put(cmd, "") == null);
0420: if (newEntry
0421: && (pattern == null || tcl.lang.Util
0422: .stringMatch(cmdName, pattern))) {
0423: TclList.append(interp, result, obj);
0424: } else {
0425: // if not appended to the result, free obj
0426: //Tcl_DecrRefCount(objPtr);
0427: }
0428:
0429: }
0430: }
0431: handledActiveNs = true; // don't process the active namespace twice
0432:
0433: // Push any child namespaces onto the stack and continue
0434: // the search in those namespaces.
0435:
0436: for (Iterator iter = ns.childTable.entrySet()
0437: .iterator(); iter.hasNext();) {
0438: Map.Entry entry = (Map.Entry) iter.next();
0439: String key = (String) entry.getKey();
0440: Namespace child = (Namespace) entry.getValue();
0441: Util.PushStack(child, search);
0442: }
0443: }
0444: unique.clear();
0445: Util.DeleteStack(search);
0446:
0447: interp.setResult(result);
0448: }
0449: } // end class FindClassesCmd
0450:
0451: /*
0452: * ------------------------------------------------------------------------
0453: * Itcl_FindObjectsCmd -> Cmds.FindObjectsCmd.cmdProc
0454: *
0455: * Invoked by Tcl whenever the user issues an "itcl::find objects"
0456: * command to query the list of known objects. Handles the following
0457: * syntax:
0458: *
0459: * find objects ?-class <className>? ?-isa <className>? ?<pattern>?
0460: *
0461: * Will raise a TclException to indicate failure.
0462: * ------------------------------------------------------------------------
0463: */
0464:
0465: static class FindObjectsCmd implements CommandWithDispose {
0466: ItclObjectInfo info;
0467:
0468: FindObjectsCmd(ItclObjectInfo info) {
0469: this .info = info;
0470: }
0471:
0472: public void disposeCmd() {
0473: Util.ReleaseData(info);
0474: }
0475:
0476: public void cmdProc(Interp interp, // Current interp.
0477: TclObject[] objv) // Args passed to the command.
0478: throws TclException {
0479: Namespace activeNs = Namespace.getCurrentNamespace(interp);
0480: Namespace globalNs = Namespace.getGlobalNamespace(interp);
0481: boolean forceFullNames = false;
0482:
0483: String pattern = null;
0484: ItclClass classDefn = null;
0485: ItclClass isaDefn = null;
0486:
0487: String name = null, token = null;
0488: String cmdName = null;
0489: boolean newEntry, match, handledActiveNs;
0490: int pos;
0491: ItclObject contextObj;
0492: HashMap unique;
0493: Itcl_Stack search;
0494: WrappedCommand wcmd, originalCmd;
0495: Namespace ns;
0496: TclObject obj;
0497: TclObject result = TclList.newInstance();
0498:
0499: // Parse arguments:
0500: // objects ?-class <className>? ?-isa <className>? ?<pattern>?
0501:
0502: pos = 0;
0503: while (++pos < objv.length) {
0504: token = objv[pos].toString();
0505: if (token.length() == 0 || token.charAt(0) != '-') {
0506: if (pattern == null) {
0507: pattern = token;
0508: forceFullNames = (pattern.indexOf("::") != -1);
0509: } else {
0510: break;
0511: }
0512: } else if ((pos + 1 < objv.length)
0513: && (token.equals("-class"))) {
0514: name = objv[pos + 1].toString();
0515: classDefn = Class.FindClass(interp, name, true);
0516: if (classDefn == null) {
0517: throw new TclException(interp, interp
0518: .getResult().toString());
0519: }
0520: pos++;
0521: } else if ((pos + 1 < objv.length)
0522: && (token.equals("-isa"))) {
0523: name = objv[pos + 1].toString();
0524: isaDefn = Class.FindClass(interp, name, true);
0525: if (isaDefn == null) {
0526: throw new TclException(interp, interp
0527: .getResult().toString());
0528: }
0529: pos++;
0530: }
0531:
0532: // Last token? Take it as the pattern, even if it starts
0533: // with a "-". This allows us to match object names that
0534: // start with "-".
0535:
0536: else if (pos == objv.length - 1 && pattern == null) {
0537: pattern = token;
0538: forceFullNames = (pattern.indexOf("::") != -1);
0539: } else {
0540: break;
0541: }
0542: }
0543:
0544: if (pos < objv.length) {
0545: throw new TclNumArgsException(interp, 1, objv,
0546: "?-class className? ?-isa className? ?pattern?");
0547: }
0548:
0549: // Search through all commands in the current namespace first,
0550: // in the global namespace next, then in all child namespaces
0551: // in this interpreter. If we find any commands that
0552: // represent objects, report them.
0553:
0554: search = new Itcl_Stack();
0555: Util.InitStack(search);
0556: Util.PushStack(globalNs, search);
0557: Util.PushStack(activeNs, search); // last in, first out!
0558:
0559: unique = new HashMap();
0560:
0561: handledActiveNs = false;
0562: while (Util.GetStackSize(search) > 0) {
0563: ns = (Namespace) Util.PopStack(search);
0564: if (ns == activeNs && handledActiveNs) {
0565: continue;
0566: }
0567:
0568: for (Iterator iter = ns.cmdTable.entrySet().iterator(); iter
0569: .hasNext();) {
0570: Map.Entry entry = (Map.Entry) iter.next();
0571: String key = (String) entry.getKey();
0572: wcmd = (WrappedCommand) entry.getValue();
0573:
0574: if (Objects.IsObject(wcmd)) {
0575: originalCmd = Namespace
0576: .getOriginalCommand(wcmd);
0577: if (originalCmd != null) {
0578: wcmd = originalCmd;
0579: }
0580: contextObj = Objects.GetContextFromObject(wcmd);
0581:
0582: // Report full names if:
0583: // - the pattern has namespace qualifiers
0584: // - the class namespace is not in the current namespace
0585: // - the class's object creation command is imported from
0586: // another namespace.
0587: //
0588: // Otherwise, report short names.
0589:
0590: if (forceFullNames || ns != activeNs
0591: || originalCmd != null) {
0592: cmdName = interp.getCommandFullName(wcmd);
0593: obj = TclString.newInstance(cmdName);
0594: } else {
0595: cmdName = interp.getCommandName(wcmd);
0596: obj = TclString.newInstance(cmdName);
0597: }
0598:
0599: newEntry = (unique.put(wcmd, "") == null);
0600:
0601: match = false;
0602: if (newEntry
0603: && (pattern == null || tcl.lang.Util
0604: .stringMatch(cmdName, pattern))) {
0605: if (classDefn == null
0606: || (contextObj.classDefn == classDefn)) {
0607: if (isaDefn == null) {
0608: match = true;
0609: } else {
0610: if (contextObj.classDefn.heritage
0611: .get(isaDefn) != null) {
0612: match = true;
0613: }
0614: }
0615: }
0616: }
0617:
0618: if (match) {
0619: TclList.append(interp, result, obj);
0620: } else {
0621: //Tcl_DecrRefCount(objPtr); // throw away the name
0622: }
0623: }
0624: }
0625: handledActiveNs = true; // don't process the active namespace twice
0626:
0627: // Push any child namespaces onto the stack and continue
0628: // the search in those namespaces.
0629:
0630: for (Iterator iter = ns.childTable.entrySet()
0631: .iterator(); iter.hasNext();) {
0632: Map.Entry entry = (Map.Entry) iter.next();
0633: //String key = (String) entry.getKey();
0634: Namespace child = (Namespace) entry.getValue();
0635:
0636: Util.PushStack(child, search);
0637: }
0638: }
0639: unique.clear();
0640: Util.DeleteStack(search);
0641:
0642: interp.setResult(result);
0643: }
0644: } // end class FindObjectsCmd
0645:
0646: /*
0647: * ------------------------------------------------------------------------
0648: * Itcl_ProtectionCmd -> Cmds.ProtectionCmd.cmdProc
0649: *
0650: * Invoked by Tcl whenever the user issues a protection setting
0651: * command like "public" or "private". Creates commands and
0652: * variables, and assigns a protection level to them. Protection
0653: * levels are defined as follows:
0654: *
0655: * public => accessible from any namespace
0656: * protected => accessible from selected namespaces
0657: * private => accessible only in the namespace where it was defined
0658: *
0659: * Handles the following syntax:
0660: *
0661: * public <command> ?<arg> <arg>...?
0662: *
0663: * Will raise a TclException to indicate failure.
0664: * ------------------------------------------------------------------------
0665: */
0666:
0667: static class ProtectionCmd implements Command {
0668: public void cmdProc(Interp interp, // Current interp.
0669: TclObject[] objv) // Args passed to the command.
0670: throws TclException {
0671: // As far as I can tell, this function is not used and
0672: // Itcl_ClassProtectionCmd used instead.
0673: throw new TclRuntimeError("unused function");
0674: }
0675: } // end class ProtectionCmd
0676:
0677: /*
0678: * ------------------------------------------------------------------------
0679: * Itcl_DelClassCmd -> Cmds.DelClassCmd.cmdProc
0680: *
0681: * Part of the "delete" ensemble. Invoked by Tcl whenever the
0682: * user issues a "delete class" command to delete classes.
0683: * Handles the following syntax:
0684: *
0685: * delete class <name> ?<name>...?
0686: *
0687: * Will raise a TclException to indicate failure.
0688: * ------------------------------------------------------------------------
0689: */
0690:
0691: static class DelClassCmd implements CommandWithDispose {
0692: ItclObjectInfo info;
0693:
0694: DelClassCmd(ItclObjectInfo info) {
0695: this .info = info;
0696: }
0697:
0698: public void disposeCmd() {
0699: Util.ReleaseData(info);
0700: }
0701:
0702: public void cmdProc(Interp interp, // Current interp.
0703: TclObject[] objv) // Args passed to the command.
0704: throws TclException {
0705: int i;
0706: String name;
0707: ItclClass cdefn;
0708:
0709: // Since destroying a base class will destroy all derived
0710: // classes, calls like "destroy class Base Derived" could
0711: // fail. Break this into two passes: first check to make
0712: // sure that all classes on the command line are valid,
0713: // then delete them.
0714:
0715: for (i = 1; i < objv.length; i++) {
0716: name = objv[i].toString();
0717: cdefn = Class.FindClass(interp, name, true);
0718: if (cdefn == null) {
0719: throw new TclException(interp, interp.getResult()
0720: .toString());
0721: }
0722: }
0723:
0724: for (i = 1; i < objv.length; i++) {
0725: name = objv[i].toString();
0726: cdefn = Class.FindClass(interp, name, false);
0727: if (cdefn != null) {
0728: interp.resetResult();
0729: Class.DeleteClass(interp, cdefn);
0730: }
0731: }
0732: interp.resetResult();
0733: }
0734: } // end class DelClassCmd
0735:
0736: /*
0737: * ------------------------------------------------------------------------
0738: * Itcl_DelObjectCmd -> Cmds.DelObjectCmd.cmdProc
0739: *
0740: * Part of the "delete" ensemble. Invoked by Tcl whenever the user
0741: * issues a "delete object" command to delete [incr Tcl] objects.
0742: * Handles the following syntax:
0743: *
0744: * delete object <name> ?<name>...?
0745: *
0746: * Will raise a TclException to indicate failure.
0747: * ------------------------------------------------------------------------
0748: */
0749:
0750: static class DelObjectCmd implements CommandWithDispose {
0751: ItclObjectInfo info;
0752:
0753: DelObjectCmd(ItclObjectInfo info) {
0754: this .info = info;
0755: }
0756:
0757: public void disposeCmd() {
0758: Util.ReleaseData(info);
0759: }
0760:
0761: public void cmdProc(Interp interp, // Current interp.
0762: TclObject[] objv) // Args passed to the command.
0763: throws TclException {
0764: int i;
0765: String name;
0766: ItclObject contextObj;
0767:
0768: // Scan through the list of objects and attempt to delete them.
0769: // If anything goes wrong (i.e., destructors fail), then
0770: // abort with an error.
0771:
0772: for (i = 1; i < objv.length; i++) {
0773: name = objv[i].toString();
0774: contextObj = Objects.FindObject(interp, name);
0775:
0776: if (contextObj == null) {
0777: throw new TclException(interp, "object \"" + name
0778: + "\" not found");
0779: }
0780:
0781: Objects.DeleteObject(interp, contextObj);
0782: }
0783: }
0784: } // end class DelObjectCmd
0785:
0786: /*
0787: * ------------------------------------------------------------------------
0788: * Itcl_ScopeCmd -> Cmds.ScopeCmd.cmdProc
0789: *
0790: * Invoked by Tcl whenever the user issues a "scope" command to
0791: * create a fully qualified variable name. Handles the following
0792: * syntax:
0793: *
0794: * scope <variable>
0795: *
0796: * If the input string is already fully qualified (starts with "::"),
0797: * then this procedure does nothing. Otherwise, it looks for a
0798: * data member called <variable> and returns its fully qualified
0799: * name. If the <variable> is a common data member, this procedure
0800: * returns a name of the form:
0801: *
0802: * ::namesp::namesp::class::variable
0803: *
0804: * If the <variable> is an instance variable, this procedure returns
0805: * a name of the form:
0806: *
0807: * @itcl ::namesp::namesp::object variable
0808: *
0809: * This kind of scoped value is recognized by the Itcl_ScopedVarResolver
0810: * proc, which handles variable resolution for the entire interpreter.
0811: *
0812: * Will raise a TclException to indicate failure.
0813: * ------------------------------------------------------------------------
0814: */
0815:
0816: static class ScopeCmd implements Command {
0817: public void cmdProc(Interp interp, // Current interp.
0818: TclObject[] objv) // Args passed to the command.
0819: throws TclException {
0820: Namespace contextNs = Namespace.getCurrentNamespace(interp);
0821: String openParen = null;
0822: int openParenStart, openParenEnd;
0823:
0824: int p;
0825: String token;
0826: ItclClass contextClass;
0827: ItclObject contextObj;
0828: ItclObjectInfo info;
0829: CallFrame frame;
0830: ItclVarLookup vlookup;
0831: TclObject obj, list;
0832: Var var;
0833:
0834: if (objv.length != 2) {
0835: throw new TclNumArgsException(interp, 1, objv,
0836: "varname");
0837: }
0838:
0839: // If this looks like a fully qualified name already,
0840: // then return it as is.
0841:
0842: token = objv[1].toString();
0843: if (token.startsWith("::")) {
0844: interp.setResult(objv[1]);
0845: return;
0846: }
0847:
0848: // If the variable name is an array reference, pick out
0849: // the array name and use that for the lookup operations
0850: // below.
0851:
0852: openParenStart = openParenEnd = -1;
0853: for (p = 0; p < token.length(); p++) {
0854: if (token.charAt(p) == '(') {
0855: openParenStart = p;
0856: } else if (token.charAt(p) == ')'
0857: && openParenStart != -1) {
0858: openParenEnd = p;
0859: break;
0860: }
0861: }
0862: if (openParenStart != -1 && openParenEnd != -1) {
0863: openParen = token.substring(openParenStart,
0864: openParenEnd + 1);
0865: token = token.substring(0, openParenStart);
0866: }
0867:
0868: // Figure out what context we're in. If this is a class,
0869: // then look up the variable in the class definition.
0870: // If this is a namespace, then look up the variable in its
0871: // varTable. Note that the normal Itcl_GetContext function
0872: // returns an error if we're not in a class context, so we
0873: // perform a similar function here, the hard way.
0874: //
0875: // TRICKY NOTE: If this is an array reference, we'll get
0876: // the array variable as the variable name. We must be
0877: // careful to add the index (everything from openParen
0878: // onward) as well.
0879:
0880: if (Class.IsClassNamespace(contextNs)) {
0881: contextClass = Class.GetClassFromNamespace(contextNs);
0882:
0883: vlookup = (ItclVarLookup) contextClass.resolveVars
0884: .get(token);
0885: if (vlookup == null) {
0886: throw new TclException(interp, "variable \""
0887: + token + "\" not found in class \""
0888: + contextClass.fullname + "\"");
0889: }
0890:
0891: if ((vlookup.vdefn.member.flags & ItclInt.COMMON) != 0) {
0892: StringBuffer buffer = new StringBuffer(64);
0893: buffer.append(vlookup.vdefn.member.fullname);
0894: if (openParen != null) {
0895: buffer.append(openParen);
0896: openParen = null;
0897: }
0898: interp.setResult(buffer.toString());
0899: return;
0900: }
0901:
0902: // If this is not a common variable, then we better have
0903: // an object context. Return the name "@itcl object variable".
0904:
0905: frame = Migrate.GetCallFrame(interp, 0);
0906: info = contextClass.info;
0907:
0908: contextObj = (ItclObject) info.contextFrames.get(frame);
0909: if (contextObj == null) {
0910: throw new TclException(interp,
0911: "can't scope variable \"" + token
0912: + "\": missing object context\"");
0913: }
0914:
0915: list = TclList.newInstance();
0916: TclList.append(interp, list, TclString
0917: .newInstance("@itcl"));
0918:
0919: TclList
0920: .append(
0921: interp,
0922: list,
0923: TclString
0924: .newInstance(interp
0925: .getCommandFullName(contextObj.w_accessCmd)));
0926:
0927: StringBuffer buffer = new StringBuffer(64);
0928: buffer.append(vlookup.vdefn.member.fullname);
0929:
0930: if (openParen != null) {
0931: buffer.append(openParen);
0932: openParen = null;
0933: }
0934:
0935: TclList.append(interp, list, TclString
0936: .newInstance(buffer.toString()));
0937:
0938: interp.setResult(list);
0939: }
0940:
0941: // We must be in an ordinary namespace context. Resolve
0942: // the variable using Tcl_FindNamespaceVar.
0943: //
0944: // TRICKY NOTE: If this is an array reference, we'll get
0945: // the array variable as the variable name. We must be
0946: // careful to add the index (everything from openParen
0947: // onward) as well.
0948:
0949: else {
0950: StringBuffer buffer = new StringBuffer(64);
0951:
0952: var = Namespace.findNamespaceVar(interp, token,
0953: contextNs, TCL.NAMESPACE_ONLY);
0954:
0955: if (var == null) {
0956: throw new TclException(interp, "variable \""
0957: + token + "\" not found in namespace \""
0958: + contextNs.fullName + "\"");
0959: }
0960:
0961: String fname = Var.getVariableFullName(interp, var);
0962: buffer.append(fname);
0963:
0964: if (openParen != null) {
0965: buffer.append(openParen);
0966: openParen = null;
0967: }
0968:
0969: interp.setResult(buffer.toString());
0970: }
0971:
0972: return;
0973: }
0974: } // end class ScopeCmd
0975:
0976: /*
0977: * ------------------------------------------------------------------------
0978: * Itcl_CodeCmd -> Cmds.CodeCmd.cmdProc
0979: *
0980: * Invoked by Tcl whenever the user issues a "code" command to
0981: * create a scoped command string. Handles the following syntax:
0982: *
0983: * code ?-namespace foo? arg ?arg arg ...?
0984: *
0985: * Unlike the scope command, the code command DOES NOT look for
0986: * scoping information at the beginning of the command. So scopes
0987: * will nest in the code command.
0988: *
0989: * The code command is similar to the "namespace code" command in
0990: * Tcl, but it preserves the list structure of the input arguments,
0991: * so it is a lot more useful.
0992: *
0993: * Will raise a TclException to indicate failure.
0994: * ------------------------------------------------------------------------
0995: */
0996:
0997: static class CodeCmd implements Command {
0998: public void cmdProc(Interp interp, // Current interp.
0999: TclObject[] objv) // Args passed to the command.
1000: throws TclException {
1001: Namespace contextNs = Namespace.getCurrentNamespace(interp);
1002:
1003: int pos;
1004: String token;
1005: TclObject list, obj;
1006:
1007: // Handle flags like "-namespace"...
1008:
1009: for (pos = 1; pos < objv.length; pos++) {
1010: token = objv[pos].toString();
1011: if (token.length() < 2 || token.charAt(0) != '-') {
1012: break;
1013: }
1014:
1015: if (token.equals("-namespace")) {
1016: if (objv.length == 2) {
1017: throw new TclNumArgsException(interp, 1, objv,
1018: "?-namespace name? command ?arg arg...?");
1019: } else {
1020: token = objv[pos + 1].toString();
1021: contextNs = Namespace.findNamespace(interp,
1022: token, null, TCL.LEAVE_ERR_MSG);
1023:
1024: if (contextNs == null) {
1025: throw new TclException(interp, interp
1026: .getResult().toString());
1027: }
1028: pos++;
1029: }
1030: } else if (token.equals("--")) {
1031: pos++;
1032: break;
1033: } else {
1034: throw new TclException(interp, "bad option \""
1035: + token + "\": should be -namespace or --");
1036: }
1037: }
1038:
1039: if (objv.length < 2) {
1040: throw new TclNumArgsException(interp, 1, objv,
1041: "?-namespace name? command ?arg arg...?");
1042: }
1043:
1044: // Now construct a scoped command by integrating the
1045: // current namespace context, and appending the remaining
1046: // arguments AS A LIST...
1047:
1048: list = TclList.newInstance();
1049:
1050: TclList.append(interp, list, TclString
1051: .newInstance("namespace"));
1052: TclList.append(interp, list, TclString
1053: .newInstance("inscope"));
1054:
1055: if (contextNs == Namespace.getGlobalNamespace(interp)) {
1056: obj = TclString.newInstance("::");
1057: } else {
1058: obj = TclString.newInstance(contextNs.fullName);
1059: }
1060: TclList.append(interp, list, obj);
1061:
1062: if (objv.length - pos == 1) {
1063: obj = objv[pos];
1064: } else {
1065: obj = TclList.newInstance();
1066: for (int i = pos; i < objv.length; i++) {
1067: TclList.append(interp, obj, objv[i]);
1068: }
1069: }
1070: TclList.append(interp, list, obj);
1071:
1072: interp.setResult(list);
1073: }
1074: } // end class CodeCmd
1075:
1076: /*
1077: * ------------------------------------------------------------------------
1078: * Itcl_StubCreateCmd -> Cmds.StubCreateCmd.cmdProc
1079: *
1080: * Invoked by Tcl whenever the user issues a "stub create" command to
1081: * create an autoloading stub for imported commands. Handles the
1082: * following syntax:
1083: *
1084: * stub create <name>
1085: *
1086: * Creates a command called <name>. Executing this command will cause
1087: * the real command <name> to be autoloaded.
1088: * ------------------------------------------------------------------------
1089: */
1090:
1091: static class StubCreateCmd implements Command {
1092: public void cmdProc(Interp interp, // Current interp.
1093: TclObject[] objv) // Args passed to the command.
1094: throws TclException {
1095: String cmdName;
1096: WrappedCommand wcmd;
1097:
1098: if (objv.length != 2) {
1099: throw new TclNumArgsException(interp, 1, objv, "name");
1100: }
1101: cmdName = objv[1].toString();
1102:
1103: // Create a stub command with the characteristic ItclDeleteStub
1104: // procedure. That way, we can recognize this command later
1105: // on as a stub. Save the cmd token in the created command,
1106: // instance so we can get the full name of this command later on.
1107:
1108: interp.createCommand(cmdName, new HandleStubCmd());
1109:
1110: wcmd = Namespace.findCommand(interp, cmdName, null,
1111: TCL.NAMESPACE_ONLY);
1112: ((HandleStubCmd) wcmd.cmd).wcmd = wcmd;
1113: }
1114: } // end class StubCreateCmd
1115:
1116: /*
1117: * ------------------------------------------------------------------------
1118: * Itcl_StubExistsCmd -> Cmds.StubExistsCmd.cmdProc
1119: *
1120: * Invoked by Tcl whenever the user issues a "stub exists" command to
1121: * see if an existing command is an autoloading stub. Handles the
1122: * following syntax:
1123: *
1124: * stub exists <name>
1125: *
1126: * Looks for a command called <name> and checks to see if it is an
1127: * autoloading stub. Will set a boolean result as the interp result.
1128: * ------------------------------------------------------------------------
1129: */
1130:
1131: static class StubExistsCmd implements Command {
1132: public void cmdProc(Interp interp, // Current interp.
1133: TclObject[] objv) // Args passed to the command.
1134: throws TclException {
1135: String cmdName;
1136: WrappedCommand wcmd;
1137:
1138: if (objv.length != 2) {
1139: throw new TclNumArgsException(interp, 1, objv, "name");
1140: }
1141: cmdName = objv[1].toString();
1142:
1143: wcmd = Namespace.findCommand(interp, cmdName, null, 0);
1144:
1145: if (wcmd != null && Cmds.IsStub(wcmd)) {
1146: interp.setResult(true);
1147: } else {
1148: interp.setResult(false);
1149: }
1150: }
1151: } // end class StubExistsCmd
1152:
1153: /*
1154: * ------------------------------------------------------------------------
1155: * Itcl_IsStub -> Cmds.IsStub
1156: *
1157: * Checks the given Tcl command to see if it represents an autoloading
1158: * stub created by the "stub create" command. Returns true if
1159: * the command is indeed a stub.
1160: * ------------------------------------------------------------------------
1161: */
1162:
1163: static boolean IsStub(WrappedCommand wcmd) // command being tested
1164: {
1165: // This may be an imported command, but don't try to get the
1166: // original. Just check to see if this particular command
1167: // is a stub. If we really want the original command, we'll
1168: // find it at a higher level.
1169:
1170: if (wcmd.cmd instanceof HandleStubCmd) {
1171: return true;
1172: }
1173: return false;
1174: }
1175:
1176: /*
1177: * ------------------------------------------------------------------------
1178: * ItclHandleStubCmd -> Cmds.HandleStubCmd.cmdProc
1179: *
1180: * Invoked by Tcl to handle commands created by "stub create".
1181: * Calls "auto_load" with the full name of the current command to
1182: * trigger autoloading of the real implementation. Then, calls the
1183: * command to handle its function.
1184: * If successful, this command will set the interpreter result
1185: * with the result from the real implementation.
1186: * Will raise a TclException to indicate failure.
1187: * ------------------------------------------------------------------------
1188: */
1189:
1190: static class HandleStubCmd implements CommandWithDispose {
1191: WrappedCommand wcmd;
1192:
1193: public void cmdProc(Interp interp, // Current interp.
1194: TclObject[] objv) // Args passed to the command.
1195: throws TclException {
1196: int loaded;
1197: String cmdName;
1198: TclObject obj;
1199: TclObject cmdline;
1200: TclObject[] cmdlinev;
1201:
1202: cmdName = interp.getCommandFullName(wcmd);
1203:
1204: // Try to autoload the real command for this stub.
1205:
1206: interp.eval("::auto_load \"" + cmdName + "\"");
1207:
1208: obj = interp.getResult();
1209:
1210: boolean err = false;
1211: loaded = 0;
1212: try {
1213: loaded = TclInteger.get(interp, obj);
1214: } catch (TclException ex) {
1215: err = true;
1216: }
1217: if (err || loaded != 1) {
1218: interp.resetResult();
1219: throw new TclException(interp, "can't autoload \""
1220: + cmdName + "\"");
1221: }
1222:
1223: // At this point, the real implementation has been loaded.
1224: // Invoke the command again with the arguments passed in.
1225:
1226: cmdline = Util.CreateArgs(interp, cmdName, objv, 1);
1227: cmdlinev = TclList.getElements(interp, cmdline);
1228: interp.resetResult();
1229: Util.EvalArgs(interp, cmdlinev);
1230: }
1231:
1232: public void disposeCmd() {
1233: Cmds.ItclDeleteStub(null);
1234: }
1235:
1236: } // end class HandleStubCmd
1237:
1238: /*
1239: * ------------------------------------------------------------------------
1240: * ItclDeleteStub -> Cmds.DeleteStub
1241: *
1242: * Invoked by Tcl whenever a stub command is deleted. This procedure
1243: * does nothing, but its presence identifies a command as a stub.
1244: * ------------------------------------------------------------------------
1245: */
1246:
1247: static void ItclDeleteStub(Object cdata) // not used
1248: {
1249: // do nothing
1250: }
1251:
1252: /*
1253: * ------------------------------------------------------------------------
1254: * Itcl_IsObjectCmd -> Cmds.IsObjectCmd.cmdProc
1255: *
1256: * Invoked by Tcl whenever the user issues an "itcl::is object"
1257: * command to test whether the argument is an object or not.
1258: * syntax:
1259: *
1260: * itcl::is object ?-class classname? commandname
1261: *
1262: * Sets interpreter result to 1 if it is an object, 0 otherwise
1263: * ------------------------------------------------------------------------
1264: */
1265:
1266: static class IsObjectCmd implements CommandWithDispose {
1267: ItclObjectInfo info;
1268:
1269: IsObjectCmd(ItclObjectInfo info) {
1270: this .info = info;
1271: }
1272:
1273: public void disposeCmd() {
1274: Util.ReleaseData(info);
1275: }
1276:
1277: public void cmdProc(Interp interp, // Current interp.
1278: TclObject[] objv) // Args passed to the command.
1279: throws TclException {
1280: boolean classFlag = false;
1281: int idx = 0;
1282: String name = null;
1283: String cname;
1284: String cmdName;
1285: String token;
1286: WrappedCommand wcmd;
1287: Namespace contextNs = null;
1288: ItclClass classDefn = null;
1289: ItclObject contextObj;
1290:
1291: // Handle the arguments.
1292: // objc needs to be either:
1293: // 2 itcl::is object commandname
1294: // 4 itcl::is object -class classname commandname
1295:
1296: if (objv.length != 2 && objv.length != 4) {
1297: throw new TclNumArgsException(interp, 1, objv,
1298: "?-class classname? commandname");
1299: }
1300:
1301: // Parse the command args. Look for the -class
1302: // keyword.
1303:
1304: for (idx = 1; idx < objv.length; idx++) {
1305: token = objv[idx].toString();
1306:
1307: if (token.equals("-class")) {
1308: cname = objv[idx + 1].toString();
1309: classDefn = Class.FindClass(interp, cname, false);
1310:
1311: if (classDefn == null) {
1312: throw new TclException(interp, interp
1313: .getResult().toString());
1314: }
1315:
1316: idx++;
1317: classFlag = true;
1318: } else {
1319: name = objv[idx].toString();
1320: }
1321: } // end for objc loop
1322:
1323: if (name == null) {
1324: throw new TclRuntimeError(
1325: "name not assigned in objc loop");
1326: }
1327:
1328: // The object name may be a scoped value of the form
1329: // "namespace inscope <namesp> <command>". If it is,
1330: // decode it.
1331:
1332: Util.DecodeScopedCommandResult res = Util
1333: .DecodeScopedCommand(interp, name);
1334: contextNs = res.rNS;
1335: cmdName = res.rCmd;
1336:
1337: wcmd = Namespace.findCommand(interp, cmdName, contextNs, 0);
1338:
1339: // Need the null test, or the test will fail if cmd is null
1340:
1341: if (wcmd == null || !Objects.IsObject(wcmd)) {
1342: interp.setResult(false);
1343: return;
1344: }
1345:
1346: // Handle the case when the -class flag is given
1347:
1348: if (classFlag) {
1349: contextObj = Objects.GetContextFromObject(wcmd);
1350: if (!Objects.ObjectIsa(contextObj, classDefn)) {
1351: interp.setResult(false);
1352: return;
1353: }
1354: }
1355:
1356: // Got this far, so assume that it is a valid object
1357:
1358: interp.setResult(true);
1359: return;
1360: }
1361: } // end class IsObjectCmd
1362:
1363: /*
1364: * ------------------------------------------------------------------------
1365: * Itcl_IsClassCmd -> Cmds.IsClassCmd.cmdProc
1366: *
1367: * Invoked by Tcl whenever the user issues an "itcl::is class"
1368: * command to test whether the argument is an itcl class or not
1369: * syntax:
1370: *
1371: * itcl::is class commandname
1372: *
1373: * Sets interpreter result to 1 if it is a class, 0 otherwise
1374: * ------------------------------------------------------------------------
1375: */
1376: static class IsClassCmd implements CommandWithDispose {
1377: ItclObjectInfo info;
1378:
1379: IsClassCmd(ItclObjectInfo info) {
1380: this .info = info;
1381: }
1382:
1383: public void disposeCmd() {
1384: Util.ReleaseData(info);
1385: }
1386:
1387: public void cmdProc(Interp interp, // Current interp.
1388: TclObject[] objv) // Args passed to the command.
1389: throws TclException {
1390: String cname;
1391: String name;
1392: ItclClass classDefn = null;
1393: Namespace contextNs = null;
1394:
1395: // Need itcl::is class classname
1396:
1397: if (objv.length != 2) {
1398: throw new TclNumArgsException(interp, 1, objv,
1399: "commandname");
1400: }
1401:
1402: name = objv[1].toString();
1403:
1404: // The object name may be a scoped value of the form
1405: // "namespace inscope <namesp> <command>". If it is,
1406: // decode it.
1407:
1408: Util.DecodeScopedCommandResult res = Util
1409: .DecodeScopedCommand(interp, name);
1410: contextNs = res.rNS;
1411: cname = res.rCmd;
1412:
1413: classDefn = Class.FindClass(interp, cname, false);
1414:
1415: // If classDefn is null, then it wasn't found, hence it
1416: // isn't a class
1417:
1418: if (classDefn != null) {
1419: interp.setResult(true);
1420: } else {
1421: interp.setResult(false);
1422: }
1423: }
1424: } // end class IsClassCmd
1425:
1426: } // end class Cmds
|