📄 itcl_obsolete.c
字号:
/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * Procedures in this file support the old-style syntax for [incr Tcl] * class definitions: * * itcl_class <className> { * inherit <base-class>... * * constructor {<arglist>} { <body> } * destructor { <body> } * * method <name> {<arglist>} { <body> } * proc <name> {<arglist>} { <body> } * * public <varname> ?<init>? ?<config>? * protected <varname> ?<init>? * common <varname> ?<init>? * } * * This capability will be removed in a future release, after users * have had a chance to switch over to the new syntax. * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * RCS: $Id: itcl_obsolete.c 144 2003-02-05 10:56:26Z mdejong $ * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */#include "itclInt.h"/* * FORWARD DECLARATIONS */static int ItclOldClassCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldMethodCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldPublicCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldProtectedCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldCommonCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiDeleteCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiVirtualCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiPreviousCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiInfoMethodsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiInfoProcsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiInfoPublicsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiInfoProtectedsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));static int ItclOldBiInfoCommonsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj* CONST objv[]));/* * Standard list of built-in methods for old-style objects. */typedef struct BiMethod { char* name; /* method name */ char* usage; /* string describing usage */ char* registration; /* registration name for C proc */ Tcl_ObjCmdProc *proc; /* implementation C proc */} BiMethod;static BiMethod BiMethodList[] = { { "cget", "-option", "@itcl-oldstyle-cget", Itcl_BiCgetCmd }, { "configure", "?-option? ?value -option value...?", "@itcl-oldstyle-configure", Itcl_BiConfigureCmd }, { "delete", "", "@itcl-oldstyle-delete", ItclOldBiDeleteCmd }, { "isa", "className", "@itcl-oldstyle-isa", Itcl_BiIsaCmd },};static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); /* * ------------------------------------------------------------------------ * Itcl_OldInit() * * Invoked by Itcl_Init() whenever a new interpeter is created to add * [incr Tcl] facilities. Adds the commands needed for backward * compatibility with previous releases of [incr Tcl]. * ------------------------------------------------------------------------ */intItcl_OldInit(interp,info) Tcl_Interp *interp; /* interpreter to be updated */ ItclObjectInfo *info; /* info regarding all known objects */{ int i; Tcl_Namespace *parserNs, *oldBiNs; /* * Declare all of the old-style built-in methods as C procedures. */ for (i=0; i < BiMethodListLen; i++) { if (Itcl_RegisterObjC(interp, BiMethodList[i].registration+1, BiMethodList[i].proc, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { return TCL_ERROR; } } /* * Create the "itcl::old-parser" namespace for backward * compatibility, to handle the old-style class definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::old-parser", (ClientData)info, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (cannot initialize itcl old-style parser)", (char*)NULL); return TCL_ERROR; } Itcl_PreserveData((ClientData)info); /* * Add commands for parsing old-style class definitions. */ Tcl_CreateObjCommand(interp, "::itcl::old-parser::inherit", Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::constructor", Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::destructor", Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::method", ItclOldMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::proc", Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::public", ItclOldPublicCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::protected", ItclOldProtectedCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-parser::common", ItclOldCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); /* * Set the runtime variable resolver for the parser namespace, * to control access to "common" data members while parsing * the class definition. */ Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL, Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); /* * Create the "itcl::old-builtin" namespace for backward * compatibility with the old-style built-in commands. */ Tcl_CreateObjCommand(interp, "::itcl::old-builtin::virtual", ItclOldBiVirtualCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::old-builtin::previous", ItclOldBiPreviousCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); if (Itcl_CreateEnsemble(interp, "::itcl::old-builtin::info") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "class", "", Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "inherit", "", Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "heritage", "", Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "method", "?methodName? ?-args? ?-body?", ItclOldBiInfoMethodsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "proc", "?procName? ?-args? ?-body?", ItclOldBiInfoProcsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "public", "?varName? ?-init? ?-value? ?-config?", ItclOldBiInfoPublicsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "protected", "?varName? ?-init? ?-value?", ItclOldBiInfoProtectedsCmd, (ClientData)NULL,(Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "common", "?varName? ?-init? ?-value?", ItclOldBiInfoCommonsCmd, (ClientData)NULL,(Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "args", "procname", Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "body", "procname", Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ) { return TCL_ERROR; } /* * Plug in an "@error" handler to handle other options from * the usual info command. */ if (Itcl_AddEnsemblePart(interp, "::itcl::old-builtin::info", "@error", (char*)NULL, Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ) { return TCL_ERROR; } oldBiNs = Tcl_FindNamespace(interp, "::itcl::old-builtin", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (!oldBiNs || Tcl_Export(interp, oldBiNs, "*", /* resetListFirst */ 1) != TCL_OK) { return TCL_ERROR; } /* * Install the "itcl_class" and "itcl_info" commands into * the global scope. This supports the old syntax for * backward compatibility. */ Tcl_CreateObjCommand(interp, "::itcl_class", ItclOldClassCmd, (ClientData)info, Itcl_ReleaseData); Itcl_PreserveData((ClientData)info); if (Itcl_CreateEnsemble(interp, "::itcl_info") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl_info", "classes", "?pattern?", Itcl_FindClassesCmd, (ClientData)info, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData((ClientData)info); if (Itcl_AddEnsemblePart(interp, "::itcl_info", "objects", "?-class className? ?-isa className? ?pattern?", Itcl_FindObjectsCmd, (ClientData)info, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData((ClientData)info); return TCL_OK;} /* * ------------------------------------------------------------------------ * Itcl_InstallOldBiMethods() * * Invoked when a class is first created, just after the class * definition has been parsed, to add definitions for built-in * methods to the class. If a method already exists in the class * with the same name as the built-in, then the built-in is skipped. * Otherwise, a method definition for the built-in method is added. * * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter) if anything goes wrong. * ------------------------------------------------------------------------ */intItcl_InstallOldBiMethods(interp, cdefn) Tcl_Interp *interp; /* current interpreter */ ItclClass *cdefn; /* class definition to be updated */{ int result = TCL_OK; int i; ItclHierIter hier; ItclClass *cdPtr; Tcl_HashEntry *entry; /* * Scan through all of the built-in methods and see if * that method already exists in the class. If not, add * it in. * * TRICKY NOTE: The virtual tables haven't been built yet, * so look for existing methods the hard way--by scanning * through all classes. */ for (i=0; i < BiMethodListLen; i++) { Itcl_InitHierIter(&hier, cdefn); cdPtr = Itcl_AdvanceHierIter(&hier); entry = NULL; while (cdPtr) { entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name); if (entry) { break; } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); if (!entry) { result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name, BiMethodList[i].usage, BiMethodList[i].registration); if (result != TCL_OK) { break; } } } return result;} /* * ------------------------------------------------------------------------ * ItclOldClassCmd() * * Invoked by Tcl whenever the user issues a "itcl_class" command to * specify a class definition. Handles the following syntax: * * itcl_class <className> { * inherit <base-class>... * * constructor {<arglist>} { <body> } * destructor { <body> } * * method <name> {<arglist>} { <body> } * proc <name> {<arglist>} { <body> } * * public <varname> ?<init>? ?<config>? * protected <varname> ?<init>? * common <varname> ?<init>?⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -