Subversion Repositories or1k

itk_archetype.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itk.h =================================================================== --- itk.h (nonexistent) +++ itk.h (revision 1765) @@ -0,0 +1,157 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tk] + * DESCRIPTION: Building mega-widgets with [incr Tcl] + * + * [incr Tk] provides a framework for building composite "mega-widgets" + * using [incr Tcl] classes. It defines a set of base classes that are + * specialized to create all other widgets. + * + * ADDING [incr Tk] TO A Tcl-BASED APPLICATION: + * + * To add [incr Tk] facilities to a Tcl application, modify the + * Tcl_AppInit() routine as follows: + * + * 1) Include the header files for [incr Tcl] and [incr Tk] near + * the top of the file containing Tcl_AppInit(): + * + * #include "itcl.h" + * #include "itk.h" + * + * 2) Within the body of Tcl_AppInit(), add the following lines: + * + * if (Itcl_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * if (Itk_Init(interp) == TCL_ERROR) { + * return TCL_ERROR; + * } + * + * 3) Link your application with libitcl.a and libitk.a + * + * NOTE: An example file "tkAppInit.c" containing the changes shown + * above is included in this distribution. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itk.h,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ + * ======================================================================== + * 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. + */ +#ifndef ITK_H +#define ITK_H + +/* + * A special definition used to allow this header file to be included + * in resource files so that they can get obtain version information from + * this file. Resource compilers don't like all the C stuff, like typedefs + * and procedure declarations, that occur below. + */ + +#ifndef RESOURCE_INCLUDED + +#include "itclInt.h" +#include "tk.h" + +#ifdef BUILD_itk +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLEXPORT +#endif + +/* + * List of options in alphabetical order: + */ +typedef struct ItkOptList { + Tcl_HashTable *options; /* list containing the real options */ + Tcl_HashEntry **list; /* gives ordering of options */ + int len; /* number of entries in order list */ + int max; /* maximum size of order list */ +} ItkOptList; + +/* + * List of options created in the class definition: + */ +typedef struct ItkClassOptTable { + Tcl_HashTable options; /* option storage with fast lookup */ + ItkOptList order; /* gives ordering of options */ +} ItkClassOptTable; + +/* + * Each option created in the class definition: + */ +typedef struct ItkClassOption { + ItclMember *member; /* info about this option */ + char *resName; /* resource name in X11 database */ + char *resClass; /* resource class name in X11 database */ + char *init; /* initial value for option */ +} ItkClassOption; + + +/* + * Exported functions: + */ +EXTERN int Itk_Init _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int Itk_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + * Functions used internally by this package: + */ +EXTERN int Itk_ConfigBodyCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itk_UsualCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +/* + * Functions for managing options included in class definitions: + */ +EXTERN int Itk_ClassOptionDefineCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +EXTERN int Itk_ClassOptionIllegalCmd _ANSI_ARGS_((ClientData cdata, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +EXTERN int Itk_ConfigClassOption _ANSI_ARGS_((Tcl_Interp *interp, + ItclObject *contextObj, ClientData cdata, char* newVal)); + +EXTERN ItkClassOptTable* Itk_CreateClassOptTable _ANSI_ARGS_(( + Tcl_Interp *interp, ItclClass *cdefn)); +EXTERN ItkClassOptTable* Itk_FindClassOptTable _ANSI_ARGS_(( + ItclClass *cdefn)); +EXTERN void Itk_DeleteClassOptTable _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass *cdefn)); + +EXTERN int Itk_CreateClassOption _ANSI_ARGS_((Tcl_Interp *interp, + ItclClass *cdefn, char *switchName, char *resName, char *resClass, + char *defVal, char *config, ItkClassOption **optPtr)); +EXTERN ItkClassOption* Itk_FindClassOption _ANSI_ARGS_(( + ItclClass *cdefn, char *switchName)); +EXTERN void Itk_DelClassOption _ANSI_ARGS_((ItkClassOption *opt)); + +/* + * Functions needed for the Archetype base class: + */ +EXTERN int Itk_ArchetypeInit _ANSI_ARGS_((Tcl_Interp* interp)); + +/* + * Functions for maintaining the ordered option list: + */ +EXTERN void Itk_OptListInit _ANSI_ARGS_((ItkOptList* olist, + Tcl_HashTable *options)); +EXTERN void Itk_OptListFree _ANSI_ARGS_((ItkOptList* olist)); + +EXTERN void Itk_OptListAdd _ANSI_ARGS_((ItkOptList* olist, + Tcl_HashEntry *entry)); +EXTERN void Itk_OptListRemove _ANSI_ARGS_((ItkOptList* olist, + Tcl_HashEntry *entry)); + +# undef TCL_STORAGE_CLASS +# define TCL_STORAGE_CLASS DLLIMPORT + +#endif /* RESOURCE INCLUDED */ +#endif /* ITK_H */

itk.h Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: itk_cmds.c =================================================================== --- itk_cmds.c (nonexistent) +++ itk_cmds.c (revision 1765) @@ -0,0 +1,316 @@ +/* + * ------------------------------------------------------------------------ + * PACKAGE: [incr Tk] + * DESCRIPTION: Building mega-widgets with [incr Tcl] + * + * [incr Tk] provides a framework for building composite "mega-widgets" + * using [incr Tcl] classes. It defines a set of base classes that are + * specialized to create all other widgets. + * + * This file defines the initialization and facilities common to all + * mega-widgets. + * + * ======================================================================== + * AUTHOR: Michael J. McLennan + * Bell Labs Innovations for Lucent Technologies + * mmclennan@lucent.com + * http://www.tcltk.com/itcl + * + * RCS: $Id: itk_cmds.c,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $ + * ======================================================================== + * 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 "itk.h" + +/* + * FORWARD DECLARATIONS + */ +static int Initialize _ANSI_ARGS_((Tcl_Interp *interp)); + +/* + * The following string is the startup script executed in new + * interpreters. It looks on disk in several different directories + * for a script "init.tcl" that is compatible with this version + * of Tcl. The init.tcl script does all of the real work of + * initialization. + */ + +static char initScript[] = "\n\ +namespace eval ::itk {\n\ + proc _find_init {} {\n\ + global env tcl_library\n\ + variable library\n\ + variable version\n\ + rename _find_init {}\n\ + tcl_findLibrary itk 3.0 {} itk.tcl ITK_LIBRARY ::itk::library {} {} itcl\n\ + }\n\ + _find_init\n\ +}"; + + +/* + * ------------------------------------------------------------------------ + * Initialize() + * + * Invoked whenever a new interpeter is created to install the + * [incr Tk] package. + * + * Creates the "::itk" namespace and installs access commands. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +static int +Initialize(interp) + Tcl_Interp *interp; /* interpreter to be updated */ +{ + Tcl_Namespace *itkNs, *parserNs; + ClientData parserInfo; + + if (Tcl_PkgRequire(interp, "Tk", TK_VERSION, 0) == NULL) { + return TCL_ERROR; + } + if (Tcl_PkgRequire(interp, "Itcl", ITCL_VERSION, 0) == NULL) { + return TCL_ERROR; + } + + /* + * Install [incr Tk] facilities if not already installed. + */ + itkNs = Tcl_FindNamespace(interp, "::itk", (Tcl_Namespace*)NULL, + /* flags */ 0); + + if (itkNs) { + Tcl_SetResult(interp, "already installed: [incr Tk]", TCL_STATIC); + return TCL_ERROR; + } + + /* + * Add the "itk_option" ensemble to the itcl class definition parser. + */ + parserNs = Tcl_FindNamespace(interp, "::itcl::parser", + (Tcl_Namespace*)NULL, /* flags */ 0); + + if (!parserNs) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "cannot initialize [incr Tk]: [incr Tcl] has not been installed\n", + "Make sure that Itcl_Init() is called before Itk_Init()", + (char*)NULL); + return TCL_ERROR; + } + parserInfo = parserNs->clientData; + + if (Itcl_CreateEnsemble(interp, "::itcl::parser::itk_option") != TCL_OK) { + return TCL_ERROR; + } + if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option", + "define", "-switch resourceName resourceClass init ?config?", + Itk_ClassOptionDefineCmd, + parserInfo, Itcl_ReleaseData) != TCL_OK) { + + return TCL_ERROR; + } + Itcl_PreserveData(parserInfo); + + if (Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option", + "add", "name ?name name...?", + Itk_ClassOptionIllegalCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || + + Itcl_AddEnsemblePart(interp, "::itcl::parser::itk_option", + "remove", "name ?name name...?", + Itk_ClassOptionIllegalCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { + + return TCL_ERROR; + } + + /* + * Create the "itk" namespace. Export all the commands in + * the namespace so that they can be imported by a command + * such as "namespace import itk::*" + */ + itkNs = Tcl_CreateNamespace(interp, "::itk", + (ClientData)NULL, (Tcl_NamespaceDeleteProc*)NULL); + + if (!itkNs || + Tcl_Export(interp, itkNs, "*", /* resetListFirst */ 1) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Setup things for itk::Archetype base class. + */ + if (Itk_ArchetypeInit(interp) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Fix the "itcl::configbody" command to recognize mega-widget + * options. + */ + Tcl_CreateObjCommand(interp, "::itcl::configbody", Itk_ConfigBodyCmd, + (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); + + Tcl_SetVar(interp, "::itk::version", ITCL_VERSION, 0); + Tcl_SetVar(interp, "::itk::patchLevel", ITCL_PATCH_LEVEL, 0); + + /* + * Signal that the package has been loaded. + */ + if (Tcl_PkgProvide(interp, "Itk", ITCL_VERSION) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ------------------------------------------------------------------------ + * Itk_Init() + * + * Invoked whenever a new interpeter is created to install the + * [incr Tcl] package. Usually invoked within Tcl_AppInit() at + * the start of execution. + * + * Creates the "::itk" namespace and installs access commands. + * + * Returns TCL_OK on success, or TCL_ERROR (along with an error + * message in the interpreter) if anything goes wrong. + * ------------------------------------------------------------------------ + */ +int +Itk_Init(interp) + Tcl_Interp *interp; /* interpreter to be updated */ +{ + if (Initialize(interp) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_Eval(interp, initScript); + return TCL_OK; +} + + +/* + * ------------------------------------------------------------------------ + * Itk_ConfigBodyCmd() + * + * Replacement for the usual "itcl::configbody" command. Recognizes + * mega-widget options included in a class definition. Options are + * identified by their "switch" name, but without the "-" prefix: + * + * itcl::configbody :: + * + * Handles bodies for public variables as well: + * + * itcl::configbody :: + * + * If an is found, it has priority over public variables. + * If 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 */ +int +Itk_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 result = TCL_OK; + + char *token, *head, *tail; + ItclClass *cdefn; + ItclMemberCode *mcode; + ItkClassOptTable *optTable; + Tcl_HashEntry *entry; + ItkClassOption *opt; + Tcl_DString buffer; + + 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); + result = TCL_ERROR; + goto configBodyCmdDone; + } + + cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); + if (cdefn == NULL) { + result = TCL_ERROR; + goto configBodyCmdDone; + } + + /* + * Look first for a configuration option with that name. + * If it is not found, assume the reference is for a public + * variable, and use the usual "configbody" implementation + * to handle it. + */ + optTable = Itk_FindClassOptTable(cdefn); + opt = NULL; + + if (optTable) { + Tcl_DString optName; + + Tcl_DStringInit(&optName); + Tcl_DStringAppend(&optName, "-", -1); + Tcl_DStringAppend(&optName, tail, -1); + entry = Tcl_FindHashEntry(&optTable->options, + Tcl_DStringValue(&optName)); + + if (entry) { + opt = (ItkClassOption*)Tcl_GetHashValue(entry); + } + Tcl_DStringFree(&optName); + } + + if (opt == NULL) { + result = Itcl_ConfigBodyCmd(dummy, interp, objc, objv); + goto configBodyCmdDone; + } + + /* + * Otherwise, change the implementation for this option. + */ + token = Tcl_GetStringFromObj(objv[2], (int*)NULL); + + if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token, + &mcode) != TCL_OK) { + + result = TCL_ERROR; + goto configBodyCmdDone; + } + + Itcl_PreserveData((ClientData)mcode); + Itcl_EventuallyFree((ClientData)mcode, Itcl_DeleteMemberCode); + + if (opt->member->code) { + Itcl_ReleaseData((ClientData)opt->member->code); + } + opt->member->code = mcode; + +configBodyCmdDone: + Tcl_DStringFree(&buffer); + return result; +}

itk_cmds.c Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property