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: * Procedures in this file support the new syntax for [incr Tcl]
0016: * class definitions:
0017: *
0018: * itcl::class <className> {
0019: * inherit <base-class>...
0020: *
0021: * constructor {<arglist>} ?{<init>}? {<body>}
0022: * destructor {<body>}
0023: *
0024: * method <name> {<arglist>} {<body>}
0025: * proc <name> {<arglist>} {<body>}
0026: * variable <name> ?<init>? ?<config>?
0027: * common <name> ?<init>?
0028: *
0029: * public <thing> ?<args>...?
0030: * protected <thing> ?<args>...?
0031: * private <thing> ?<args>...?
0032: * }
0033: *
0034: * ========================================================================
0035: * AUTHOR: Michael J. McLennan
0036: * Bell Labs Innovations for Lucent Technologies
0037: * mmclennan@lucent.com
0038: * http://www.tcltk.com/itcl
0039: *
0040: * RCS: $Id: Parse.java,v 1.2 2005/09/12 00:00:50 mdejong Exp $
0041: * ========================================================================
0042: * Copyright (c) 1993-1998 Lucent Technologies, Inc.
0043: * ------------------------------------------------------------------------
0044: * See the file "license.itcl" for information on usage and redistribution
0045: * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
0046: */
0047:
0048: package itcl.lang;
0049:
0050: import tcl.lang.*;
0051:
0052: //
0053: // Info needed for public/protected/private commands:
0054: //
0055: class ProtectionCmdInfo {
0056: int pLevel; // protection level
0057: ItclObjectInfo info; // info regarding all known objects
0058: }
0059:
0060: class Parse {
0061:
0062: /*
0063: * ------------------------------------------------------------------------
0064: * Itcl_ParseInit -> Parse.ParseInit
0065: *
0066: * Invoked by Itcl_Init() whenever a new interpeter is created to add
0067: * [incr Tcl] facilities. Adds the commands needed to parse class
0068: * definitions. Will raise a TclException if anything goes wrong.
0069: * ------------------------------------------------------------------------
0070: */
0071:
0072: static void ParseInit(Interp interp, // interpreter to be updated
0073: ItclObjectInfo info) // info regarding all known objects
0074: throws TclException {
0075: Namespace parserNs;
0076: ProtectionCmdInfo pInfo;
0077:
0078: // Create the "itcl::parser" namespace used to parse class
0079: // definitions.
0080:
0081: parserNs = Namespace.createNamespace(interp, "::itcl::parser",
0082: null);
0083:
0084: if (parserNs == null) {
0085: throw new TclException(interp,
0086: " (cannot initialize itcl parser)");
0087: }
0088: // We don't preserve the info argument here because it is not associated
0089: // with the namespace created above. The ::itcl::class command created
0090: // below holds a ref to the info object anyway.
0091: //Util.PreserveData(info);
0092:
0093: // Add commands for parsing class definitions.
0094:
0095: interp.createCommand("::itcl::parser::inherit",
0096: new ClassInheritCmd());
0097:
0098: interp.createCommand("::itcl::parser::constructor",
0099: new ClassConstructorCmd());
0100:
0101: interp.createCommand("::itcl::parser::destructor",
0102: new ClassDestructorCmd());
0103:
0104: interp.createCommand("::itcl::parser::method",
0105: new ClassMethodCmd());
0106:
0107: interp
0108: .createCommand("::itcl::parser::proc",
0109: new ClassProcCmd());
0110:
0111: interp.createCommand("::itcl::parser::common",
0112: new ClassCommonCmd());
0113:
0114: interp.createCommand("::itcl::parser::variable",
0115: new ClassVariableCmd());
0116:
0117: pInfo = new ProtectionCmdInfo();
0118: pInfo.pLevel = Itcl.PUBLIC;
0119: pInfo.info = info;
0120:
0121: interp.createCommand("::itcl::parser::public",
0122: new ClassProtectionCmd(pInfo));
0123:
0124: pInfo = new ProtectionCmdInfo();
0125: pInfo.pLevel = Itcl.PROTECTED;
0126: pInfo.info = info;
0127:
0128: interp.createCommand("::itcl::parser::protected",
0129: new ClassProtectionCmd(pInfo));
0130:
0131: pInfo = new ProtectionCmdInfo();
0132: pInfo.pLevel = Itcl.PRIVATE;
0133: pInfo.info = info;
0134:
0135: interp.createCommand("::itcl::parser::private",
0136: new ClassProtectionCmd(pInfo));
0137:
0138: // Set the runtime variable resolver for the parser namespace,
0139: // to control access to "common" data members while parsing
0140: // the class definition.
0141:
0142: Resolver resolver = new ParseVarResolverImpl();
0143: Namespace.setNamespaceResolver(parserNs, resolver);
0144:
0145: // Install the "class" command for defining new classes.
0146:
0147: interp.createCommand("::itcl::class", new Parse.ClassCmd(info));
0148: Util.PreserveData(info);
0149: }
0150:
0151: /*
0152: * ------------------------------------------------------------------------
0153: * Itcl_ClassCmd -> Parse.ClassCmd.cmdProc
0154: *
0155: * Invoked by Tcl whenever the user issues an "itcl::class" command to
0156: * specify a class definition. Handles the following syntax:
0157: *
0158: * itcl::class <className> {
0159: * inherit <base-class>...
0160: *
0161: * constructor {<arglist>} ?{<init>}? {<body>}
0162: * destructor {<body>}
0163: *
0164: * method <name> {<arglist>} {<body>}
0165: * proc <name> {<arglist>} {<body>}
0166: * variable <varname> ?<init>? ?<config>?
0167: * common <varname> ?<init>?
0168: *
0169: * public <args>...
0170: * protected <args>...
0171: * private <args>...
0172: * }
0173: *
0174: * ------------------------------------------------------------------------
0175: */
0176:
0177: static class ClassCmd implements CommandWithDispose {
0178: ItclObjectInfo info;
0179:
0180: ClassCmd(ItclObjectInfo info) {
0181: this .info = info;
0182: }
0183:
0184: public void disposeCmd() {
0185: Util.ReleaseData(info);
0186: }
0187:
0188: public void cmdProc(Interp interp, // Current interp.
0189: TclObject[] objv) // Args passed to the command.
0190: throws TclException {
0191: String className;
0192: Namespace parserNs;
0193: ItclClass cdefn;
0194: CallFrame frame;
0195:
0196: if (objv.length != 3) {
0197: throw new TclNumArgsException(interp, 1, objv,
0198: "name { definition }");
0199: }
0200: className = objv[1].toString();
0201: if (className.length() == 0) {
0202: throw new TclException(interp,
0203: "invalid class name \"\"");
0204: }
0205:
0206: // Find the namespace to use as a parser for the class definition.
0207: // If for some reason it is destroyed, bail out here.
0208:
0209: parserNs = Namespace.findNamespace(interp,
0210: "::itcl::parser", null, TCL.LEAVE_ERR_MSG);
0211:
0212: if (parserNs == null) {
0213: interp
0214: .addErrorInfo("\n (while parsing class definition for \""
0215: + className + "\")");
0216: throw new TclException(interp, interp.getResult()
0217: .toString());
0218: }
0219:
0220: // Try to create the specified class and its namespace.
0221:
0222: cdefn = Class.CreateClass(interp, className, info);
0223:
0224: // Import the built-in commands from the itcl::builtin namespace.
0225: // Do this before parsing the class definition, so methods/procs
0226: // can override the built-in commands.
0227:
0228: try {
0229: Namespace.importList(interp, cdefn.namesp,
0230: "::itcl::builtin::*", true);
0231: } catch (TclException ex) {
0232: interp
0233: .addErrorInfo("\n (while installing built-in commands for class \""
0234: + className + "\")");
0235:
0236: Namespace.deleteNamespace(cdefn.namesp);
0237: throw ex;
0238: }
0239:
0240: // Push this class onto the class definition stack so that it
0241: // becomes the current context for all commands in the parser.
0242: // Activate the parser and evaluate the class definition.
0243:
0244: Util.PushStack(cdefn, info.cdefnStack);
0245:
0246: TclException pex = null;
0247: boolean pushed = false;
0248:
0249: try {
0250: frame = ItclAccess.newCallFrame(interp);
0251: Namespace.pushCallFrame(interp, frame, parserNs, false);
0252: pushed = true;
0253: interp.eval(objv[2].toString());
0254: } catch (TclException ex) {
0255: pex = ex;
0256: } finally {
0257: if (pushed) {
0258: Namespace.popCallFrame(interp);
0259: }
0260: }
0261:
0262: Util.PopStack(info.cdefnStack);
0263:
0264: if (pex != null) {
0265: interp
0266: .addErrorInfo("\n (class \"" + className
0267: + "\" body line "
0268: + interp.getErrorLine() + ")");
0269:
0270: Namespace.deleteNamespace(cdefn.namesp);
0271: throw pex;
0272: }
0273:
0274: // At this point, parsing of the class definition has succeeded.
0275: // Add built-in methods such as "configure" and "cget"--as long
0276: // as they don't conflict with those defined in the class.
0277:
0278: try {
0279: BiCmds.InstallBiMethods(interp, cdefn);
0280: } catch (TclException ex) {
0281: Namespace.deleteNamespace(cdefn.namesp);
0282: throw ex;
0283: }
0284:
0285: // Build the name resolution tables for all data members.
0286:
0287: Class.BuildVirtualTables(cdefn);
0288:
0289: interp.resetResult();
0290: }
0291: } // end class ClassCmd
0292:
0293: /*
0294: * ------------------------------------------------------------------------
0295: * Itcl_ClassInheritCmd -> Parse.ClassInheritCmd.cmdProc
0296: *
0297: * Invoked by Tcl during the parsing of a class definition whenever
0298: * the "inherit" command is invoked to define one or more base classes.
0299: * Handles the following syntax:
0300: *
0301: * inherit <baseclass> ?<baseclass>...?
0302: *
0303: * ------------------------------------------------------------------------
0304: */
0305:
0306: static class ClassInheritCmd implements Command {
0307: public void cmdProc(Interp interp, // Current interp.
0308: TclObject[] objv) // Args passed to the command.
0309: throws TclException {
0310: ItclObjectInfo info = (ItclObjectInfo) interp
0311: .getAssocData(ItclInt.INTERP_DATA);
0312: ItclClass cdefn = (ItclClass) Util
0313: .PeekStack(info.cdefnStack);
0314:
0315: boolean newEntry = true;
0316: String token;
0317: Itcl_ListElem elem, elem2;
0318: ItclClass cd, baseCdefn, badCd;
0319: ItclHierIter hier;
0320: Itcl_Stack stack;
0321: CallFrame frame;
0322:
0323: if (objv.length < 2) {
0324: throw new TclNumArgsException(interp, 1, objv,
0325: "class ?class...?");
0326: }
0327:
0328: // In "inherit" statement can only be included once in a
0329: // class definition.
0330:
0331: elem = Util.FirstListElem(cdefn.bases);
0332: if (elem != null) {
0333: StringBuffer msg = new StringBuffer(64);
0334: msg.append("inheritance \"");
0335:
0336: while (elem != null) {
0337: cd = (ItclClass) Util.GetListValue(elem);
0338: msg.append(cd.name);
0339: msg.append(" ");
0340:
0341: elem = Util.NextListElem(elem);
0342: }
0343:
0344: msg.append("\" already defined for class \"");
0345: msg.append(cdefn.fullname);
0346: msg.append("\"");
0347:
0348: throw new TclException(interp, msg.toString());
0349: }
0350:
0351: // Validate each base class and add it to the "bases" list.
0352:
0353: frame = ItclAccess.newCallFrame(interp);
0354: Namespace.pushCallFrame(interp, frame, cdefn.namesp.parent,
0355: false);
0356:
0357: for (int i = 1; i < objv.length; i++) {
0358:
0359: // Make sure that the base class name is known in the
0360: // parent namespace (currently active). If not, try
0361: // to autoload its definition.
0362:
0363: token = objv[i].toString();
0364: baseCdefn = Class.FindClass(interp, token, true);
0365: if (baseCdefn == null) {
0366: String errmsg = interp.getResult().toString();
0367: interp.resetResult();
0368:
0369: StringBuffer msg = new StringBuffer(64);
0370: msg.append("cannot inherit from \"");
0371: msg.append(token);
0372: msg.append("\"");
0373:
0374: if (errmsg.length() > 0) {
0375: msg.append(" (");
0376: msg.append(errmsg);
0377: msg.append(")");
0378: }
0379:
0380: //goto inheritError;
0381: ClassInheritCmdInheritError(interp, cdefn, msg
0382: .toString());
0383: }
0384:
0385: // Make sure that the base class is not the same as the
0386: // class that is being built.
0387:
0388: if (baseCdefn == cdefn) {
0389: //goto inheritError;
0390: ClassInheritCmdInheritError(interp, cdefn,
0391: "class \"" + cdefn.name
0392: + "\" cannot inherit from itself");
0393: }
0394:
0395: Util.AppendList(cdefn.bases, baseCdefn);
0396: Util.PreserveData(baseCdefn);
0397: }
0398:
0399: // Scan through the inheritance list to make sure that no
0400: // class appears twice.
0401:
0402: elem = Util.FirstListElem(cdefn.bases);
0403: while (elem != null) {
0404: elem2 = Util.NextListElem(elem);
0405: while (elem2 != null) {
0406: if (Util.GetListValue(elem) == Util
0407: .GetListValue(elem2)) {
0408: cd = (ItclClass) Util.GetListValue(elem);
0409: String msg = "class \"" + cdefn.fullname
0410: + "\" cannot inherit base class \""
0411: + cd.fullname + "\" more than once";
0412: //goto inheritError;
0413: ClassInheritCmdInheritError(interp, cdefn, msg);
0414: }
0415: elem2 = Util.NextListElem(elem2);
0416: }
0417: elem = Util.NextListElem(elem);
0418: }
0419:
0420: // Add each base class and all of its base classes into
0421: // the heritage for the current class. Along the way, make
0422: // sure that no class appears twice in the heritage.
0423:
0424: hier = new ItclHierIter();
0425: Class.InitHierIter(hier, cdefn);
0426: cd = Class.AdvanceHierIter(hier); // skip the class itself
0427: cd = Class.AdvanceHierIter(hier);
0428: while (cd != null) {
0429: // Map class def to the empty string in heritage table
0430: Object prev = cdefn.heritage.put(cd, "");
0431: newEntry = (prev == null);
0432:
0433: if (!newEntry) {
0434: break;
0435: }
0436:
0437: cd = Class.AdvanceHierIter(hier);
0438: }
0439: Class.DeleteHierIter(hier);
0440:
0441: // Same base class found twice in the hierarchy?
0442: // Then flag error. Show the list of multiple paths
0443: // leading to the same base class.
0444:
0445: if (!newEntry) {
0446: StringBuffer msg = new StringBuffer(64);
0447:
0448: badCd = cd;
0449: msg.append("class \"");
0450: msg.append(cdefn.fullname);
0451: msg.append("\" inherits base class \"");
0452: msg.append(badCd.fullname);
0453: msg.append("\" more than once:");
0454:
0455: cd = cdefn;
0456: stack = new Itcl_Stack();
0457: Util.InitStack(stack);
0458: Util.PushStack(cd, stack);
0459:
0460: // Show paths leading to bad base class
0461:
0462: while (Util.GetStackSize(stack) > 0) {
0463: cd = (ItclClass) Util.PopStack(stack);
0464:
0465: if (cd == badCd) {
0466: msg.append("\n ");
0467: for (int i = 0; i < Util.GetStackSize(stack); i++) {
0468: if (Util.GetStackValue(stack, i) == null) {
0469: cd = (ItclClass) Util.GetStackValue(
0470: stack, i - 1);
0471: msg.append(cd.name);
0472: msg.append("->");
0473: }
0474: }
0475: msg.append(badCd.name);
0476: } else if (cd == null) {
0477: Util.PopStack(stack);
0478: } else {
0479: elem = Util.LastListElem(cd.bases);
0480: if (elem != null) {
0481: Util.PushStack(cd, stack);
0482: Util.PushStack(null, stack);
0483: while (elem != null) {
0484: Util.PushStack(Util.GetListValue(elem),
0485: stack);
0486: elem = Util.PrevListElem(elem);
0487: }
0488: }
0489: }
0490: }
0491: Util.DeleteStack(stack);
0492: //goto inheritError;
0493: ClassInheritCmdInheritError(interp, cdefn, msg
0494: .toString());
0495: }
0496:
0497: // At this point, everything looks good.
0498: // Finish the installation of the base classes. Update
0499: // each base class to recognize the current class as a
0500: // derived class.
0501:
0502: elem = Util.FirstListElem(cdefn.bases);
0503: while (elem != null) {
0504: baseCdefn = (ItclClass) Util.GetListValue(elem);
0505:
0506: Util.AppendList(baseCdefn.derived, cdefn);
0507: Util.PreserveData(cdefn);
0508:
0509: elem = Util.NextListElem(elem);
0510: }
0511:
0512: Namespace.popCallFrame(interp);
0513: }
0514: } // end class ClassInheritCmd
0515:
0516: // Helper function to simulate inheritError label as goto target.
0517: // This is invoked to tear down the inherit data structures
0518: // and leave the calling function via an Exception.
0519:
0520: static void ClassInheritCmdInheritError(Interp interp,
0521: ItclClass cdefn, String exmsg) throws TclException {
0522: Itcl_ListElem elem;
0523:
0524: Namespace.popCallFrame(interp);
0525:
0526: elem = Util.FirstListElem(cdefn.bases);
0527: while (elem != null) {
0528: ItclClass baseDefn = (ItclClass) Util.GetListValue(elem);
0529: Util.ReleaseData(baseDefn);
0530: elem = Util.DeleteListElem(elem);
0531: }
0532:
0533: throw new TclException(interp, exmsg);
0534: }
0535:
0536: /*
0537: * ------------------------------------------------------------------------
0538: * Itcl_ClassProtectionCmd -> Parse.ClassProtectionCmd.cmdProc
0539: *
0540: * Invoked by Tcl whenever the user issues a protection setting
0541: * command like "public" or "private". Creates commands and
0542: * variables, and assigns a protection level to them. Protection
0543: * levels are defined as follows:
0544: *
0545: * public => accessible from any namespace
0546: * protected => accessible from selected namespaces
0547: * private => accessible only in the namespace where it was defined
0548: *
0549: * Handles the following syntax:
0550: *
0551: * public <command> ?<arg> <arg>...?
0552: *
0553: * Will raise a TclException if anything goes wrong.
0554: * ------------------------------------------------------------------------
0555: */
0556:
0557: static class ClassProtectionCmd implements CommandWithDispose {
0558: ProtectionCmdInfo pInfo;
0559:
0560: public ClassProtectionCmd(ProtectionCmdInfo pInfo) {
0561: this .pInfo = pInfo;
0562: }
0563:
0564: public void cmdProc(Interp interp, // Current interp.
0565: TclObject[] objv) // Args passed to the command.
0566: throws TclException {
0567: int result;
0568: int oldLevel;
0569:
0570: if (objv.length < 2) {
0571: throw new TclNumArgsException(interp, 1, objv,
0572: "command ?arg arg...?");
0573: }
0574:
0575: oldLevel = Util.Protection(interp, pInfo.pLevel);
0576:
0577: try {
0578:
0579: if (objv.length == 2) {
0580: interp.eval(objv[1].toString());
0581: } else {
0582: // Eval rest of args without the first arg
0583: TclObject cmdline = Util.CreateArgs(interp, null,
0584: objv, 1);
0585: TclObject[] cmdlinev = TclList.getElements(interp,
0586: cmdline);
0587: Util.EvalArgs(interp, cmdlinev);
0588: }
0589:
0590: // Removed TCL_BREAK, TCL_CONTINUE error since eval() raises them
0591:
0592: } catch (TclException ex) {
0593: interp.addErrorInfo("\n (" + objv[0].toString()
0594: + " body line " + interp.getErrorLine() + ")");
0595: } finally {
0596: Util.Protection(interp, oldLevel);
0597: }
0598: }
0599:
0600: // This dispose does not actually do anything since
0601: // FreeParserCommandData would only deallocate memory
0602:
0603: public void disposeCmd() {
0604: Parse.FreeParserCommandData(pInfo);
0605: }
0606:
0607: } // end class ClassProtectionCmd
0608:
0609: /*
0610: * ------------------------------------------------------------------------
0611: * Itcl_ClassConstructorCmd -> Parse.ClassConstructorCmd.cmdProc
0612: *
0613: * Invoked by Tcl during the parsing of a class definition whenever
0614: * the "constructor" command is invoked to define the constructor
0615: * for an object. Handles the following syntax:
0616: *
0617: * constructor <arglist> ?<init>? <body>
0618: *
0619: * ------------------------------------------------------------------------
0620: */
0621:
0622: static class ClassConstructorCmd implements Command {
0623: public void cmdProc(Interp interp, // Current interp.
0624: TclObject[] objv) // Args passed to the command.
0625: throws TclException {
0626: ItclObjectInfo info = (ItclObjectInfo) interp
0627: .getAssocData(ItclInt.INTERP_DATA);
0628: ItclClass cdefn = (ItclClass) Util
0629: .PeekStack(info.cdefnStack);
0630:
0631: String name, arglist, body;
0632:
0633: if (objv.length < 3 || objv.length > 4) {
0634: throw new TclNumArgsException(interp, 1, objv,
0635: "args ?init? body");
0636: }
0637:
0638: name = objv[0].toString();
0639: if (cdefn.functions.get(name) != null) {
0640: throw new TclException(interp, "\"" + name
0641: + "\" already defined in class \""
0642: + cdefn.fullname + "\"");
0643: }
0644:
0645: // If there is an object initialization statement, pick this
0646: // out and take the last argument as the constructor body.
0647:
0648: arglist = objv[1].toString();
0649: if (objv.length == 3) {
0650: body = objv[2].toString();
0651: } else {
0652: cdefn.initCode = objv[2];
0653: cdefn.initCode.preserve();
0654: body = objv[3].toString();
0655: }
0656:
0657: Methods.CreateMethod(interp, cdefn, name, arglist, body);
0658: }
0659: } // end class ClassConstructorCmd
0660:
0661: /*
0662: * ------------------------------------------------------------------------
0663: * Itcl_ClassDestructorCmd -> Parse.ClassDestructorCmd.cmdProc
0664: *
0665: * Invoked by Tcl during the parsing of a class definition whenever
0666: * the "destructor" command is invoked to define the destructor
0667: * for an object. Handles the following syntax:
0668: *
0669: * destructor <body>
0670: *
0671: * ------------------------------------------------------------------------
0672: */
0673:
0674: static class ClassDestructorCmd implements Command {
0675: public void cmdProc(Interp interp, // Current interp.
0676: TclObject[] objv) // Args passed to the command.
0677: throws TclException {
0678: ItclObjectInfo info = (ItclObjectInfo) interp
0679: .getAssocData(ItclInt.INTERP_DATA);
0680: ItclClass cdefn = (ItclClass) Util
0681: .PeekStack(info.cdefnStack);
0682:
0683: String name, body;
0684:
0685: if (objv.length != 2) {
0686: throw new TclNumArgsException(interp, 1, objv, "body");
0687: }
0688:
0689: name = objv[0].toString();
0690: body = objv[1].toString();
0691:
0692: if (cdefn.functions.get(name) != null) {
0693: throw new TclException(interp, "\"" + name
0694: + "\" already defined in class \""
0695: + cdefn.fullname + "\"");
0696: }
0697:
0698: Methods.CreateMethod(interp, cdefn, name, null, body);
0699: }
0700: } // end class ClassDestructorCmd
0701:
0702: /*
0703: * ------------------------------------------------------------------------
0704: * Itcl_ClassMethodCmd -> Parse.ClassMethodCmd.cmdProc
0705: *
0706: * Invoked by Tcl during the parsing of a class definition whenever
0707: * the "method" command is invoked to define an object method.
0708: * Handles the following syntax:
0709: *
0710: * method <name> ?<arglist>? ?<body>?
0711: *
0712: * ------------------------------------------------------------------------
0713: */
0714:
0715: static class ClassMethodCmd implements Command {
0716: public void cmdProc(Interp interp, // Current interp.
0717: TclObject[] objv) // Args passed to the command.
0718: throws TclException {
0719: ItclObjectInfo info = (ItclObjectInfo) interp
0720: .getAssocData(ItclInt.INTERP_DATA);
0721: ItclClass cdefn = (ItclClass) Util
0722: .PeekStack(info.cdefnStack);
0723:
0724: String name, arglist, body;
0725:
0726: if (objv.length < 2 || objv.length > 4) {
0727: throw new TclNumArgsException(interp, 1, objv,
0728: "name ?args? ?body?");
0729: }
0730:
0731: name = objv[1].toString();
0732:
0733: arglist = null;
0734: body = null;
0735: if (objv.length >= 3) {
0736: arglist = objv[2].toString();
0737: }
0738: if (objv.length == 4) {
0739: body = objv[3].toString();
0740: }
0741:
0742: Methods.CreateMethod(interp, cdefn, name, arglist, body);
0743: }
0744: } // end class ClassMethodCmd
0745:
0746: /*
0747: * ------------------------------------------------------------------------
0748: * Itcl_ClassProcCmd -> Parse.ClassProcCmd.cmdProc
0749: *
0750: * Invoked by Tcl during the parsing of a class definition whenever
0751: * the "proc" command is invoked to define a common class proc.
0752: * A "proc" is like a "method", but only has access to "common"
0753: * class variables. Handles the following syntax:
0754: *
0755: * proc <name> ?<arglist>? ?<body>?
0756: *
0757: * ------------------------------------------------------------------------
0758: */
0759:
0760: static class ClassProcCmd implements Command {
0761: public void cmdProc(Interp interp, // Current interp.
0762: TclObject[] objv) // Args passed to the command.
0763: throws TclException {
0764: ItclObjectInfo info = (ItclObjectInfo) interp
0765: .getAssocData(ItclInt.INTERP_DATA);
0766: ItclClass cdefn = (ItclClass) Util
0767: .PeekStack(info.cdefnStack);
0768:
0769: String name, arglist, body;
0770:
0771: if (objv.length < 2 || objv.length > 4) {
0772: throw new TclNumArgsException(interp, 1, objv,
0773: "name ?args? ?body?");
0774: }
0775:
0776: name = objv[1].toString();
0777:
0778: arglist = null;
0779: body = null;
0780: if (objv.length >= 3) {
0781: arglist = objv[2].toString();
0782: }
0783: if (objv.length >= 4) {
0784: body = objv[3].toString();
0785: }
0786:
0787: Methods.CreateProc(interp, cdefn, name, arglist, body);
0788: }
0789: } // end class ClassProcCmd
0790:
0791: /*
0792: * ------------------------------------------------------------------------
0793: * Itcl_ClassVariableCmd -> Parse.ClassVariableCmd.cmdProc
0794: *
0795: * Invoked by Tcl during the parsing of a class definition whenever
0796: * the "variable" command is invoked to define an instance variable.
0797: * Handles the following syntax:
0798: *
0799: * variable <varname> ?<init>? ?<config>?
0800: *
0801: * ------------------------------------------------------------------------
0802: */
0803:
0804: static class ClassVariableCmd implements Command {
0805: public void cmdProc(Interp interp, // Current interp.
0806: TclObject[] objv) // Args passed to the command.
0807: throws TclException {
0808: ItclObjectInfo info = (ItclObjectInfo) interp
0809: .getAssocData(ItclInt.INTERP_DATA);
0810: ItclClass cdefn = (ItclClass) Util
0811: .PeekStack(info.cdefnStack);
0812:
0813: int pLevel;
0814: ItclVarDefn vdefn;
0815: String name, init, config;
0816:
0817: pLevel = Util.Protection(interp, 0);
0818:
0819: if (pLevel == Itcl.PUBLIC) {
0820: if (objv.length < 2 || objv.length > 4) {
0821: throw new TclNumArgsException(interp, 1, objv,
0822: "name ?init? ?config?");
0823: }
0824: } else if ((objv.length < 2) || (objv.length > 3)) {
0825: throw new TclNumArgsException(interp, 1, objv,
0826: "name ?init?");
0827: }
0828:
0829: // Make sure that the variable name does not contain anything
0830: // goofy like a "::" scope qualifier.
0831:
0832: name = objv[1].toString();
0833: if (name.indexOf("::") != -1) {
0834: throw new TclException(interp, "bad variable name \""
0835: + name + "\"");
0836: }
0837:
0838: init = null;
0839: config = null;
0840: if (objv.length >= 3) {
0841: init = objv[2].toString();
0842: }
0843: if (objv.length >= 4) {
0844: config = objv[3].toString();
0845: }
0846:
0847: vdefn = Class.CreateVarDefn(interp, cdefn, name, init,
0848: config);
0849: }
0850: } // end class ClassVariableCmd
0851:
0852: /*
0853: * ------------------------------------------------------------------------
0854: * Itcl_ClassCommonCmd -> Parse.ClassCommonCmd.cmdProc
0855: *
0856: * Invoked by Tcl during the parsing of a class definition whenever
0857: * the "common" command is invoked to define a variable that is
0858: * common to all objects in the class. Handles the following syntax:
0859: *
0860: * common <varname> ?<init>?
0861: *
0862: * ------------------------------------------------------------------------
0863: */
0864:
0865: static class ClassCommonCmd implements Command {
0866: public void cmdProc(Interp interp, // Current interp.
0867: TclObject[] objv) // Args passed to the command.
0868: throws TclException {
0869: ItclObjectInfo info = (ItclObjectInfo) interp
0870: .getAssocData(ItclInt.INTERP_DATA);
0871: ItclClass cdefn = (ItclClass) Util
0872: .PeekStack(info.cdefnStack);
0873:
0874: String name, init;
0875: ItclVarDefn vdefn;
0876: Namespace ns;
0877: Var var;
0878:
0879: if ((objv.length < 2) || (objv.length > 3)) {
0880: throw new TclNumArgsException(interp, 1, objv,
0881: "varname ?init?");
0882: }
0883:
0884: // Make sure that the variable name does not contain anything
0885: // goofy like a "::" scope qualifier.
0886:
0887: name = objv[1].toString();
0888: if (name.indexOf("::") != -1) {
0889: throw new TclException(interp, "bad variable name \""
0890: + name + "\"");
0891: }
0892:
0893: init = null;
0894: if (objv.length >= 3) {
0895: init = objv[2].toString();
0896: }
0897:
0898: vdefn = Class
0899: .CreateVarDefn(interp, cdefn, name, init, null);
0900: vdefn.member.flags |= ItclInt.COMMON;
0901:
0902: // Create the variable in the namespace associated with the
0903: // class. Do this the hard way, to avoid the variable resolver
0904: // procedures. These procedures won't work until we rebuild
0905: // the virtual tables below.
0906:
0907: ns = cdefn.namesp;
0908:
0909: var = Migrate.NewVar();
0910: ItclAccess.createCommonVar(var, vdefn.member.name, ns,
0911: ns.varTable);
0912:
0913: ns.varTable.put(vdefn.member.name, var);
0914:
0915: // TRICKY NOTE: Make sure to rebuild the virtual tables for this
0916: // class so that this variable is ready to access. The variable
0917: // resolver for the parser namespace needs this info to find the
0918: // variable if the developer tries to set it within the class
0919: // definition.
0920: //
0921: // If an initialization value was specified, then initialize
0922: // the variable now.
0923:
0924: Class.BuildVirtualTables(cdefn);
0925:
0926: if (init != null) {
0927: TclObject val = interp.setVar(vdefn.member.name
0928: .toString(), TclString.newInstance(init),
0929: TCL.NAMESPACE_ONLY);
0930: if (val == null) {
0931: throw new TclException(interp,
0932: "cannot initialize common variable \""
0933: + vdefn.member.name + "\"");
0934: }
0935: }
0936: }
0937: } // end class ClassCommonCmd
0938:
0939: /*
0940: * ------------------------------------------------------------------------
0941: * Itcl_ParseVarResolver -> Parse.ParseVarResolver
0942: *
0943: * Used by the "parser" namespace to resolve variable accesses to
0944: * common variables. The runtime resolver procedure is consulted
0945: * whenever a variable is accessed within the namespace. It can
0946: * deny access to certain variables, or perform special lookups itself.
0947: *
0948: * This procedure allows access only to "common" class variables that
0949: * have been declared within the class or inherited from another class.
0950: * A "set" command can be used to initialized common data members within
0951: * the body of the class definition itself:
0952: *
0953: * itcl::class Foo {
0954: * common colors
0955: * set colors(red) #ff0000
0956: * set colors(green) #00ff00
0957: * set colors(blue) #0000ff
0958: * ...
0959: * }
0960: *
0961: * itcl::class Bar {
0962: * inherit Foo
0963: * set colors(gray) #a0a0a0
0964: * set colors(white) #ffffff
0965: *
0966: * common numbers
0967: * set numbers(0) zero
0968: * set numbers(1) one
0969: * }
0970: *
0971: * ------------------------------------------------------------------------
0972: */
0973:
0974: static Var ParseVarResolver(Interp interp, // current interpreter
0975: String name, // name of the variable being accessed
0976: Namespace contextNs, // namespace context
0977: int flags) // TCL.GLOBAL_ONLY => global variable
0978: // TCL.NAMESPACE_ONLY => namespace variable
0979: throws TclException {
0980: ItclObjectInfo info = (ItclObjectInfo) interp
0981: .getAssocData(ItclInt.INTERP_DATA);
0982: ItclClass cdefn = (ItclClass) Util.PeekStack(info.cdefnStack);
0983:
0984: ItclVarLookup vlookup;
0985:
0986: // See if the requested variable is a recognized "common" member.
0987: // If it is, make sure that access is allowed.
0988:
0989: vlookup = (ItclVarLookup) cdefn.resolveVars.get(name);
0990:
0991: if (vlookup != null) {
0992: if ((vlookup.vdefn.member.flags & ItclInt.COMMON) != 0) {
0993: if (!vlookup.accessible) {
0994: throw new TclException(
0995: interp,
0996: "can't access \""
0997: + name
0998: + "\": "
0999: + Util
1000: .ProtectionStr(vlookup.vdefn.member.protection)
1001: + " variable");
1002: }
1003: return vlookup.common;
1004: }
1005: }
1006:
1007: // If the variable is not recognized, return null and
1008: // let lookup continue via the normal name resolution rules.
1009: // This is important for variables like "errorInfo"
1010: // that might get set while the parser namespace is active.
1011:
1012: return null;
1013: }
1014:
1015: static class ParseVarResolverImpl implements Resolver {
1016: public WrappedCommand resolveCmd(Interp interp, // The current interpreter.
1017: String name, // Command name to resolve.
1018: Namespace context, // The namespace to look in.
1019: int flags) // 0 or TCL.LEAVE_ERR_MSG.
1020: throws TclException // Tcl exceptions are thrown for Tcl errors.
1021: {
1022: return null; // Do not resolve anything
1023: }
1024:
1025: public Var resolveVar(Interp interp, // The current interpreter.
1026: String name, // Variable name to resolve.
1027: Namespace context, // The namespace to look in.
1028: int flags) // 0 or TCL.LEAVE_ERR_MSG.
1029: throws TclException // Tcl exceptions are thrown for Tcl errors.
1030: {
1031: return Parse.ParseVarResolver(interp, name, context, flags);
1032: }
1033: }
1034:
1035: /*
1036: * ------------------------------------------------------------------------
1037: * ItclFreeParserCommandData -> Parse.FreeParserCommandData
1038: *
1039: * This callback will free() up memory dynamically allocated
1040: * and passed as the ClientData argument to Tcl_CreateObjCommand.
1041: * This callback is required because one can not simply pass
1042: * a pointer to the free() or ckfree() to Tcl_CreateObjCommand.
1043: * ------------------------------------------------------------------------
1044: */
1045:
1046: static void FreeParserCommandData(Object cdata) // client data to be destroyed
1047: {
1048: //ckfree(cdata);
1049: }
1050:
1051: } // end class Parse
|