📄 itcl_methods.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. * * These procedures handle commands available within a class scope. * In [incr Tcl], the term "method" is used for a procedure that has * access to object-specific data, while the term "proc" is used for * a procedure that has access only to common class data. * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * RCS: $Id: itcl_methods.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"#include "tclCompile.h"/* * FORWARD DECLARATIONS */static int ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj, int *rargc, ItclVarDefn ***rvars, char ***rvals));static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp, int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj)); /* * ------------------------------------------------------------------------ * Itcl_BodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::body" command to * define or redefine the implementation for a class method/proc. * Handles the following syntax: * * itcl::body <class>::<func> <arglist> <body> * * Looks for an existing class member function with the name <func>, * and if found, tries to assign the implementation. If an argument * list was specified in the original declaration, it must match * <arglist> or an error is flagged. If <body> has the form "@name" * then it is treated as a reference to a C handling procedure; * otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ *//* ARGSUSED */intItcl_BodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */{ int status = TCL_OK; char *head, *tail, *token, *arglist, *body; ItclClass *cdefn; ItclMemberFunc *mfunc; Tcl_HashEntry *entry; Tcl_DString buffer; if (objc != 4) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", token, " class::func arglist body\"", (char*)NULL); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::func". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto bodyCmdDone; } /* * Find the function and try to change its implementation. * Note that command resolution table contains *all* functions, * even those in a base class. Make sure that the class * containing the method definition is the requested class. */ if (objc != 4) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "wrong # args: should be \"", token, " class::func arglist body\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } mfunc = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); if (mfunc->member->classDefn != cdefn) { mfunc = NULL; } } if (mfunc == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "function \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); body = Tcl_GetStringFromObj(objv[3], (int*)NULL); if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) { status = TCL_ERROR; goto bodyCmdDone; }bodyCmdDone: Tcl_DStringFree(&buffer); return status;} /* * ------------------------------------------------------------------------ * Itcl_ConfigBodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::configbody" command * to define or redefine the configuration code associated with a * public variable. Handles the following syntax: * * itcl::configbody <class>::<publicVar> <body> * * Looks for an existing public variable with the name <publicVar>, * and if found, tries to assign the implementation. If <body> has * the form "@name" then it is treated as a reference to a C handling * procedure; otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ *//* ARGSUSED */intItcl_ConfigBodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */{ int status = TCL_OK; char *head, *tail, *token; Tcl_DString buffer; ItclClass *cdefn; ItclVarLookup *vlookup; ItclMember *member; ItclMemberCode *mcode; Tcl_HashEntry *entry; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "class::option body"); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::option". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto configBodyCmdDone; } /* * Find the variable and change its implementation. * Note that variable resolution table has *all* variables, * even those in a base class. Make sure that the class * containing the variable definition is the requested class. */ vlookup = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->vdefn->member->classDefn != cdefn) { vlookup = NULL; } } if (vlookup == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "option \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } member = vlookup->vdefn->member; if (member->protection != ITCL_PUBLIC) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "option \"", member->fullname, "\" is not a public configuration option", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } token = Tcl_GetStringFromObj(objv[2], (int*)NULL); if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token, &mcode) != TCL_OK) { status = TCL_ERROR; goto configBodyCmdDone; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); if (member->code) { Itcl_ReleaseData((ClientData)member->code); } member->code = mcode;configBodyCmdDone: Tcl_DStringFree(&buffer); return status;} /* * ------------------------------------------------------------------------ * Itcl_CreateMethod() * * Installs a method into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. * * Returns TCL_OK on success, or TCL_ERROR (along with an error message * in the specified interp) if anything goes wrong. * ------------------------------------------------------------------------ */intItcl_CreateMethod(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ char* name; /* name of new method */ char* arglist; /* space-separated list of arg names */ char* body; /* body of commands for the method */{ ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the method name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad method name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the method definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Build a fully-qualified name for the method, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); Itcl_PreserveData((ClientData)mfunc); mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecMethod, (ClientData)mfunc, Itcl_ReleaseData); Tcl_DStringFree(&buffer); return TCL_OK;} /* * ------------------------------------------------------------------------ * Itcl_CreateProc() * * Installs a class proc into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along * with an error message in the specified interp) if anything goes * wrong. * ------------------------------------------------------------------------ */intItcl_CreateProc(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ char* name; /* name of new proc */ char* arglist; /* space-separated list of arg names */ char* body; /* body of commands for the proc */{ ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the proc name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad proc name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the proc definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Mark procs as "common". This distinguishes them from methods. */ mfunc->member->flags |= ITCL_COMMON; /* * Build a fully-qualified name for the proc, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2);⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -