开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
otcl.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：65k
源码类别：

通讯编程

开发平台：

Visual C++

otcl.c：源码内容
  1. /* -*- Mode: c++ -*-
  2.  *
  3.  *  $Id: otcl.c,v 1.23 2005/09/07 04:44:18 tom_henderson Exp $
  4.  *  
  5.  *  Copyright 1993 Massachusetts Institute of Technology
  6.  * 
  7.  *  Permission to use, copy, modify, distribute, and sell this software and its
  8.  *  documentation for any purpose is hereby granted without fee, provided that
  9.  *  the above copyright notice appear in all copies and that both that
  10.  *  copyright notice and this permission notice appear in supporting
  11.  *  documentation, and that the name of M.I.T. not be used in advertising or
  12.  *  publicity pertaining to distribution of the software without specific,
  13.  *  written prior permission.  M.I.T. makes no representations about the
  14.  *  suitability of this software for any purpose.  It is provided "as is"
  15.  *  without express or implied warranty.
  16.  * 
  17.  */
  19. #include <stdlib.h>
  20. #include <string.h>
  21. #include <tclInt.h>
  22. #include <otcl.h> 
  25. /*
  26.  * compatibility definitions to bridge 7.x -> 7.5
  27.  */
  29. #if TCL_MAJOR_VERSION < 7
  30.   #error Tcl distribution is TOO OLD
  31. #elif TCL_MAJOR_VERSION == 7 && TCL_MINOR_VERSION <= 3
  32.   typedef char* Tcl_Command;
  33.   static char* Tcl_GetCommandName(Tcl_Interp* in, Tcl_Command id) {
  34.     return id;
  35.   }
  37.   static int Tcl_UpVar(Tcl_Interp* in, char* lvl, char* l, char* g, int flg){
  38.     char* args[4];
  39.     args[0] = "uplevel"; args[1] = "1";
  40.     args[2]=l; args[3]=g;
  41.     return Tcl_UpvarCmd(0, in, 4, args);
  42.   }
  44.   #define Tcl_CreateCommand(A,B,C,D,E)     
  45.     strcpy((char*)ckalloc(strlen(B)+1), B);
  46.     Tcl_CreateCommand(A,B,C,D,E)
  47. #endif
  49. #if TCL_MAJOR_VERSION <= 7
  50. #define TclIsVarUndefined(varPtr) 
  51.     ((varPtr)->flags == VAR_UNDEFINED)
  52. #endif
  54. #if TCL_MAJOR_VERSION < 8
  55. #define ObjVarTablePtr(OBJ) (&(OBJ)->variables.varTable)
  56. #define compat_Tcl_AddObjErrorInfo(a,b,c) Tcl_AddErrorInfo(a,b)
  57. #else
  58. #define ObjVarTablePtr(OBJ) ((OBJ)->variables.varTablePtr)
  59. #define compat_Tcl_AddObjErrorInfo(a,b,c) Tcl_AddObjErrorInfo(a,b,c)
  60. #endif
  64. /*
  65.  * object and class internals
  66.  */
  69. typedef struct OTclObject {
  70.   Tcl_Command id;
  71.   Tcl_Interp* teardown;
  72.   struct OTclClass* cl;
  73.   struct OTclClass* type;
  74.   Tcl_HashTable* procs;
  75.   CallFrame variables;
  76. } OTclObject;
  79. typedef struct OTclClass {
  80.   struct OTclObject object;
  81.   struct OTclClasses* super;
  82.   struct OTclClasses* sub;
  83.   int color;
  84.   struct OTclClasses* order;
  85.   struct OTclClass* parent;
  86.   Tcl_HashTable instprocs;
  87.   Tcl_HashTable instances;
  88.   Tcl_HashTable* objectdata;
  89. } OTclClass;
  92. typedef struct OTclClasses {
  93.   struct OTclClass* cl;
  94.   struct OTclClasses* next;
  95. } OTclClasses;
  98. /*
  99.  * definitions of the main otcl objects
  100.  */
  101. static Tcl_HashTable* theObjects = 0;
  102. static Tcl_HashTable* theClasses = 0;
  103. static Tcl_CmdProc* ProcInterpId = 0;
  105. /*
  106.  * error return functions
  107.  */
  110. static int
  111. OTclErrMsg(Tcl_Interp *in, char* msg, Tcl_FreeProc* type) {
  112.   Tcl_SetResult(in, msg, type);
  113.   return TCL_ERROR;
  114. }
  116. static int
  117. OTclErrArgCnt(Tcl_Interp *in, CONST84 char *cmdname, char *arglist) {
  118.   Tcl_ResetResult(in);
  119.   Tcl_AppendResult(in, "wrong # args: should be {", cmdname, 0);
  120.   if (arglist != 0) Tcl_AppendResult(in, " ", arglist, 0);
  121.   Tcl_AppendResult(in, "}", 0);
  122.   return TCL_ERROR;
  123. }
  126. static int
  127. OTclErrBadVal(Tcl_Interp *in, char *expected, CONST84 char *value) {
  128.   Tcl_ResetResult(in);
  129.   Tcl_AppendResult(in, "expected ", expected, " but got", 0);
  130.   Tcl_AppendElement(in, value);
  131.   return TCL_ERROR;
  132. }
  135. static int
  136. OTclErrType(Tcl_Interp *in, CONST84 char* nm, char* wt) {
  137.   Tcl_ResetResult(in);
  138.   Tcl_AppendResult(in,"type check failed: ",nm," is not of type ",wt,0);
  139.   return TCL_ERROR;
  140. }
  143. /*
  144.  * precedence ordering functions
  145.  */
  148. enum colors { WHITE, GRAY, BLACK };
  150. static int
  151. TopoSort(OTclClass* cl, OTclClass* base, OTclClasses* (*next)(OTclClass*)) {
  152.   OTclClasses* sl = (*next)(cl);
  153.   OTclClasses* pl;
  155.   /*
  156.    * careful to reset the color of unreported classes to
  157.    * white in case we unwind with error, and on final exit
  158.    * reset color of reported classes to white
  159.    */
  161.   cl->color = GRAY;
  162.   for (; sl != 0; sl = sl->next) {
  163.     OTclClass* sc = sl->cl;
  164.     if (sc->color==GRAY) { cl->color = WHITE; return 0; }
  165.     if (sc->color==WHITE && !TopoSort(sc, base, next)) {
  166.       cl->color=WHITE;
  167.       if (cl == base) {
  168. OTclClasses* pc = cl->order;
  169. while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; }
  170.       }
  171.       return 0;
  172.     }
  173.   }
  174.   cl->color = BLACK;
  175.   pl = (OTclClasses*)ckalloc(sizeof(OTclClasses));
  176.   pl->cl = cl;
  177.   pl->next = base->order;
  178.   base->order = pl;
  179.   if (cl == base) {
  180.     OTclClasses* pc = cl->order;
  181.     while (pc != 0) { pc->cl->color = WHITE; pc = pc->next; }
  182.   }
  183.   return 1;
  184. }
  187. static void
  188. RC(OTclClasses* sl) {
  189.   while (sl != 0) {
  190.     OTclClasses* n = sl->next;
  191.     ckfree((char*)sl); sl = n;
  192.   }
  193. } 
  196. static OTclClasses* Super(OTclClass* cl) { return cl->super; }
  198. static OTclClasses*
  199. ComputePrecedence(OTclClass* cl) {
  200.   if (!cl->order) {
  201.     int ok = TopoSort(cl, cl, Super);
  202.     if (!ok) { RC(cl->order); cl->order = 0; }
  203.   }
  204.   return cl->order;
  205. }
  208. static OTclClasses* Sub(OTclClass* cl) { return cl->sub; }
  210. static OTclClasses*
  211. ComputeDependents(OTclClass* cl) {
  212.   if (!cl->order) {
  213.     int ok = TopoSort(cl, cl, Sub);
  214.     if (!ok) { RC(cl->order); cl->order = 0; }
  215.   }
  216.   return cl->order;
  217. }
  220. static void
  221. FlushPrecedences(OTclClass* cl) {
  222.   OTclClasses* pc;
  223.   RC(cl->order); cl->order = 0;
  224.   pc = ComputeDependents(cl);
  226.   /*
  227.    * ordering doesn't matter here - we're just using toposort
  228.    * to find all lower classes so we can flush their caches
  229.    */
  231.   if (pc) pc = pc->next;
  232.   while (pc != 0) {
  233.     RC(pc->cl->order); pc->cl->order = 0;
  234.     pc = pc->next;
  235.   }  
  236.   RC(cl->order); cl->order = 0;
  237. }
  240. static void
  241. AddInstance(OTclObject* obj, OTclClass* cl) {
  242.   obj->cl = cl;
  243.   if (cl != 0) {
  244.     int nw;
  245.     (void) Tcl_CreateHashEntry(&cl->instances, (char*)obj, &nw);
  246.   }
  247. }
  250. static int
  251. RemoveInstance(OTclObject* obj, OTclClass* cl) {
  252.   if (cl != 0) {
  253.     Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&cl->instances, (char*)obj);
  254.     if (hPtr) { Tcl_DeleteHashEntry(hPtr); return 1; }
  255.   }
  256.   return 0;
  257. }
  260. /*
  261.  * superclass/subclass list maintenance
  262.  */
  265. static void
  266. AS(OTclClass* cl, OTclClass* s, OTclClasses** sl) {
  267.   OTclClasses* l = *sl;
  268.   while (l &&  l->cl != s) l = l->next;
  269.   if (!l) {
  270.     OTclClasses* sc = (OTclClasses*)ckalloc(sizeof(OTclClasses));
  271.     sc->cl = s; sc->next = *sl; *sl = sc;
  272.   }
  273. }
  275. static void
  276. AddSuper(OTclClass* cl, OTclClass* super) {
  277.   if (cl && super) {
  278.     
  279.     /*
  280.      * keep corresponding sub in step with super
  281.      */ 
  283.     AS(cl, super, &cl->super);
  284.     AS(super, cl, &super->sub);
  285.   }
  286. }
  289. static int
  290. RS(OTclClass* cl, OTclClass* s, OTclClasses** sl) {
  291.   OTclClasses* l = *sl;
  292.   if (!l) return 0;
  293.   if (l->cl == s) {
  294.     *sl = l->next;
  295.     ckfree((char*)l);
  296.     return 1;
  297.   }
  298.   while (l->next && l->next->cl != s) l = l->next;
  299.   if (l->next) {
  300.     OTclClasses* n = l->next->next;
  301.     ckfree((char*)(l->next));
  302.     l->next = n;
  303.     return 1;
  304.   }
  305.   return 0;
  306. }
  309. static int
  310. RemoveSuper(OTclClass* cl, OTclClass* super) {
  312.   /*
  313.    * keep corresponding sub in step with super
  314.    */ 
  316.   int sp = RS(cl, super, &cl->super);
  317.   int sb = RS(super, cl, &super->sub);
  318.   return (sp && sb);
  319. }
  322. /*
  323.  * internal type checking
  324.  */
  327. static OTclClass*
  328. InObject(Tcl_Interp* in) {
  329.   Tcl_HashEntry* hp = Tcl_FindHashEntry(theObjects, (char*)in);
  330.   if (hp != 0) return (OTclClass*)Tcl_GetHashValue(hp);
  331.   return 0;
  332. }
  335. static OTclClass*
  336. InClass(Tcl_Interp* in) {
  337.   Tcl_HashEntry* hp = Tcl_FindHashEntry(theClasses, (char*)in);
  338.   if (hp != 0) return (OTclClass*)Tcl_GetHashValue(hp);
  339.   return 0;
  340. }
  343. static int
  344. IsType(OTclObject* obj, OTclClass* type) {
  345.   OTclClass* t = obj ? obj->type : 0;
  346.   while (t && t!=type) t = t->parent;
  347.   return (t != 0);
  348. }
  351. /*
  352.  * methods lookup and dispatch
  353.  */
  356. static int
  357. LookupMethod(Tcl_HashTable* methods, CONST84 char* nm, Tcl_CmdProc** pr,
  358.      ClientData* cd, Tcl_CmdDeleteProc** dp) 
  359. {
  360.   Tcl_HashEntry *hPtr = Tcl_FindHashEntry(methods, nm);
  361.   if (hPtr != 0) {
  362.     Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
  363.     if (pr != 0) *pr = co->proc;
  364.     if (cd != 0) *cd = co->clientData;
  365.     if (dp != 0) *dp = co->deleteProc;
  366.     return 1;
  367.   }
  368.   return 0;
  369. }
  372. static OTclClass*
  373. SearchCMethod(OTclClasses* pl, CONST84 char* nm, Tcl_CmdProc** pr,
  374.       ClientData* cd, Tcl_CmdDeleteProc** dp)
  375. { 
  376.   while (pl != 0) {
  377.     Tcl_HashTable* cm = &pl->cl->instprocs;
  378.     if (LookupMethod(cm, nm, pr, cd, 0) != 0) break;
  379.     pl = pl->next;
  380.   }
  381.   return pl ? pl->cl : 0;
  382. }
  385. #define OTCLSMALLARGS 8
  387. static int 
  388. OTclDispatch(ClientData cd, Tcl_Interp* in, int argc, CONST84 char* argv[]) {
  389.   OTclObject* self = (OTclObject*)cd;
  390.   Tcl_CmdProc* proc = 0;
  391.   ClientData cp = 0;
  392.   OTclClass* cl = 0;
  394.   if (argc < 2) return OTclErrArgCnt(in, argv[0], "message ?args...?");
  396.   /*
  397.    * try for local methods first, then up the class heirarchy
  398.    */ 
  400.   if (!self->procs || !LookupMethod(self->procs, argv[1], &proc, &cp, 0))
  401.     cl = SearchCMethod(ComputePrecedence(self->cl),argv[1],&proc,&cp,0);
  403.   if (proc) {
  404.     CONST84 char* sargs[OTCLSMALLARGS];
  405.     CONST84 char** args = sargs;
  406.     int result;
  407.     int i;
  408.     
  409.     /*
  410.      * permute args to be:  self self class method <rest>
  411.      * and, if method has no clientdata, pass an object pointer.
  412.      */ 
  414.     cp = (cp != 0) ? cp : cd;
  415.     if (argc+2 > OTCLSMALLARGS)
  416.       args = (CONST84 char**)ckalloc((argc+2)*sizeof(char*));
  417.     args[0] = argv[0]; 
  418.     args[1] = argv[0];
  419.     args[2] = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : "";
  420.     for (i = 1; i < argc; i++) args[i+2] = argv[i];
  422.     /*
  423.     printf("%d ", argc);
  424.     for (i = 0; i < argc; i++)
  425.       printf("%s ", argv[i]);
  426.     printf("n");
  427.     */
  428.     /*
  429.     for (i = 0; i < argc + 2; i++)
  430.       printf("%s ", args[i]);
  431.     printf("n");
  432.     */
  434.     result = (*proc)(cp, in, argc+2, (const char **) args);
  435.     /* this adds to the stack trace */
  436.     if (result == TCL_ERROR) {
  437.     char msg[150];
  438.     /* old_args2 is because args[2] was getting
  439.      * clobbered sometimes => seg fault.
  440.      * ---johnh
  441.      */
  442.     CONST84 char *old_args2 = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : argv[0];
  443.     sprintf(msg, "n    (%.40s %.40s line %d)",
  444.     old_args2, argv[1], in->errorLine);
  445.     compat_Tcl_AddObjErrorInfo(in, msg, -1);
  446.     }
  447.     if (argc+2 > OTCLSMALLARGS) { ckfree((char*)args); args = 0; }
  448.     return result;
  449.   }
  451.   /*
  452.    * back off and try unknown
  453.    */
  455.   if (!self->procs || !LookupMethod(self->procs, "unknown", &proc, &cp, 0))
  456.     cl = SearchCMethod(ComputePrecedence(self->cl),"unknown",&proc,&cp,0);
  457.   
  458.   if (proc) {
  459.     CONST84 char* sargs[OTCLSMALLARGS];
  460.     CONST84 char** args = sargs;
  461.     int result;
  462.     int i;
  463.     
  464.     /*
  465.      * permute args to be:  self self class method <rest>
  466.      * and, if method has no clientdata, pass an object pointer.
  467.      */ 
  469.     cp = (cp != 0) ? cp : cd;
  470.     if (argc+3 > OTCLSMALLARGS)
  471.       args = (CONST84 char**)ckalloc((argc+3)*sizeof(char*));
  472.     args[0] = argv[0]; 
  473.     args[1] = argv[0];
  474.     args[2] = cl ? (char *) Tcl_GetCommandName(in, cl->object.id) : "";
  475.     args[3] = "unknown";
  476.     for (i = 1; i < argc; i++) args[i+3] = argv[i];
  477.     result = (*proc)(cp, in, argc+3, (const char **) args);
  478.     if (result == TCL_ERROR) {
  479.     char msg[100];
  480.     sprintf(msg, "n    (%.30s unknown line %d)",
  481.     cl ? args[2] : argv[0], in->errorLine);
  482.     compat_Tcl_AddObjErrorInfo(in, msg, -1);
  483.     }
  484.     if (argc+3 > OTCLSMALLARGS) { ckfree((char*)args); args = 0; }
  485.     return result;
  486.   }  
  488.   /*
  489.    * and if that fails too, error out
  490.    */
  492.   Tcl_ResetResult(in);
  493.   Tcl_AppendResult(in, argv[0], ": unable to dispatch method ", argv[1], 0);
  494.   return TCL_ERROR;
  495. }
  498. /*
  499.  * autoloading
  500.  */
  503. static void
  504. AutoLoaderDP(ClientData cd) {
  505.   ckfree((char*)cd);
  506. }
  508. static int
  509. AutoLoader(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  511.   /*
  512.    * cd is a script to evaluate; object context reconstructed from argv
  513.    */
  515.   OTclObject* obj = OTclGetObject(in, argv[1]);
  516.   OTclClass* cl = argv[2][0] ? OTclGetClass(in, argv[2]) : 0;
  517.   CONST84 char* clname = cl ? argv[2] : "{}"; 
  518.   Tcl_CmdProc* proc = 0;
  519.   ClientData cp = 0;
  521.   if (Tcl_Eval(in, (char*)cd) != TCL_OK) {
  522.     Tcl_AppendResult(in, " during autoloading (object=", argv[1],
  523.      ", class=", clname, ", proc=", argv[3],")", 0);
  524.     return TCL_ERROR;
  525.   }
  527.   /*
  528.    * the above eval should have displaced this procedure from the object,
  529.    * so check by looking at our old spot in the table, and if successful
  530.    * continue dispatch with the right clientdata.
  531.    */ 
  533.   if (cl)
  534.     (void) LookupMethod(&cl->instprocs, argv[3], &proc, &cp, 0);
  535.   else if (obj->procs)
  536.     (void) LookupMethod(obj->procs, argv[3], &proc, &cp, 0);
  538.   if (proc && proc != (Tcl_CmdProc *) AutoLoader) {
  539.     ClientData cdata = (cp != 0) ? cp : (ClientData)obj;
  540.     return (*proc)(cdata, in, argc, (const char **) argv);
  541.   }
  542.   
  543.   Tcl_ResetResult(in);
  544.   Tcl_AppendResult(in, "no new proc during autoloading (object=", argv[1],
  545.    ", class=", clname, ", proc=", argv[3],")", 0);
  546.   return TCL_ERROR;
  547. }
  550. int
  551. MakeAuto(Tcl_CmdInfo* proc, CONST84 char* loader) {
  552.   proc->proc = (Tcl_CmdProc *) AutoLoader;
  553.   proc->deleteProc = AutoLoaderDP;
  554.   proc->clientData = (ClientData)strcpy(ckalloc(strlen(loader)+1), loader);
  555.   return (proc->clientData != 0);
  556. }
  559. /*
  560.  * creating, installing, listing and removing procs
  561.  */
  564. static void
  565. AddMethod(Tcl_HashTable* methods, CONST84 char* nm, Tcl_CmdProc* pr,
  566.   ClientData cd, Tcl_CmdDeleteProc* dp, ClientData dd)
  567. { 
  568.   int nw = 0;
  569.   Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(methods, nm, &nw);
  570.   Tcl_CmdInfo* co = (Tcl_CmdInfo*)ckalloc(sizeof(Tcl_CmdInfo));
  571.   co->proc = pr;
  572.   co->clientData = cd;
  573.   co->deleteProc = dp;
  574.   co->deleteData = dd;
  575.   Tcl_SetHashValue(hPtr, (ClientData)co);
  576. }
  579. static int
  580. RemoveMethod(Tcl_HashTable* methods, CONST84 char* nm, ClientData cd) { 
  581.   Tcl_HashEntry *hPtr = Tcl_FindHashEntry(methods, nm);
  582.   if (hPtr != 0) {
  583.     Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
  584.     if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
  585.     ckfree((char*)co);
  586.     Tcl_DeleteHashEntry(hPtr);
  587.     return 1;
  588.   }
  589.   return 0;
  590. }
  592. #if TCL_MAJOR_VERSION >= 8
  593. typedef struct {
  594. Tcl_Interp* interp;
  595. int procUid;
  596. } OTclDeleteProcData;
  599. static int s_ProcUid=0; 
  600. static const char s_otclProcPrefix[] = "::otcl::p";
  601. static char s_otclProcName[sizeof(s_otclProcPrefix) + 8];
  603. const char* GetProcName(int index)
  604. {
  605. sprintf(s_otclProcName, "%s%d", s_otclProcPrefix, index);
  606. return s_otclProcName;
  607. }
  609. static void
  610. OTclDeleteProc(ClientData cd)
  611. {
  612.   OTclDeleteProcData* pdpd = (OTclDeleteProcData*)cd;
  613.   /* cleanup, ignore any errors */
  614.   Tcl_Command cmd;
  615.   cmd = Tcl_FindCommand(pdpd->interp, (char*)GetProcName(pdpd->procUid),
  616. (Tcl_Namespace*)NULL, 0);
  617.   if (cmd) 
  618.   Tcl_DeleteCommandFromToken(pdpd->interp, cmd);
  619.   ckfree((char*)pdpd);
  620. }
  621. #endif  
  624. int
  625. MakeProc(Tcl_CmdInfo* proc, Tcl_Interp* in, int argc, CONST84 char* argv[]) {    
  626.   CONST84 char* name = argv[1];
  627.   CONST84 char* oargs = argv[2];
  628.   CONST84 char* nargs = (CONST84 char*)ckalloc(strlen("self class proc ")+strlen(argv[2])+1);
  629.   int ok = 0;
  630.   CONST84 char* id;
  632. #if TCL_MAJOR_VERSION >= 8
  633.   Tcl_Obj **objv;
  634.   int i;
  635.   id= (char*)GetProcName(++s_ProcUid);
  636. #else
  637.   id= "__OTclProc__";
  638. #endif
  640.   /*
  641.    * add the standard method args automatically
  642.    */
  644.   argv[1] = id;
  645.   (void)strcpy((char *)nargs, "self class proc ");
  646.   if (argv[2][0] != 0) (void) strcat((char *)nargs, argv[2]);
  647.   argv[2] = nargs;
  649. #if TCL_MAJOR_VERSION >= 8
  650.   objv = (Tcl_Obj **)ckalloc(argc * sizeof(Tcl_Obj *));
  651.   for (i = 0; i < argc; i++) {
  652.     objv[i] = Tcl_NewStringObj(argv[i], -1); /* let strlen() decide length */
  653.     Tcl_IncrRefCount(objv[i]);
  654.   }
  656.   /*
  657.    * use standard Tcl_ProcCmd to digest, and fish result out of interp
  658.    */
  659.   if (Tcl_ProcObjCmd(0, in, argc, objv) == TCL_OK) {
  660.     if (Tcl_GetCommandInfo(in, id, proc) && proc->proc == ProcInterpId) {
  661.       OTclDeleteProcData* pData =
  662.         (OTclDeleteProcData*)(ckalloc(sizeof(OTclDeleteProcData)));
  664.       pData->procUid = s_ProcUid;
  665.       pData->interp = in;
  667.       /* set the delete procedure to be OTclDeleteProc, which will
  668.        * remove the procedure, the deleteProc will be called in, for example,
  669.        * RemoveMethod, note that we are changing a copy of proc, the original
  670.        * proc structure still has the right deleteProc */
  671.       proc->deleteProc = OTclDeleteProc;
  672.       proc->deleteData = (ClientData)pData;
  673.       ok = 1;
  674.     }
  675.   }
  677.   for (i = 0; i < argc; i++)
  678.     Tcl_DecrRefCount(objv[i]);
  679.   ckfree((char *)objv);
  680.   
  681. #else /* TCL_MAJOR_VERSION < 8 */
  682.   
  683.   if (Tcl_ProcCmd(0, in, argc, argv) == TCL_OK) {
  684.     if (Tcl_GetCommandInfo(in, id, proc) && proc->proc == ProcInterpId) {
  685.       Tcl_CmdDeleteProc* dp = proc->deleteProc;
  686.       proc->deleteProc = 0;
  687.       if (Tcl_SetCommandInfo(in, id, proc))
  688.        (void)Tcl_DeleteCommand(in, id);
  689.       proc->deleteProc = dp;
  690.       ok = 1;
  691.     }
  692.   }
  694. #endif /* TCL_MAJOR_VERSION < 8 */
  696.   ckfree((char*)nargs);
  697.   argv[1] = name;
  698.   argv[2] = oargs;
  699.   
  700.   return ok;
  701. }
  703. static void
  704. ListKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern) {
  705.   Tcl_HashSearch hSrch;
  706.   Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
  707.   Tcl_ResetResult(in);
  708.   for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
  709.     char* key = Tcl_GetHashKey(table, hPtr);
  710.     if (!pattern || Tcl_StringMatch(key, pattern))
  711.       Tcl_AppendElement(in, key);
  712.   }
  713. }
  716. static void
  717. ListInstanceKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern) {
  718.   Tcl_HashSearch hSrch;
  719.   Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
  720.   Tcl_ResetResult(in);
  721.   for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
  722.     OTclObject* obj = (OTclObject*)Tcl_GetHashKey(table, hPtr);
  723.     CONST84 char* name = (char *) Tcl_GetCommandName(in, obj->id);
  724.     if (!pattern || Tcl_StringMatch(name, pattern))
  725.       Tcl_AppendElement(in, name);
  726.   }
  727. }
  730. static void
  731. ListProcKeys(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* pattern) {
  732.   Tcl_HashSearch hSrch;
  733.   Tcl_HashEntry* hPtr = table ? Tcl_FirstHashEntry(table, &hSrch) : 0;
  734.   Tcl_ResetResult(in);
  735.   for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
  736.     CONST84 char* key = Tcl_GetHashKey(table, hPtr);
  737.     Tcl_CmdProc* proc = ((Tcl_CmdInfo*)Tcl_GetHashValue(hPtr))->proc;
  738.     if (pattern && !Tcl_StringMatch(key, pattern)) continue;
  739.     
  740.     /*
  741.      * also counts anything to be autoloaded as a proc
  742.      */
  744.     if (proc!=(Tcl_CmdProc *) AutoLoader && proc!=ProcInterpId) continue; 
  745.     Tcl_AppendElement(in, key);
  746.   }
  747. }
  750. static Proc*
  751. FindProc(Tcl_HashTable* table, CONST84 char* name) {
  752.   Tcl_HashEntry* hPtr = table ? Tcl_FindHashEntry(table, name) : 0;
  753.   if (hPtr) {
  754.     Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
  755.     if (co->proc == ProcInterpId)
  756.       return (Proc*)co->clientData;
  757.   }
  758.   return 0;
  759. }
  760.  
  762. static int
  763. ListProcArgs(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* name) {
  764.   Proc* proc = FindProc(table, name);
  765.   if (proc) {
  766. #if TCL_MAJOR_VERSION == 7
  767.     Arg* args = proc->argPtr;
  768. #else
  769.     CompiledLocal* args = proc->firstLocalPtr;
  770. #endif
  771.     int i = 0;
  773.     /*
  774.      * skip over hidden self, class, proc args 
  775.      */
  777.     for (; args!=0 && i<3; args = args->nextPtr, i++) ;
  778.     Tcl_ResetResult(in);
  779.     while (args != 0) {
  780. #if TCL_MAJOR_VERSION >= 8
  781. /*#if TCL_RELEASE_SERIAL >= 3*/
  782. #if ((TCL_MINOR_VERSION == 0) && (TCL_RELEASE_SERIAL >= 3)) || (TCL_MINOR_VERSION > 0)
  783.     if (TclIsVarArgument(args))
  784. #else
  785.     if (args->isArg)
  786. #endif
  787. #endif
  788.     Tcl_AppendElement(in, args->name);
  789.     args = args->nextPtr;
  790.     }
  791.     return TCL_OK;
  792.   }
  793.   return OTclErrBadVal(in, "a tcl method name", name);
  794. }
  797. static int
  798. ListProcDefault(Tcl_Interp* in, Tcl_HashTable* table,
  799. CONST84 char* name, CONST84 char* arg, CONST84 char* var)
  800. {
  802.   /*
  803.    * code snarfed from tcl info default
  804.    */
  806.   Proc* proc = FindProc(table, name);
  807.   if (proc) {
  808. #if TCL_MAJOR_VERSION < 8
  809.     Arg *ap;
  810.     for (ap = proc->argPtr; ap != 0; ap = ap->nextPtr) {
  811.       if (strcmp(arg, ap->name) != 0) continue;
  812.       if (ap->defValue != 0) {
  813. if (Tcl_SetVar(in, var, ap->defValue, 0) == 0) {
  814. #else 
  815.     CompiledLocal *ap;
  816.     for (ap = proc->firstLocalPtr; ap != 0; ap = ap->nextPtr) {
  817.       if (strcmp(arg, ap->name) != 0) continue;
  818.       if (ap->defValuePtr != 0) {
  819. if (Tcl_SetVar(in, 
  820.        var, 
  821. #if TCL_MINOR_VERSION == 0
  822.        TclGetStringFromObj(ap->defValuePtr, 
  823.    (int *) NULL),
  824. #else
  825.        TclGetString(ap->defValuePtr),
  826. #endif
  827.        0) == NULL) {
  828. #endif
  829.   Tcl_ResetResult(in);
  830.   Tcl_AppendResult(in, "couldn't store default value in variable "",
  831.    var, """, (char *) 0);
  832.   return TCL_ERROR;
  833. }
  834. Tcl_SetResult(in, "1", TCL_STATIC);
  835.       } else {
  836. if (Tcl_SetVar(in, var, "", 0) == 0) {
  837.   Tcl_AppendResult(in, "couldn't store default value in variable "",
  838.    var, """, (char *) 0);
  839.   return TCL_ERROR;
  840. }
  841. Tcl_SetResult(in, "0", TCL_STATIC);
  842.       }
  843.       return TCL_OK;
  844.     }
  845.     Tcl_ResetResult(in);
  846.     Tcl_AppendResult(in, "procedure "", name,
  847.      "" doesn't have an argument "", arg, """, (char *) 0);
  848.     return TCL_ERROR;
  849.   }
  850.   return OTclErrBadVal(in, "a tcl method name", name);
  851. }
  854. static int
  855. ListProcBody(Tcl_Interp* in, Tcl_HashTable* table, CONST84 char* name) {
  856.   Proc* proc = FindProc(table, name);
  857.   if (proc) {
  858.     Tcl_ResetResult(in);
  859. #if TCL_MAJOR_VERSION< 8
  860.     Tcl_AppendResult(in, proc->command, 0);
  861. #else 
  862.     Tcl_AppendResult(in, 
  863. #if TCL_MINOR_VERSION == 0
  864.      TclGetStringFromObj(proc->bodyPtr, (int *)NULL),
  865. #else
  866.      TclGetString(proc->bodyPtr),
  867. #endif
  868.      0);
  869. #endif
  870.     return TCL_OK;
  871.   }
  872.   return OTclErrBadVal(in, "a tcl method name", name);
  873. }
  874.  
  875. /*
  876.  * object creation
  877.  */
  879. static void
  880. PrimitiveOInit(void* mem, Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
  881.   OTclObject* obj = (OTclObject*)mem;
  883.   obj->teardown = in;
  884.   AddInstance(obj, cl);
  885.   obj->type = InObject(in);
  886.   obj->procs = 0;
  887.   
  888.   /*
  889.    * fake callframe needed to interface to tcl variable
  890.    * manipulations. looks like one below global 
  891.    */
  893.   Tcl_InitHashTable(ObjVarTablePtr(obj), TCL_STRING_KEYS);
  894.   obj->variables.level = 1;
  895. #if TCL_MAJOR_VERSION < 8
  896.   obj->variables.argc = 0;
  897.   obj->variables.argv = 0;
  898. #else
  899.   obj->variables.numCompiledLocals = 0;
  900.   obj->variables.compiledLocals = 0;
  901. #endif
  902.   obj->variables.callerPtr = 0;
  903.   obj->variables.callerVarPtr = 0;
  905. #if TCL_MAJOR_VERSION >= 8
  906.   /* we need to deal with new members in CallFrame in Tcl8.0 */
  907.   obj->variables.isProcCallFrame = 1;
  908.   /* XXX: is it correct to assign global namespace here? */
  909.   obj->variables.nsPtr = ((Interp *)in)->globalNsPtr; 
  910.   obj->variables.objc = 0;
  911.   obj->variables.objv = NULL; /* we don't want byte codes for now */
  912.   obj->variables.procPtr = (Proc *) ckalloc(sizeof(Proc));
  913.   obj->variables.procPtr->iPtr = (Interp *)in;
  914.   obj->variables.procPtr->refCount = 1;
  915.   /* XXX it correct to assign global namespace here? */
  916.   obj->variables.procPtr->cmdPtr = NULL;
  917.   obj->variables.procPtr->bodyPtr = NULL;
  918.   obj->variables.procPtr->numArgs  = 0; /* actual argument count is set below. */
  919.   obj->variables.procPtr->numCompiledLocals = 0;
  920.   obj->variables.procPtr->firstLocalPtr = NULL;
  921.   obj->variables.procPtr->lastLocalPtr = NULL;
  922. #endif
  923. }
  926. static void PrimitiveODestroyNoFree(ClientData cd);
  928. static void 
  929. PrimitiveODestroy(ClientData cd) {
  930.   PrimitiveODestroyNoFree(cd);   
  931.   ckfree((char*)cd);
  932. }
  934. static void
  935. PrimitiveODestroyNoFree(ClientData cd) {
  936.   OTclObject* obj = (OTclObject*)cd;
  937.   Tcl_HashSearch hs;
  938.   Tcl_HashEntry* hp;
  939.   Tcl_HashSearch hs2;
  940.   Tcl_HashEntry* hp2;
  941.   Tcl_Interp* in;
  943.   /*
  944.    * check and latch against recurrent calls with obj->teardown
  945.    */
  947.   if (!obj || !obj->teardown) return;
  948.   in = obj->teardown; obj->teardown = 0;
  950.   /*
  951.    * call and latch user destroy with obj->id if we haven't
  952.    */
  954.   if (obj->id) {
  955.     CONST84 char* args[2] = { "", "destroy" };
  956.     Tcl_CmdInfo info;
  958.     /*
  959.      * but under 7.4p1 it is too late, so check with info
  960.      */
  962.     args[0] = (char *) Tcl_GetCommandName(in, obj->id);
  963.     if (Tcl_GetCommandInfo(in, args[0], &info))
  964.       (void) OTclDispatch(cd, in, 2, args);
  965.     obj->id = 0;
  966.   }
  968.   /*
  969.    * resume the primitive teardown for procs and variables.
  970.    * variables unset here were lost from user destroy, and
  971.    * any trace error messages will be swallowed.
  972.    */
  973.   hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
  974.   while (hp != 0) {
  975.     for (;;) {
  976.       Var* vp = (Var*)Tcl_GetHashValue(hp);
  977.       if (!TclIsVarUndefined(vp)) break;
  978.       hp = Tcl_NextHashEntry(&hs);
  979.       if (hp == 0)
  980.       goto done;
  981.     }
  982.     if (hp != 0) {
  983.       char* name = Tcl_GetHashKey(ObjVarTablePtr(obj), hp);
  984.       (void)OTclUnsetInstVar(obj, in, name, TCL_LEAVE_ERR_MSG);
  985.     }
  986.     hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
  987.   }
  988. done:
  989.   hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
  990.   while (hp != 0) {
  991.    /*
  992.     * We delete the hash table below so disassociate
  993.     * each remaining (undefined) var from its hash table entry.
  994.     * (Otherwise, tcl will later try to delete
  995.     * the already-freed hash table entry.)
  996.     */
  997.     Var* vp = (Var*)Tcl_GetHashValue(hp);
  998.     vp->hPtr = 0;
  999.     hp = Tcl_NextHashEntry(&hs);
  1000.   }
  1001.   Tcl_DeleteHashTable(ObjVarTablePtr(obj));
  1002.   hp2 = obj->procs ? Tcl_FirstHashEntry(obj->procs, &hs2) : 0; 
  1003.   for (; hp2 != 0; hp2 = Tcl_NextHashEntry(&hs2)) {
  1004.     Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hp2);
  1005.     ClientData cdest = cd;
  1006.     if (co->clientData != 0) cdest = co->clientData;
  1007.     if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
  1008.     ckfree((char*)co);
  1009.   }
  1010.   if (obj->procs) {
  1011.     Tcl_DeleteHashTable(obj->procs); ckfree((char*)(obj->procs));
  1012.   }
  1014.   (void)RemoveInstance(obj, obj->cl);
  1016. #if TCL_MAJOR_VERSION >= 8
  1017.   ckfree((char*)(obj->variables.procPtr));
  1018.   ckfree((char*)(obj->variables.varTablePtr));
  1019. #endif
  1020. }
  1023. static OTclObject*
  1024. PrimitiveOCreate(Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
  1025.   OTclObject* obj = (OTclObject*)ckalloc(sizeof(OTclObject)); 
  1026. #if TCL_MAJOR_VERSION < 8
  1027.   if (obj != 0) {
  1028.     PrimitiveOInit(obj, in, name, cl);
  1029.     obj->id = Tcl_CreateCommand(in, name, OTclDispatch, (ClientData)obj,
  1030. PrimitiveODestroy);
  1031.   }
  1032. #else
  1033.   obj->variables.varTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
  1034.   if (obj != 0)
  1035.     if (obj->variables.varTablePtr != 0) {
  1036.       PrimitiveOInit(obj, in, name, cl);
  1037.       obj->id = Tcl_CreateCommand(in, name, (Tcl_CmdProc *) OTclDispatch, 
  1038.   (ClientData)obj, PrimitiveODestroy);
  1039.     } else {
  1040.       ckfree((char *)obj);
  1041.       obj = NULL;
  1042.     }
  1043. #endif
  1044.   return obj;
  1045. }
  1047. static void
  1048. PrimitiveCInit(void* mem, Tcl_Interp* in, CONST84 char* name, OTclClass* class) {
  1049.   OTclObject* obj = (OTclObject*)mem;
  1050.   OTclClass* cl = (OTclClass*)mem;
  1052.   obj->type = InClass(in);
  1053.   cl->super = 0;
  1054.   cl->sub = 0;
  1055.   AddSuper(cl, InObject(in));
  1056.   cl->parent = InObject(in);
  1057.   cl->color = WHITE;
  1058.   cl->order = 0;
  1059.   Tcl_InitHashTable(&cl->instprocs, TCL_STRING_KEYS);
  1060.   Tcl_InitHashTable(&cl->instances, TCL_ONE_WORD_KEYS);
  1061.   cl->objectdata = 0;
  1062. }
  1065. static void
  1066. PrimitiveCDestroy(ClientData cd) {
  1067.   OTclClass* cl = (OTclClass*)cd;
  1068.   OTclObject* obj = (OTclObject*)cd;
  1069.   Tcl_HashSearch hSrch;
  1070.   Tcl_HashEntry* hPtr;
  1071.   Tcl_Interp* in;
  1073.   /*
  1074.    * check and latch against recurrent calls with obj->teardown
  1075.    */
  1076.   
  1077.   if (!obj || !obj->teardown) return;
  1078.   in = obj->teardown; obj->teardown = 0;
  1080.   /*
  1081.    * call and latch user destroy with obj->id if we haven't
  1082.    */
  1084.   if (obj->id) {
  1085.     CONST84 char* args[2] = { "", "destroy" };
  1086.     Tcl_CmdInfo info;
  1088.     /*
  1089.      * but under 7.4p1 it is too late, so check with info
  1090.      */
  1092.     args[0] = (char *) Tcl_GetCommandName(in, obj->id);
  1093.     if (Tcl_GetCommandInfo(in, args[0], &info))
  1094.       (void) OTclDispatch(cd, in, 2, args);
  1095.     obj->id = 0;
  1096.   }
  1098.   /*
  1099.    * resume the primitive teardown for instances and instprocs
  1100.    */ 
  1102.   hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch);
  1103.   while (hPtr) {
  1104.     /*
  1105.      * allow circularity for meta-classes
  1106.      */
  1107.     OTclObject* inst;
  1108.     for (;;) {
  1109.       inst = (OTclObject*)Tcl_GetHashKey(&cl->instances, hPtr);
  1110.       if (inst != (OTclObject*)cl) {
  1111.         CONST84 char* name = (char *) Tcl_GetCommandName(inst->teardown, inst->id);
  1112. (void)Tcl_DeleteCommand(inst->teardown, name);
  1113. break;
  1114.       }
  1115.       hPtr = Tcl_NextHashEntry(&hSrch);
  1116.       if (hPtr == 0)
  1117. goto done;
  1118.     }
  1119.     hPtr = Tcl_FirstHashEntry(&cl->instances, &hSrch);
  1120.   }
  1121. done:
  1122.   hPtr = Tcl_FirstHashEntry(&cl->instprocs, &hSrch); 
  1123.   for (; hPtr != 0; hPtr = Tcl_NextHashEntry(&hSrch)) {
  1124.     /* for version 8 the instprocs are registered, so no need to delete them (?) */
  1125.     Tcl_CmdInfo* co = (Tcl_CmdInfo*)Tcl_GetHashValue(hPtr);
  1126.     ClientData cdest = cd;
  1127.     if (co->clientData != 0) cdest = co->clientData;
  1128.     if (co->deleteProc != 0) (*co->deleteProc)(co->deleteData);
  1129.     ckfree((char*)co);
  1130.   }
  1131.   Tcl_DeleteHashTable(&cl->instprocs);
  1133.   if (cl->objectdata) {
  1134.     Tcl_DeleteHashTable(cl->objectdata);
  1135.     ckfree((char*)(cl->objectdata)); cl->objectdata = 0;
  1136.   }
  1138.   /*
  1139.    * flush all caches, unlink superclasses
  1140.    */ 
  1142.   FlushPrecedences(cl);
  1143.   while (cl->super) (void)RemoveSuper(cl, cl->super->cl);
  1144.   while (cl->sub) (void)RemoveSuper(cl->sub->cl, cl);
  1146.   /*
  1147.    * handoff the primitive teardown
  1148.    */
  1150.   obj->teardown = in;  
  1151.   /* don't want to free the memory since we need to 
  1152.    * delete the hash table later, because we want the 
  1153.    * PrimitiveODestory to destory the hash entries first */
  1154.   PrimitiveODestroyNoFree(cd);
  1155.   Tcl_DeleteHashTable(&cl->instances);
  1156.   ckfree((char*)cd);
  1157. }
  1160. static OTclClass*
  1161. PrimitiveCCreate(Tcl_Interp* in, CONST84 char* name, OTclClass* class){
  1162.   OTclClass* cl = (OTclClass*)ckalloc(sizeof(OTclClass));
  1163. #if TCL_MAJOR_VERSION < 8
  1164.   if (cl != 0) {
  1165.     OTclObject* obj = (OTclObject*)cl;
  1166.     PrimitiveOInit(obj, in, name, class);
  1167.     PrimitiveCInit(cl, in, name, class);
  1168.     obj->id = Tcl_CreateCommand(in, name, OTclDispatch, (ClientData)cl,
  1169. PrimitiveCDestroy);
  1170.   }
  1171. #else
  1172.   cl->object.variables.varTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
  1173.   if (cl != 0) 
  1174.     if (cl->object.variables.varTablePtr != 0) {
  1175.       OTclObject* obj = (OTclObject*)cl;
  1176.       PrimitiveOInit(obj, in, name, class);
  1177.       PrimitiveCInit(cl, in, name, class);
  1178.       obj->id = Tcl_CreateCommand(in, name, (Tcl_CmdProc *) OTclDispatch, 
  1179.   (ClientData)cl, PrimitiveCDestroy);
  1180.     } else {
  1181.       ckfree((char *)cl);
  1182.       cl = NULL;
  1183.     }
  1184. #endif
  1185.   return cl;
  1186. }
  1189. /*
  1190.  * object method implementations
  1191.  */
  1194. static int
  1195. OTclOAllocMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1196.   OTclClass* cl = OTclAsClass(in, cd);
  1197.   OTclObject* newobj;
  1198.   int i;
  1200.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1201.   if (argc < 5) return OTclErrArgCnt(in, argv[0], "alloc <obj> ?args?");
  1202.   newobj = PrimitiveOCreate(in, argv[4], cl);
  1203.   if (newobj == 0) return OTclErrMsg(in,"Object alloc failed", TCL_STATIC);
  1204.   
  1205.   /*
  1206.    * this alloc doesn't process any extra args, so return them all
  1207.    */
  1209.   Tcl_ResetResult(in);
  1210.   for (i = 5; i < argc; i++) Tcl_AppendElement(in, argv[i]);
  1211.   return TCL_OK;
  1212. }
  1215. static int
  1216. OTclOInitMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1217.   OTclObject* obj = OTclAsObject(in, cd);
  1218.   int i;
  1220.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1221.   if (argc < 4) return OTclErrArgCnt(in, argv[0], "init ?args?");
  1222.   if (argc & 1) return OTclErrMsg(in, "uneven number of args", TCL_STATIC);
  1224.   for (i=4; i<argc; i+=2) {
  1225.     int result;
  1226.     CONST84 char* args[3];
  1227.     args[0] = argv[0];
  1228.     args[1] = argv[i]; if (args[1][0] == '-') args[1]++;
  1229.     args[2] = argv[i+1];
  1230.     result = OTclDispatch(cd, in, 3, args);
  1231.     if (result != TCL_OK) {
  1232.       Tcl_AppendResult(in, " during {", args[0], "} {",
  1233.        args[1], "} {", args[2], "}", 0);
  1234.       return result;
  1235.     }
  1236.   }
  1237.   Tcl_ResetResult(in);
  1238.   return TCL_OK;
  1239. }
  1242. static int
  1243. OTclODestroyMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1244.   OTclObject* obj = OTclAsObject(in, cd);
  1245.   Tcl_HashSearch hs;
  1246.   Tcl_HashEntry* hp;
  1247.   Tcl_Command oid;
  1248.   int result = TCL_OK;
  1250.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1251.   if (argc != 4) return OTclErrArgCnt(in, argv[0], "destroy");
  1253.   /*
  1254.    * unset variables here, while it may not be too late
  1255.    * to deal with trace error messages
  1256.    */
  1258.   hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
  1259.   while (hp != 0) {
  1260.     for (;;) {
  1261.       Var* vp = (Var*)Tcl_GetHashValue(hp);
  1262.       if (!TclIsVarUndefined(vp)) break;
  1263.       hp = Tcl_NextHashEntry(&hs);
  1264.       if (hp == 0)
  1265.         goto done;
  1266.     }
  1267.     if (hp != 0) {
  1268.       CONST84 char* name = Tcl_GetHashKey(ObjVarTablePtr(obj), hp);
  1269.       result = OTclUnsetInstVar(obj, in, name, TCL_LEAVE_ERR_MSG);
  1270.       if (result != TCL_OK) break;
  1271.     }
  1272.     hp = Tcl_FirstHashEntry(ObjVarTablePtr(obj), &hs);
  1273.   }
  1274.   if (hp != 0) return TCL_ERROR;
  1275. done:
  1276.   /*
  1277.    * latch, and call delete command if not already in progress
  1278.    */
  1280.   oid = obj->id; obj->id = 0;
  1281.   if (obj->teardown != 0) {
  1282.     CONST84 char* name = (char *) Tcl_GetCommandName(in, oid);
  1283.     return (Tcl_DeleteCommand(in, name) == 0) ? TCL_OK : TCL_ERROR;
  1284.   }
  1285.   
  1286.   Tcl_ResetResult(in);
  1287.   return TCL_OK;
  1288. }
  1291. static int
  1292. OTclOClassMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1293.   OTclObject* obj = OTclAsObject(in, cd);
  1294.   OTclClass* cl;
  1296.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1297.   if (argc != 5) return OTclErrArgCnt(in, argv[0], "class <class>");
  1299.   /*
  1300.    * allow a change to any class; type system enforces safety later
  1301.    */
  1303.   cl = OTclGetClass(in, argv[4]);
  1304.   if (!cl) return OTclErrBadVal(in, "a class", argv[4]);
  1305.   (void)RemoveInstance(obj, obj->cl);
  1306.   AddInstance(obj, cl);
  1307.   return TCL_OK;
  1308. }
  1311. static int OTclCInfoMethod(ClientData, Tcl_Interp*, int, CONST84 char*[]);
  1313. static int
  1314. OTclOInfoMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1315.   OTclObject* obj = OTclAsObject(in, cd);
  1317.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1318.   if (argc < 5) return OTclErrArgCnt(in,argv[0],"info <opt> ?args?");
  1319.   
  1320.   if (!strcmp(argv[4], "class")) {
  1321.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info class ?class?");
  1322.     if (argc == 5) {
  1323.       Tcl_SetResult(in, (char *)Tcl_GetCommandName(in, obj->cl->object.id),
  1324.     TCL_VOLATILE);
  1325.     } else {
  1326.       int result;
  1327.       CONST84 char* saved = argv[4];
  1328.       argv[4] = "superclass";
  1329.       result = OTclCInfoMethod((ClientData)obj->cl, in, argc, argv);
  1330.       argv[4] = saved;
  1331.       return result;
  1332.     }
  1333.   } else if (!strcmp(argv[4], "commands")) {
  1334.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info commands ?pat?");
  1335.     ListKeys(in, obj->procs, (argc == 6) ? argv[5] : 0);
  1336.   } else if (!strcmp(argv[4], "procs")) {
  1337.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info procs ?pat?");
  1338.     ListProcKeys(in, obj->procs, (argc == 6) ? argv[5] : 0);
  1339.   } else if (!strcmp(argv[4], "args")) {
  1340.     if (argc != 6) return OTclErrArgCnt(in,argv[0],"info args <proc>");
  1341.     return ListProcArgs(in, obj->procs, argv[5]);
  1342.   } else if (!strcmp(argv[4], "default")) {
  1343.     if (argc != 8)
  1344.       return OTclErrArgCnt(in,argv[0],"info default <proc> <arg> <var>");
  1345.     return ListProcDefault(in, obj->procs, argv[5], argv[6], argv[7]);
  1346.   } else if (!strcmp(argv[4], "body")) {
  1347.     if (argc != 6) return OTclErrArgCnt(in,argv[0],"info body <proc>");
  1348.     return ListProcBody(in, obj->procs, argv[5]);
  1349.   } else if (!strcmp(argv[4], "vars")) {
  1350.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info vars ?pat?");
  1351.     ListKeys(in, ObjVarTablePtr(obj), (argc == 6) ? argv[5] : 0);
  1352.   } else {
  1353.     return OTclErrBadVal(in, "an info option", argv[4]);
  1354.   }
  1355.   return TCL_OK;
  1356. }
  1359. static int
  1360. OTclOProcMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1361.   OTclObject* obj = OTclAsObject(in, cd);
  1362.   Tcl_CmdInfo proc;
  1363.   int op;
  1365.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1366.   if (argc != 7) return OTclErrArgCnt(in,argv[0],"proc name args body");
  1368.   /*
  1369.    * if the args list is "auto", the body is a script to load the proc
  1370.    */
  1372.   if (!strcmp("auto", argv[5])) op = MakeAuto(&proc, argv[6]);
  1373.   else if (argv[5][0]==0 && argv[6][0]==0) op = -1;
  1374.   else op = MakeProc(&proc,in, argc-3, argv+3);
  1376.   if (!obj->procs) {
  1377.     obj->procs = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
  1378.     Tcl_InitHashTable(obj->procs, TCL_STRING_KEYS);
  1379.   }
  1380.   (void)RemoveMethod(obj->procs, argv[4], (ClientData)obj);
  1381.   if (op == 1) AddMethod(obj->procs, argv[4], proc.proc,
  1382.  proc.clientData, proc.deleteProc, proc.deleteData);
  1383.   
  1384.   return (op != 0) ? TCL_OK : TCL_ERROR;
  1385. }
  1388. static int
  1389. OTclONextMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1390.   OTclObject* obj = OTclAsObject(in, cd);
  1391.   CONST84 char* class = (char *) Tcl_GetVar(in, "class",0);
  1392.   CONST84 char* method = (char *) Tcl_GetVar(in, "proc",0);
  1394.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1395.   if (argc < 4) return OTclErrArgCnt(in, argv[0], "next ?args?");
  1396.   if (!method||!class) return OTclErrMsg(in,"no executing proc", TCL_STATIC);
  1398.   argv[2] = class;
  1399.   argv[3] = method;
  1400.   return OTclNextMethod(obj, in, argc, argv);
  1401. }
  1404. static int
  1405. OTclOSetMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1406.   OTclObject* obj = OTclAsObject(in, cd);
  1407.   CONST84 char* result;
  1409.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1410.   if (argc<5 || argc>6) return OTclErrArgCnt(in, argv[0], "set var ?value?");
  1411.   if (argc == 6)
  1412.     result = OTclSetInstVar(obj, in, argv[4], argv[5], TCL_LEAVE_ERR_MSG);
  1413.   else
  1414.     result = OTclGetInstVar(obj, in, argv[4], TCL_LEAVE_ERR_MSG);
  1415.   if (result != 0) Tcl_SetResult(in, (char *)result, TCL_VOLATILE); 
  1416.   return (result != 0) ? TCL_OK : TCL_ERROR;
  1417. }
  1420. static int
  1421. OTclOUnsetMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1422.   OTclObject* obj = OTclAsObject(in, cd);
  1423.   int result = TCL_ERROR;
  1424.   int i;
  1426.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1427.   if (argc < 5) return OTclErrArgCnt(in, argv[0], "unset ?vars?");
  1429.   for (i=4; i<argc; i++) {
  1430.     result = OTclUnsetInstVar(obj, in, argv[i], TCL_LEAVE_ERR_MSG);
  1431.     if (result != TCL_OK) break;
  1432.   }
  1433.   return result;
  1434. }
  1436. /*
  1437.  * This (fairly low-level) routine is exported to allow tclcl
  1438.  * to avoid generating/evaling tcl code to do its instvar.
  1439.  */
  1440. int
  1441. OTclOInstVarOne(OTclObject* obj, Tcl_Interp *in, char *frameName, CONST84 char *varName, CONST84 char *localName, int flags)
  1442. {
  1443.   Interp* iPtr = (Interp*)in;
  1444.   int result = TCL_ERROR;
  1446.   /*
  1447.    * Fake things as if the caller's stack frame is just over
  1448.    * the object, then use UpVar to suck the object's variable
  1449.    * into the caller.
  1450.    *
  1451.    * Patched for global instvar by Orion Hodson <O.Hodson@cs.ucl.ac.uk>
  1452.    */
  1453.   if (iPtr->varFramePtr) {
  1454.    CallFrame* saved = iPtr->varFramePtr->callerVarPtr;
  1455.    int level = iPtr->varFramePtr->level;
  1457.   iPtr->varFramePtr->callerVarPtr = &obj->variables;
  1458.    iPtr->varFramePtr->level = obj->variables.level+1;
  1459.    result = Tcl_UpVar(in, frameName, varName, localName, flags);
  1460.    iPtr->varFramePtr->callerVarPtr = saved;
  1461.    iPtr->varFramePtr->level = level;
  1462.   } else {
  1463.    Tcl_SetResult(in, "no instvar in global :: scope", TCL_STATIC);
  1464.   }
  1465.   return result;
  1466. }
  1468. static int
  1469. OTclOInstVarMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[])
  1470. {
  1471.   OTclObject* obj = OTclAsObject(in, cd);
  1472.   int i;
  1473.   int result = TCL_ERROR;
  1475.   if (!obj) return OTclErrType(in, argv[0], "Object");
  1476.   if (argc < 5) return OTclErrArgCnt(in, argv[0], "instvar ?vars?");
  1478.   for (i=4; i<argc; i++) {
  1479.     int ac;
  1480.     CONST84 char **av;
  1481.     result = Tcl_SplitList(in, argv[i], &ac, (const char ***) &av);
  1482.     if (result != TCL_OK) break;
  1483.     if (ac == 1) {
  1484.       result = OTclOInstVarOne(obj, in, "1", av[0], av[0], 0);
  1485.     } else if (ac == 2) {
  1486.       result = OTclOInstVarOne(obj, in, "1", av[0], av[1], 0);
  1487.     } else {
  1488.       result = TCL_ERROR;
  1489.       Tcl_ResetResult(in);
  1490.       Tcl_AppendResult(in, "expected ?inst/local? or ?inst? ?local? but got ",
  1491.        argv[i]);
  1492.     }
  1493.     ckfree((char*)av);
  1494.     if (result != TCL_OK) break;
  1495.   }
  1496.   return result;
  1497. }
  1500. /*
  1501.  * class method implementations
  1502.  */
  1505. static int
  1506. OTclCAllocMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1507.   OTclClass* cl = OTclAsClass(in, cd);
  1508.   OTclClass* newcl;
  1509.   int i;
  1511.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1512.   if (argc < 5) return OTclErrArgCnt(in, argv[0], "alloc <cl> ?args?");
  1513.   newcl = PrimitiveCCreate(in, argv[4], cl);
  1514.   if (newcl == 0) return OTclErrMsg(in,"Class alloc failed", TCL_STATIC);
  1516.   /*
  1517.    * this alloc doesn't process any extra args, so return them all
  1518.    */
  1520.   Tcl_ResetResult(in);
  1521.   for (i = 5; i < argc; i++) Tcl_AppendElement(in, argv[i]);
  1522.   return TCL_OK;
  1523. }
  1526. static int
  1527. OTclCCreateMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1528.   OTclClass* cl = OTclAsClass(in, cd);
  1529.   OTclObject* obj;
  1530.   Tcl_CmdProc* proc = 0;
  1531.   ClientData cp = 0;
  1532.   OTclClasses* pl;
  1533.   CONST84 char* args[4];
  1534.   int result;
  1535.   int i;
  1537.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1538.   if (argc < 5) return OTclErrArgCnt(in, argv[0], "create <obj> ?args?");
  1539.   for (pl = ComputePrecedence(cl); pl != 0; pl = pl->next) {
  1540.     Tcl_HashTable* procs = pl->cl->object.procs;
  1541.     if (procs && LookupMethod(procs,"alloc",&proc,&cp,0)) break;
  1542.   }
  1543.   if (!pl) return OTclErrMsg(in, "no reachable alloc", TCL_STATIC);
  1544.   
  1545.   for (i=0; i<4; i++) args[i] = argv[i];
  1546.   argv[0] = (char *) Tcl_GetCommandName(in, pl->cl->object.id);
  1547.   argv[1] = argv[0];
  1548.   argv[2] = "";
  1549.   argv[3] = "alloc";
  1550.   cp = (cp != 0) ? cp : (ClientData)pl->cl;
  1551.   result = (*proc)(cp, in, argc, (const char **) argv);
  1552.   for (i=0; i<4; i++) argv[i] = args[i];
  1553.   if (result != TCL_OK) return result;
  1555.   obj = OTclGetObject(in, argv[4]);
  1556.   if (obj == 0) 
  1557.   return OTclErrMsg(in, "couldn't find result of alloc", TCL_STATIC);
  1558.   (void)RemoveInstance(obj, obj->cl);
  1559.   AddInstance(obj, cl);
  1561.   result = Tcl_VarEval(in, argv[4], " init ", in->result, 0);
  1562.   if (result != TCL_OK) return result;
  1563.   Tcl_SetResult(in, (char *)argv[4], TCL_VOLATILE);
  1564.   return TCL_OK;
  1565. }
  1568. static int
  1569. OTclCSuperClassMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1570.   OTclClass* cl = OTclAsClass(in, cd);
  1571.   OTclClasses* osl = 0;
  1572.   int ac = 0;
  1573.   CONST84 char** av = 0;
  1574.   OTclClass** scl = 0;
  1575.   int reversed = 0;
  1576.   int i, j;
  1578.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1579.   if (argc != 5) return OTclErrArgCnt(in, argv[0], "superclass <classes>");
  1580.   if (Tcl_SplitList(in, argv[4], &ac, (const char ***) &av) != TCL_OK)
  1581.     return TCL_ERROR;
  1583.   scl = (OTclClass**)ckalloc(ac*sizeof(OTclClass*));
  1584.   for (i = 0; i < ac; i++) {
  1585.     scl[i] = OTclGetClass(in, av[i]);
  1586.     if (!scl[i]) {
  1588.       /*
  1589.        * try to force autoloading if we can't resolve a class name
  1590.        */
  1592.       int loaded = 0;
  1593.       char* args = (char*)ckalloc(strlen("auto_load ")+strlen(av[i])+1);
  1594.       (void)strcpy(args, "auto_load ");
  1595.       (void) strcat(args, av[i]);
  1596.       if (Tcl_Eval(in, args) == TCL_OK) {
  1597. scl[i] = OTclGetClass(in, av[i]);
  1598. loaded = (scl[i] != 0);
  1599.       }
  1600.       ckfree(args);
  1601.       if (!loaded) {
  1602. ckfree((char*)av);
  1603. ckfree((char*)scl);
  1604. return OTclErrBadVal(in, "a list of classes", argv[4]);
  1605.       }
  1606.     }
  1607.   }
  1609.   /*
  1610.    * check that superclasses don't precede their classes
  1611.    */
  1613.   for (i = 0; i < ac; i++) {
  1614.     if (reversed != 0) break;
  1615.     for (j = i+1; j < ac; j++) {
  1616.       OTclClasses* dl = ComputePrecedence(scl[j]);
  1617.       if (reversed != 0) break;
  1618.       while (dl != 0) {
  1619. if (dl->cl == scl[i]) break;
  1620. dl = dl->next;
  1621.       }
  1622.       if (dl != 0) reversed = 1;
  1623.     }
  1624.   }
  1625.   
  1626.   if (reversed != 0) {
  1627.     ckfree((char*)av);
  1628.     ckfree((char*)scl);
  1629.     return OTclErrBadVal(in, "classes in dependence order", argv[4]);
  1630.   }
  1631.   
  1632.   while (cl->super != 0) {
  1633.     
  1634.     /*
  1635.      * build up an old superclass list in case we need to revert
  1636.      */ 
  1638.     OTclClass* sc = cl->super->cl;
  1639.     OTclClasses* l = osl;
  1640.     osl = (OTclClasses*)ckalloc(sizeof(OTclClasses));
  1641.     osl->cl = sc;
  1642.     osl->next = l;
  1643.     (void)RemoveSuper(cl, cl->super->cl);
  1644.   }
  1645.   for (i = 0; i < ac; i++)
  1646.     AddSuper(cl, scl[i]);
  1647.   ckfree((char*)av);
  1648.   ckfree((char*)scl);
  1649.   FlushPrecedences(cl);
  1650.   
  1651.   if (!ComputePrecedence(cl)) {
  1653.     /*
  1654.      * cycle in the superclass graph, backtrack
  1655.      */ 
  1657.     OTclClasses* l;
  1658.     while (cl->super != 0) (void)RemoveSuper(cl, cl->super->cl);
  1659.     for (l = osl; l != 0; l = l->next) AddSuper(cl, l->cl);
  1660.     RC(osl);
  1661.     return OTclErrBadVal(in, "a cycle-free graph", argv[4]);
  1662.   }
  1663.   RC(osl);
  1664.   Tcl_ResetResult(in);
  1665.   return TCL_OK;
  1666. }
  1669. static int
  1670. OTclCInfoMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1671.   OTclClass* cl = OTclAsClass(in, cd);
  1673.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1674.   if (argc < 5) return OTclErrArgCnt(in,argv[0],"info <opt> ?args?");
  1676.   if (!strcmp(argv[4], "superclass")) {
  1677.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info superclass ?class?");
  1678.     if (argc == 5) {
  1679.       OTclClasses* sl = cl->super;
  1680.       OTclClasses* sc = 0;
  1681.       
  1682.       /*
  1683.        * reverse the list to obtain presentation order
  1684.        */ 
  1685.       
  1686.       Tcl_ResetResult(in);
  1687.       while (sc != sl) {
  1688. OTclClasses* nl = sl;
  1689. while (nl->next != sc) nl = nl->next;
  1690. Tcl_AppendElement(in, Tcl_GetCommandName(in, nl->cl->object.id));
  1691. sc = nl;
  1692.       }
  1693.     } else {
  1694.       OTclClass* isc = OTclGetClass(in, argv[5]);
  1695.       OTclClasses* pl;
  1696.       if (isc == 0) return OTclErrBadVal(in, "a class", argv[5]);
  1697.       pl = ComputePrecedence(cl);
  1698.       
  1699.       /*
  1700.        * search precedence to see if we're related or not
  1701.        */
  1703.       while (pl != 0) {
  1704. if (pl->cl == isc) {
  1705.   Tcl_SetResult(in, "1", TCL_STATIC);
  1706.   break;
  1707. }
  1708. pl = pl->next;
  1709.       }
  1710.       if (pl == 0) Tcl_SetResult(in, "0", TCL_STATIC);
  1711.     }
  1712.   } else if (!strcmp(argv[4], "subclass")) {
  1713.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info subclass ?class?");
  1714.     if (argc == 5) {
  1715.       OTclClasses* sl = cl->sub;
  1716.       OTclClasses* sc = 0;
  1717.       
  1718.       /*
  1719.        * order unimportant
  1720.        */ 
  1721.       
  1722.       Tcl_ResetResult(in);
  1723.       for (sc = sl; sc != 0; sc = sc->next)
  1724. Tcl_AppendElement(in, Tcl_GetCommandName(in, sc->cl->object.id));
  1725.     } else {
  1726.       OTclClass* isc = OTclGetClass(in, argv[5]);
  1727.       OTclClasses* pl;
  1728.       OTclClasses* saved;
  1729.       if (isc == 0) return OTclErrBadVal(in, "a class", argv[5]);
  1730.       saved = cl->order; cl->order = 0;
  1731.       pl = ComputeDependents(cl);
  1732.       
  1733.       /*
  1734.        * search precedence to see if we're related or not
  1735.        */
  1737.       while (pl != 0) {
  1738. if (pl->cl == isc) {
  1739.   Tcl_SetResult(in, "1", TCL_STATIC);
  1740.   break;
  1741. }
  1742. pl = pl->next;
  1743.       }
  1744.       if (pl == 0) Tcl_SetResult(in, "0", TCL_STATIC);
  1745.       RC(cl->order); cl->order = saved;
  1746.     }
  1747.   } else if (!strcmp(argv[4], "heritage")) {
  1748.     OTclClasses* pl = ComputePrecedence(cl);
  1749.     CONST84 char* pattern = (argc == 6) ? argv[5] : 0;
  1750.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info heritage ?pat?");
  1751.     if (pl) pl = pl->next;
  1752.     Tcl_ResetResult(in);
  1753.     for (; pl != 0; pl = pl->next) {
  1754.       CONST84 char* name = (char *) Tcl_GetCommandName(in, pl->cl->object.id);
  1755.       if (pattern && !Tcl_StringMatch(name, pattern)) continue;
  1756.       Tcl_AppendElement(in, name);
  1757.     }
  1758.   } else if (!strcmp(argv[4], "instances")) {
  1759.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instances ?pat?");
  1760.     ListInstanceKeys(in, &cl->instances, (argc == 6) ? argv[5] : 0);
  1761.   } else if (!strcmp(argv[4], "instcommands")) {
  1762.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instcommands ?pat?");
  1763.     ListKeys(in, &cl->instprocs, (argc == 6) ? argv[5] : 0);
  1764.   } else if (!strcmp(argv[4], "instprocs")) {
  1765.     if (argc > 6) return OTclErrArgCnt(in,argv[0],"info instprocs ?pat?");
  1766.     ListProcKeys(in, &cl->instprocs, (argc == 6) ? argv[5] : 0);
  1767.   } else if (!strcmp(argv[4], "instargs")) {
  1768.     if (argc != 6) return OTclErrArgCnt(in,argv[0],"info instargs <instproc>");
  1769.     return ListProcArgs(in, &cl->instprocs, argv[5]);
  1770.   } else if (!strcmp(argv[4], "instdefault")) {
  1771.     if (argc != 8)
  1772.       return OTclErrArgCnt(in,argv[0],
  1773.    "info instdefault <instproc> <arg> <var>");
  1774.     return ListProcDefault(in, &cl->instprocs, argv[5], argv[6], argv[7]);
  1775.   } else if (!strcmp(argv[4], "instbody")) {
  1776.     if (argc != 6) return OTclErrArgCnt(in,argv[0],"info instbody <instproc>");
  1777.     return ListProcBody(in, &cl->instprocs, argv[5]);
  1778.   } else {
  1779.     return OTclOInfoMethod(cd, in, argc, argv);
  1780.   }
  1781.   return TCL_OK;
  1782. }
  1785. static int
  1786. OTclCInstProcMethod(ClientData cd, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1787.   OTclClass* cl = OTclAsClass(in, cd);
  1788.   Tcl_CmdInfo proc;
  1789.   int op;
  1791.   if (!cl) return OTclErrType(in, argv[0], "Class");
  1792.   if (argc != 7) return OTclErrArgCnt(in,argv[0],"instproc name args body");
  1793.   
  1794.   /*
  1795.    * if the args list is "auto", the body is a script to load the proc
  1796.    */
  1798.   if (!strcmp("auto", argv[5])) op = MakeAuto(&proc, argv[6]);
  1799.   else if (argv[5][0]==0 && argv[6][0]==0) op = -1;
  1800.   else op = MakeProc(&proc,in, argc-3, argv+3);
  1802.   (void)RemoveMethod(&cl->instprocs, argv[4], (ClientData)cl);
  1803.   if (op == 1) AddMethod(&cl->instprocs, argv[4], proc.proc,
  1804.  proc.clientData, proc.deleteProc, proc.deleteData);
  1805.   
  1806.   return (op != 0) ? TCL_OK : TCL_ERROR;
  1807. }
  1809. /*
  1810.  * C interface routines for manipulating objects and classes
  1811.  */
  1814. extern OTclObject*
  1815. OTclAsObject(Tcl_Interp* in, ClientData cd) {
  1816.   OTclObject* obj = (OTclObject*)cd;
  1817.   return IsType(obj, InObject(in)) ? obj : 0;
  1818. }
  1821. extern OTclClass*
  1822. OTclAsClass(Tcl_Interp* in, ClientData cd) {
  1823.   OTclClass* cl = (OTclClass*)cd;
  1824.   return IsType((OTclObject*)cl, InClass(in)) ? cl : 0;
  1825. }
  1828. extern OTclObject*
  1829. OTclGetObject(Tcl_Interp* in, CONST84 char* name) {
  1830.   Tcl_CmdInfo info;
  1831.   OTclObject* obj = 0;
  1832.   if (Tcl_GetCommandInfo(in, name, &info))
  1833.     if (info.proc == (Tcl_CmdProc *) OTclDispatch)
  1834.       obj = OTclAsObject(in, info.clientData);
  1835.   return obj;
  1836. }
  1839. extern OTclClass*
  1840. OTclGetClass(Tcl_Interp* in, CONST84 char* name) {
  1841.   Tcl_CmdInfo info;
  1842.   OTclClass* cl = 0;
  1843.   if (Tcl_GetCommandInfo(in, name, &info))
  1844.     if (info.proc == (Tcl_CmdProc *) OTclDispatch)
  1845.       cl = OTclAsClass(in, info.clientData);
  1846.   return cl;
  1847. }
  1850. extern OTclObject*
  1851. OTclCreateObject(Tcl_Interp* in, CONST84 char* name, OTclClass* cl) {
  1852.   CONST84 char* args[3];
  1853.   args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
  1854.   args[1] = "create";
  1855.   args[2] = name;
  1856.   if (OTclDispatch((ClientData)cl,in,3,args) != TCL_OK) return 0;
  1857.   return OTclGetObject(in, name);
  1858. }
  1861. extern OTclClass*
  1862. OTclCreateClass(Tcl_Interp* in, CONST84 char* name, OTclClass* cl){
  1863.   CONST84 char* args[3];
  1864.   args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
  1865.   args[1] = "create";
  1866.   args[2] = name;
  1867.   if (OTclDispatch((ClientData)cl,in,3,args) != TCL_OK) return 0;
  1868.   return OTclGetClass(in, name);
  1869. }
  1872. extern int
  1873. OTclDeleteObject(Tcl_Interp* in, OTclObject* obj) {
  1874.   CONST84 char* args[2];
  1875.   args[0] = (char *) Tcl_GetCommandName(in, obj->id);
  1876.   args[1] = "destroy";
  1877.   return OTclDispatch((ClientData)obj, in, 2, args);
  1878. }
  1881. extern int
  1882. OTclDeleteClass(Tcl_Interp* in, OTclClass* cl) {
  1883.   CONST84 char* args[2];
  1884.   args[0] = (char *) Tcl_GetCommandName(in, cl->object.id);
  1885.   args[1] = "destroy";
  1886.   return OTclDispatch((ClientData)cl, in, 2, args);
  1887. }
  1890. extern void
  1891. OTclAddPMethod(OTclObject* obj, char* nm, Tcl_CmdProc* proc,
  1892.        ClientData cd, Tcl_CmdDeleteProc* dp)
  1893. {
  1894.   if (obj->procs)
  1895.     (void)RemoveMethod(obj->procs, nm, (ClientData)obj);
  1896.   else {
  1897.     obj->procs = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
  1898.     Tcl_InitHashTable(obj->procs, TCL_STRING_KEYS);
  1899.   }
  1900.   AddMethod(obj->procs, nm, proc, cd, dp, cd);
  1901. }
  1904. extern void
  1905. OTclAddIMethod(OTclClass* cl, char* nm, Tcl_CmdProc* proc,
  1906.        ClientData cd, Tcl_CmdDeleteProc* dp)
  1907. {
  1908.   (void)RemoveMethod(&cl->instprocs, nm, (ClientData)cl);
  1909.   AddMethod(&cl->instprocs, nm, proc, cd, dp, cd);
  1910. }
  1913. extern int
  1914. OTclRemovePMethod(OTclObject* obj, char* nm) {
  1915.   if (obj->procs) return RemoveMethod(obj->procs, nm, (ClientData)obj);
  1916.   else return 0;
  1917. }
  1920. extern int
  1921. OTclRemoveIMethod(OTclClass* cl, char* nm) {
  1922.   return RemoveMethod(&cl->instprocs, nm, (ClientData)cl);
  1923. }
  1926. extern int
  1927. OTclNextMethod(OTclObject* obj, Tcl_Interp* in, int argc, CONST84 char*argv[]) {
  1928.   OTclClass* cl = 0;
  1929.   OTclClass* ncl;
  1930.   OTclClasses* pl;
  1931.   Tcl_CmdProc* proc = 0;
  1932.   ClientData cp = 0;
  1933.   CONST84 char* class = argv[2];
  1934.   int result = TCL_OK;
  1936.   if (class[0]){
  1937.     cl = OTclGetClass(in, class);
  1938.     if (!cl) return OTclErrBadVal(in, "a class", class);
  1939.   }  
  1941.   /*
  1942.    * if we are already in the precedence ordering, then advance
  1943.    * past our last point; otherwise (if cl==0) start from the start
  1944.    */
  1946.   pl = ComputePrecedence(obj->cl);
  1947.   while (pl && cl) {
  1948.     if (pl->cl == cl) cl = 0;
  1949.     pl = pl->next;
  1950.   }
  1952.   /*
  1953.    * search for a further class method and patch args before launching.
  1954.    * if no further method, return without error.
  1955.    */
  1957.   ncl = SearchCMethod(pl, argv[3], &proc, &cp, 0);  
  1958.   if (proc != 0) {
  1959.     cp = (cp != 0) ? cp : (ClientData)obj;
  1960.     argv[2] = (char *) Tcl_GetCommandName(in, ncl->object.id);
  1961.     result = (*proc)(cp, in, argc, (const char **) argv);
  1962.     argv[2] = class;
  1963.   }
  1964.   return result;
  1965. }
  1968. extern CONST84_RETURN char*
  1969. OTclSetInstVar(OTclObject* obj,Tcl_Interp* in, 
  1970.        CONST84 char* name, CONST84 char* value,int flgs){
  1971.   Interp* iPtr = (Interp*)in;
  1972.   CallFrame* saved = iPtr->varFramePtr;
  1973.   CONST84 char* result;
  1975.   iPtr->varFramePtr = &obj->variables;
  1976.   result = (char *) Tcl_SetVar(in, name, value, flgs);
  1977.   iPtr->varFramePtr = saved;
  1978.   return result;
  1979. }
  1982. extern CONST84_RETURN char*
  1983. OTclGetInstVar(OTclObject* obj, Tcl_Interp* in, CONST84 char* name, int flgs){
  1984.   Interp* iPtr = (Interp*)in;
  1985.   CallFrame* saved = iPtr->varFramePtr;
  1986.   CONST84 char* result;
  1988.   iPtr->varFramePtr = &obj->variables;
  1989.   result = (char *) Tcl_GetVar(in, name, flgs);
  1990.   iPtr->varFramePtr = saved;
  1991.   return result;
  1992. }
  1995. extern int
  1996. OTclUnsetInstVar(OTclObject* obj, Tcl_Interp* in, CONST84 char* name, int flgs) {
  1997.   Interp* iPtr = (Interp*)in;
  1998.   CallFrame* saved = iPtr->varFramePtr;
  1999.   int result;
  2001.   iPtr->varFramePtr = &obj->variables;
  2002.   result = Tcl_UnsetVar(in, name, flgs);
  2003.   iPtr->varFramePtr = saved;
  2004.   return result;
  2005. }
  2008. extern void
  2009. OTclSetObjectData(OTclObject* obj, OTclClass* cl, ClientData data) {
  2010.   Tcl_HashEntry *hPtr;
  2011.   int nw;
  2013.   if (!cl->objectdata) {
  2014.     cl->objectdata = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
  2015.     Tcl_InitHashTable(cl->objectdata, TCL_ONE_WORD_KEYS);
  2016.   }
  2017.   hPtr = Tcl_CreateHashEntry(cl->objectdata, (char*)obj, &nw);
  2018.   Tcl_SetHashValue(hPtr, data);
  2019. }
  2022. extern int
  2023. OTclGetObjectData(OTclObject* obj, OTclClass* cl, ClientData* data) {
  2024.   Tcl_HashEntry *hPtr;
  2026.   if (!cl->objectdata) return 0;
  2027.   hPtr = Tcl_FindHashEntry(cl->objectdata, (char*)obj);
  2028.   if (data) *data = hPtr ? Tcl_GetHashValue(hPtr) : 0;
  2029.   return (hPtr != 0);
  2030. }
  2033. extern int
  2034. OTclUnsetObjectData(OTclObject* obj, OTclClass* cl) {
  2035.   Tcl_HashEntry *hPtr;
  2037.   if (!cl->objectdata) return 0;
  2038.   hPtr = Tcl_FindHashEntry(cl->objectdata, (char*)obj);
  2039.   if (hPtr) Tcl_DeleteHashEntry(hPtr);
  2040.   return (hPtr != 0);
  2041. }
  2044. /*
  2045.  * Tcl extension initialization routine
  2046.  */
  2048. #define MAXTCLPROC 4096
  2050. extern int
  2051. Otcl_Init(Tcl_Interp* in) {
  2052.   OTclClass* theobj = 0;
  2053.   OTclClass* thecls = 0;
  2054.   Tcl_HashEntry* hp1;
  2055.   Tcl_HashEntry* hp2;
  2056.   int nw1;
  2057.   int nw2;
  2058.   char tm[MAXTCLPROC];
  2059. #if TCL_MAJOR_VERSION >= 8
  2060.   Tcl_Namespace *namespacePtr;
  2061. #endif
  2062.   
  2063.   /*
  2064.    * discover Tcl's hidden proc interpreter
  2065.    */
  2066.   
  2067.   if (ProcInterpId == 0) {
  2068.     char* args[4];
  2069. #if TCL_MAJOR_VERSION >= 8
  2070.     int i;
  2071.     int res = 0;
  2072.     Tcl_Obj* objv[4];
  2073. #endif
  2075.     args[0]="proc"; args[1]="_fake_"; args[2]=""; args[3]="return";
  2077. #if TCL_MAJOR_VERSION < 8
  2078.     if (Tcl_ProcCmd(0, in, 4, args) == TCL_OK) {
  2079.       Tcl_CmdInfo info;
  2080.       if (Tcl_GetCommandInfo(in, args[1], &info)) {
  2081. ProcInterpId = info.proc;
  2082. (void)Tcl_DeleteCommand(in, args[1]);
  2083.       } else return OTclErrMsg(in, "proc failed", TCL_STATIC);
  2084.     } else return TCL_ERROR;
  2085. #else /*TCL_MAJOR_VERSION >= 8*/
  2086.     for (i = 0; i < 4; i++) {
  2087.       objv[i] = Tcl_NewStringObj(args[i], -1);
  2088.       Tcl_IncrRefCount(objv[i]);
  2089.     }
  2090.     if (Tcl_ProcObjCmd(0, in, 4, objv) == TCL_OK) {
  2091.       Tcl_CmdInfo info;
  2092.       if (Tcl_GetCommandInfo(in, args[1], &info)) {
  2093. ProcInterpId = info.proc;
  2094. (void)Tcl_DeleteCommand(in, args[1]);
  2095.       } else 
  2096. res = 1;
  2097.     } else 
  2098.       res = 2;
  2099.     for (i = 0; i < 4; i++)
  2100.       Tcl_DecrRefCount(objv[i]);
  2101.     switch (res) {
  2102.     case 1: return OTclErrMsg(in, "proc failed", TCL_STATIC);
  2103.     case 2: return TCL_ERROR;
  2104.     }
  2105. #endif  /*TCL_MAJOR_VERSION >= 8*/
  2106.   }
  2107.   /*
  2108.    * bootstrap the tables of base objects and classes
  2109.    */
  2110.   
  2111.   if (theObjects == 0) {
  2112.     theObjects = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
  2113.     if (!theObjects) return OTclErrMsg(in, "Object table failed", TCL_STATIC);
  2114.     Tcl_InitHashTable(theObjects, TCL_ONE_WORD_KEYS);
  2115.   }
  2117.   if (theClasses == 0) {
  2118.     theClasses = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
  2119.     if (!theClasses) return OTclErrMsg(in, "Class table failed", TCL_STATIC);
  2120.     Tcl_InitHashTable(theClasses, TCL_ONE_WORD_KEYS);
  2121.   }
  2122.     
  2123.   hp1 = Tcl_CreateHashEntry(theObjects, (char*)in, &nw1);
  2124.   if (nw1) theobj = PrimitiveCCreate(in, "Object", 0);
  2125.   hp2 = Tcl_CreateHashEntry(theClasses, (char*)in, &nw2);
  2126.   if (nw2) thecls = PrimitiveCCreate(in, "Class", 0);
  2128.   if (!nw1 && !nw2) {
  2129.     Tcl_SetResult(in, "0", TCL_STATIC);
  2130.     return TCL_OK;
  2131.   } else if (!theobj || !thecls) {
  2132.     if (theobj) PrimitiveCDestroy((ClientData)theobj);
  2133.     if (thecls) PrimitiveCDestroy((ClientData)thecls);
  2134.     return OTclErrMsg(in, "Object/Class failed", TCL_STATIC);
  2135.   }
  2137.   Tcl_SetHashValue(hp1, (char*)theobj);
  2138.   Tcl_SetHashValue(hp2, (char*)thecls);
  2139.     
  2140.   theobj->object.type = thecls;
  2141.   theobj->parent = 0;
  2142.   thecls->object.type = thecls;
  2143.   thecls->parent = theobj;
  2145.   AddInstance((OTclObject*)theobj, thecls);
  2146.   AddInstance((OTclObject*)thecls, thecls);
  2147.   AddSuper(thecls, theobj);
  2149. #if TCL_MAJOR_VERSION >= 8
  2150.   /* create the otcl namespace of otcl instprocs and procs */
  2151.   namespacePtr = Tcl_CreateNamespace(in, "otcl", (ClientData) NULL,
  2152.      (Tcl_NamespaceDeleteProc *) NULL);  
  2153.   if (namespacePtr==NULL)
  2154.     return OTclErrMsg(in, "creation of name space failed", TCL_STATIC);
  2155. #endif
  2156.   
  2157.   /*
  2158.    * and fill them with functionality
  2159.    */
  2160.   
  2161.   OTclAddPMethod((OTclObject*)theobj, "alloc", (Tcl_CmdProc *) OTclOAllocMethod, 0, 0);
  2162.   OTclAddIMethod(theobj, "init", (Tcl_CmdProc *) OTclOInitMethod, 0, 0);
  2163.   OTclAddIMethod(theobj, "destroy", (Tcl_CmdProc *) OTclODestroyMethod, 0, 0);
  2164.   OTclAddIMethod(theobj, "class", (Tcl_CmdProc *) OTclOClassMethod, 0, 0);
  2165.   OTclAddIMethod(theobj, "info", (Tcl_CmdProc *) OTclOInfoMethod, 0, 0);
  2166.   OTclAddIMethod(theobj, "proc", (Tcl_CmdProc *) OTclOProcMethod, 0, 0);
  2167.   OTclAddIMethod(theobj, "next", (Tcl_CmdProc *) OTclONextMethod, 0, 0);
  2168.   OTclAddIMethod(theobj, "set", (Tcl_CmdProc *) OTclOSetMethod, 0, 0);
  2169.   OTclAddIMethod(theobj, "unset", (Tcl_CmdProc *) OTclOUnsetMethod, 0, 0);
  2170.   OTclAddIMethod(theobj, "instvar", (Tcl_CmdProc *) OTclOInstVarMethod, 0, 0);
  2172.   OTclAddPMethod((OTclObject*)thecls, "alloc", (Tcl_CmdProc *) OTclCAllocMethod, 0, 0);
  2173.   OTclAddIMethod(thecls, "create", (Tcl_CmdProc *) OTclCCreateMethod, 0, 0);
  2174.   OTclAddIMethod(thecls, "superclass", (Tcl_CmdProc *) OTclCSuperClassMethod, 0, 0);
  2175.   OTclAddIMethod(thecls, "info", (Tcl_CmdProc *) OTclCInfoMethod, 0, 0);
  2176.   OTclAddIMethod(thecls, "instproc", (Tcl_CmdProc *) OTclCInstProcMethod, 0, 0);
  2178.   /*
  2179.    * with some methods and library procs in tcl - they could go in a
  2180.    * otcl.tcl file, but they're embedded here with Tcl_Eval to avoid
  2181.    * the need to carry around a separate library.
  2182.    */
  2184.   (void)strcpy(tm, "Object instproc array {opt ary args} {             n");
  2185.   (void)strcat(tm, "  $self instvar $ary                               n");
  2186.   (void)strcat(tm, "  eval array [list $opt] [list $ary] $args         n");
  2187.   (void)strcat(tm, "}                                                  n");
  2188.   if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
  2189.   
  2190.   (void)strcpy(tm, "Class instproc unknown {m args} {                  n");
  2191.   (void)strcat(tm, "  if {$m == {create}} then {                       n");
  2192.   (void)strcat(tm, "    error "$self: unable to dispatch $m"         n");
  2193.   (void)strcat(tm, "  }                                                n");
  2194.   (void)strcat(tm, "  eval [list $self] create [list $m] $args         n");
  2195.   (void)strcat(tm, "}                                                  n");
  2196.   if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
  2197.   
  2198.   (void)strcpy(tm, "proc otcl_load {obj file} {                        n");
  2199.   (void)strcat(tm, "   global auto_index                               n");
  2200.   (void)strcat(tm, "   source $file                                    n");
  2201.   (void)strcat(tm, "   foreach i [array names auto_index             \n");
  2202.   (void)strcat(tm, "       [list $obj *proc *]] {                      n");
  2203.   (void)strcat(tm, "     set type [lindex $i 1]                        n");
  2204.   (void)strcat(tm, "     set meth [lindex $i 2]                        n");
  2205.   (void)strcat(tm, "     if {[$obj info ${type}s $meth] == {}} then {  n");
  2206.   (void)strcat(tm, "       $obj $type $meth {auto} $auto_index($i)     n");
  2207.   (void)strcat(tm, "     }                                             n");
  2208.   (void)strcat(tm, "   }                                               n");
  2209.   (void)strcat(tm, " }                                                 n");
  2210.   if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
  2212.   (void)strcpy(tm, "proc otcl_mkindex {meta dir args} {                n");
  2213.   (void)strcat(tm, "  set sp {[  ]+}                            n");
  2214.   (void)strcat(tm, "  set st {^[  ]*}                            n");
  2215.   (void)strcat(tm, "  set wd {([^  ]+)}                           n");
  2216.   (void)strcat(tm, "  foreach creator $meta {                          n");
  2217.   (void)strcat(tm, "    lappend cp "$st$creator${sp}create$sp$wd"    n");
  2218.   (void)strcat(tm, "    lappend ap "$st$creator$sp$wd"               n");
  2219.   (void)strcat(tm, "  }                                                n");
  2220.   (void)strcat(tm, "  foreach method {proc instproc} {                 n");
  2221.   (void)strcat(tm, "    lappend mp "$st$wd${sp}($method)$sp$wd"      n");
  2222.   (void)strcat(tm, "  }                                                n");
  2223.   (void)strcat(tm, "  foreach cl [concat Class [Class info heritage]] {n");
  2224.   (void)strcat(tm, "    eval lappend meths [$cl info instcommands]     n");
  2225.   (void)strcat(tm, "  }                                                n");
  2226.   (void)strcat(tm, "  set old [pwd]                                    n");
  2227.   (void)strcat(tm, "  cd $dir                                          n");
  2228.   (void)strcat(tm, "  append idx "# Tcl autoload index file, "       n");
  2229.   (void)strcat(tm, "  append idx "version 2.0\n"                    n");
  2230.   (void)strcat(tm, "  append idx "# otcl additions generated with "  n");
  2231.   (void)strcat(tm, "  append idx "\"otcl_mkindex [list $meta] "    n");
  2232.   (void)strcat(tm, "  append idx "[list $dir] $args\"\n"          n");
  2233.   (void)strcat(tm, "  set oc 0                                         n");
  2234.   (void)strcat(tm, "  set mc 0                                         n");
  2235.   (void)strcat(tm, "  foreach file [eval glob -nocomplain -- $args] {  n");
  2236.   (void)strcat(tm, "    if {[catch {set f [open $file]} msg]} then {   n");
  2237.   (void)strcat(tm, "      catch {close $f}                             n");
  2238.   (void)strcat(tm, "      cd $old                                      n");
  2239.   (void)strcat(tm, "      error $msg                                   n");
  2240.   (void)strcat(tm, "    }                                              n");
  2241.   (void)strcat(tm, "    while {[gets $f line] >= 0} {                  n");
  2242.   (void)strcat(tm, "      foreach c $cp {                              n");
  2243.   (void)strcat(tm, "     if {[regexp $c $line x obj]==1 &&          n");
  2244.   (void)strcat(tm, "         [string index $obj 0]!={$}} then {     n");
  2245.   (void)strcat(tm, "       incr oc                                  n");
  2246.   (void)strcat(tm, "       append idx "set auto_index($obj) "     n");
  2247.   (void)strcat(tm, "       append idx "\"otcl_load $obj "       n");
  2248.   (void)strcat(tm, "          append idx "\$dir/$file\"\n"       n");
  2249.   (void)strcat(tm, "     }                                          n");
  2250.   (void)strcat(tm, "   }                                            n");
  2251.   (void)strcat(tm, "      foreach a $ap {                              n");
  2252.   (void)strcat(tm, "     if {[regexp $a $line x obj]==1 &&          n");
  2253.   (void)strcat(tm, "         [string index $obj 0]!={$} &&          n");
  2254.   (void)strcat(tm, "         [lsearch -exact $meths $obj]==-1} {    n");
  2255.   (void)strcat(tm, "       incr oc                                  n");
  2256.   (void)strcat(tm, "       append idx "set auto_index($obj) "     n");
  2257.   (void)strcat(tm, "       append idx "\"otcl_load $obj "       n");
  2258.   (void)strcat(tm, "          append idx "\$dir/$file\"\n"       n");
  2259.   (void)strcat(tm, "     }                                          n");
  2260.   (void)strcat(tm, "   }                                            n");
  2261.   (void)strcat(tm, "      foreach m $mp {                              n");
  2262.   (void)strcat(tm, "     if {[regexp $m $line x obj ty pr]==1 &&    n");
  2263.   (void)strcat(tm, "         [string index $obj 0]!={$} &&          n");
  2264.   (void)strcat(tm, "         [string index $pr 0]!={$}} then {      n");
  2265.   (void)strcat(tm, "         incr mc                                n");
  2266.   (void)strcat(tm, "         append idx "set \{auto_index($obj " n");
  2267.   (void)strcat(tm, "         append idx "$ty $pr)\} \"source " n");
  2268.   (void)strcat(tm, "         append idx "\$dir/$file\"\n"     n");
  2269.   (void)strcat(tm, "     }                                          n");
  2270.   (void)strcat(tm, "      }                                            n");
  2271.   (void)strcat(tm, "    }                                              n");
  2272.   (void)strcat(tm, "    close $f                                       n");
  2273.   (void)strcat(tm, "  }                                                n");
  2274.   (void)strcat(tm, "  set t [open tclIndex a+]                         n");
  2275.   (void)strcat(tm, "  puts $t $idx nonewline                           n");
  2276.   (void)strcat(tm, "  close $t                                         n");
  2277.   (void)strcat(tm, "  cd $old                                          n");
  2278.   (void)strcat(tm, "  return "$oc objects, $mc methods"              n");
  2279.   (void)strcat(tm, "}                                                  n");
  2280.   if (Tcl_Eval(in, tm) != TCL_OK) return TCL_ERROR;
  2282.   Tcl_SetResult(in, "1", TCL_STATIC);
  2283.   return TCL_OK;
  2284. }
  2286. /*
  2287.  * Otcl strangness:  why isn't c listed?
  2288.  *    dash> otclsh
  2289.  *    % Class Foo
  2290.  *    Foo
  2291.  *    % Foo instproc a a {}
  2292.  *    % Foo instproc b {} { }
  2293.  *    % Foo instproc c {} {}
  2294.  *    % Foo info instprocs
  2295.  *    a b
  2296.  * -johnh, 30-Jun-98
  2297.  */