ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Import Tcl 8.6.12

Browse Source
This commit is contained in:
Steve Dower
2021-11-08 17:30:58 +00:00
parent 1aadb2455c
commit 674867e7e6
608 changed files with 78089 additions and 60360 deletions
Download Patch File Download Diff File Expand all files Collapse all files

627
pkgs/itcl4.2.2/generic/itcl.decls Normal file
View File

@@ -0,0 +1,627 @@
# -*- tcl -*-
# public API
library itcl
interface itcl
hooks {itclInt}
epoch 0
scspec ITCLAPI
# Declare each of the functions in the public Tcl interface. Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.
declare 2 {
int Itcl_RegisterC(Tcl_Interp *interp, const char *name,
Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 3 {
int Itcl_RegisterObjC(Tcl_Interp *interp, const char *name,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 4 {
int Itcl_FindC(Tcl_Interp *interp, const char *name,
Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr,
ClientData *cDataPtr)
}
declare 5 {
void Itcl_InitStack(Itcl_Stack *stack)
}
declare 6 {
void Itcl_DeleteStack(Itcl_Stack *stack)
}
declare 7 {
void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack)
}
declare 8 {
ClientData Itcl_PopStack(Itcl_Stack *stack)
}
declare 9 {
ClientData Itcl_PeekStack(Itcl_Stack *stack)
}
declare 10 {
ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos)
}
declare 11 {
void Itcl_InitList(Itcl_List *listPtr)
}
declare 12 {
void Itcl_DeleteList(Itcl_List *listPtr)
}
declare 13 {
Itcl_ListElem *Itcl_CreateListElem(Itcl_List *listPtr)
}
declare 14 {
Itcl_ListElem *Itcl_DeleteListElem(Itcl_ListElem *elemPtr)
}
declare 15 {
Itcl_ListElem *Itcl_InsertList(Itcl_List *listPtr, ClientData val)
}
declare 16 {
Itcl_ListElem *Itcl_InsertListElem(Itcl_ListElem *pos, ClientData val)
}
declare 17 {
Itcl_ListElem *Itcl_AppendList(Itcl_List *listPtr, ClientData val)
}
declare 18 {
Itcl_ListElem *Itcl_AppendListElem(Itcl_ListElem *pos, ClientData val)
}
declare 19 {
void Itcl_SetListValue(Itcl_ListElem *elemPtr, ClientData val)
}
declare 20 {
void Itcl_EventuallyFree(ClientData cdata, Tcl_FreeProc *fproc)
}
declare 21 {
void Itcl_PreserveData(ClientData cdata)
}
declare 22 {
void Itcl_ReleaseData(ClientData cdata)
}
declare 23 {
Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp *interp, int status)
}
declare 24 {
int Itcl_RestoreInterpState(Tcl_Interp *interp, Itcl_InterpState state)
}
declare 25 {
void Itcl_DiscardInterpState(Itcl_InterpState state)
}
declare 26 {
void * Itcl_Alloc(size_t size)
}
declare 27 {
void Itcl_Free(void *ptr)
}
# private API
interface itclInt
#
# Functions used within the package, but not considered "public"
#
declare 0 {
int Itcl_IsClassNamespace(Tcl_Namespace *namesp)
}
declare 1 {
int Itcl_IsClass(Tcl_Command cmd)
}
declare 2 {
ItclClass *Itcl_FindClass(Tcl_Interp *interp, const char *path, int autoload)
}
declare 3 {
int Itcl_FindObject(Tcl_Interp *interp, const char *name, ItclObject **roPtr)
}
declare 4 {
int Itcl_IsObject(Tcl_Command cmd)
}
declare 5 {
int Itcl_ObjectIsa(ItclObject *contextObj, ItclClass *cdefn)
}
declare 6 {
int Itcl_Protection(Tcl_Interp *interp, int newLevel)
}
declare 7 {
const char *Itcl_ProtectionStr(int pLevel)
}
declare 8 {
int Itcl_CanAccess(ItclMemberFunc *memberPtr, Tcl_Namespace *fromNsPtr)
}
declare 9 {
int Itcl_CanAccessFunc(ItclMemberFunc *mfunc, Tcl_Namespace *fromNsPtr)
}
declare 11 {
void Itcl_ParseNamespPath(const char *name, Tcl_DString *buffer,
const char **head, const char **tail)
}
declare 12 {
int Itcl_DecodeScopedCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace **rNsPtr, char **rCmdPtr)
}
declare 13 {
int Itcl_EvalArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
}
declare 14 {
Tcl_Obj *Itcl_CreateArgs(Tcl_Interp *interp, const char *string,
int objc, Tcl_Obj *const objv[])
}
declare 17 {
int Itcl_GetContext(Tcl_Interp *interp, ItclClass **iclsPtrPtr,
ItclObject **ioPtrPtr)
}
declare 18 {
void Itcl_InitHierIter(ItclHierIter *iter, ItclClass *iclsPtr)
}
declare 19 {
void Itcl_DeleteHierIter(ItclHierIter *iter)
}
declare 20 {
ItclClass *Itcl_AdvanceHierIter(ItclHierIter *iter)
}
declare 21 {
int Itcl_FindClassesCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 22 {
int Itcl_FindObjectsCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 24 {
int Itcl_DelClassCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 25 {
int Itcl_DelObjectCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 26 {
int Itcl_ScopeCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 27 {
int Itcl_CodeCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 28 {
int Itcl_StubCreateCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 29 {
int Itcl_StubExistsCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 30 {
int Itcl_IsStub(Tcl_Command cmd)
}
#
# Functions for manipulating classes
#
declare 31 {
int Itcl_CreateClass(Tcl_Interp *interp, const char *path,
ItclObjectInfo *info, ItclClass **rPtr)
}
declare 32 {
int Itcl_DeleteClass(Tcl_Interp *interp, ItclClass *iclsPtr)
}
declare 33 {
Tcl_Namespace *Itcl_FindClassNamespace(Tcl_Interp *interp, const char *path)
}
declare 34 {
int Itcl_HandleClass(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 38 {
void Itcl_BuildVirtualTables(ItclClass *iclsPtr)
}
declare 39 {
int Itcl_CreateVariable(Tcl_Interp *interp, ItclClass *iclsPtr,
Tcl_Obj *name, char *init, char *config, ItclVariable **ivPtr)
}
declare 40 {
void Itcl_DeleteVariable(char *cdata)
}
declare 41 {
const char *Itcl_GetCommonVar(Tcl_Interp *interp, const char *name,
ItclClass *contextClass)
}
#
# Functions for manipulating objects
#
declare 44 {
int Itcl_CreateObject(Tcl_Interp *interp, const char* name, ItclClass *iclsPtr,
int objc, Tcl_Obj *const objv[], ItclObject **rioPtr)
}
declare 45 {
int Itcl_DeleteObject(Tcl_Interp *interp, ItclObject *contextObj)
}
declare 46 {
int Itcl_DestructObject(Tcl_Interp *interp, ItclObject *contextObj,
int flags)
}
declare 48 {
const char *Itcl_GetInstanceVar(Tcl_Interp *interp, const char *name,
ItclObject *contextIoPtr, ItclClass *contextIclsPtr)
}
#
# Functions for manipulating methods and procs
#
declare 50 {
int Itcl_BodyCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 51 {
int Itcl_ConfigBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 52 {
int Itcl_CreateMethod(Tcl_Interp *interp, ItclClass *iclsPtr,
Tcl_Obj *namePtr, const char *arglist, const char *body)
}
declare 53 {
int Itcl_CreateProc(Tcl_Interp *interp, ItclClass *iclsPtr,
Tcl_Obj *namePtr, const char *arglist, const char *body)
}
declare 54 {
int Itcl_CreateMemberFunc(Tcl_Interp *interp, ItclClass *iclsPtr,
Tcl_Obj *name, const char *arglist, const char *body,
ItclMemberFunc **mfuncPtr)
}
declare 55 {
int Itcl_ChangeMemberFunc(Tcl_Interp *interp, ItclMemberFunc *mfunc,
const char *arglist, const char *body)
}
declare 56 {
void Itcl_DeleteMemberFunc(void *cdata)
}
declare 57 {
int Itcl_CreateMemberCode(Tcl_Interp *interp, ItclClass *iclsPtr, \
const char *arglist, const char *body, ItclMemberCode **mcodePtr)
}
declare 58 {
void Itcl_DeleteMemberCode(void *cdata)
}
declare 59 {
int Itcl_GetMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc)
}
declare 61 {
int Itcl_EvalMemberCode(Tcl_Interp *interp, ItclMemberFunc *mfunc,
ItclObject *contextObj, int objc, Tcl_Obj *const objv[])
}
declare 67 {
void Itcl_GetMemberFuncUsage(ItclMemberFunc *mfunc,
ItclObject *contextObj, Tcl_Obj *objPtr)
}
declare 68 {
int Itcl_ExecMethod(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 69 {
int Itcl_ExecProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 71 {
int Itcl_ConstructBase(Tcl_Interp *interp, ItclObject *contextObj,
ItclClass *contextClass)
}
declare 72 {
int Itcl_InvokeMethodIfExists(Tcl_Interp *interp, const char *name,
ItclClass *contextClass, ItclObject *contextObj, int objc,
Tcl_Obj *const objv[])
}
declare 74 {
int Itcl_ReportFuncErrors(Tcl_Interp *interp, ItclMemberFunc *mfunc,
ItclObject *contextObj, int result)
}
#
# Commands for parsing class definitions
#
declare 75 {
int Itcl_ParseInit(Tcl_Interp *interp, ItclObjectInfo *info)
}
declare 76 {
int Itcl_ClassCmd(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 77 {
int Itcl_ClassInheritCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 78 {
int Itcl_ClassProtectionCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 79 {
int Itcl_ClassConstructorCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 80 {
int Itcl_ClassDestructorCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 81 {
int Itcl_ClassMethodCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 82 {
int Itcl_ClassProcCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 83 {
int Itcl_ClassVariableCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 84 {
int Itcl_ClassCommonCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 85 {
int Itcl_ParseVarResolver(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNs, int flags, Tcl_Var *rPtr)
}
#
# Commands in the "builtin" namespace
#
declare 86 {
int Itcl_BiInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr)
}
declare 87 {
int Itcl_InstallBiMethods(Tcl_Interp *interp, ItclClass *cdefn)
}
declare 88 {
int Itcl_BiIsaCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 89 {
int Itcl_BiConfigureCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 90 {
int Itcl_BiCgetCmd(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 91 {
int Itcl_BiChainCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 92 {
int Itcl_BiInfoClassCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 93 {
int Itcl_BiInfoInheritCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 94 {
int Itcl_BiInfoHeritageCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 95 {
int Itcl_BiInfoFunctionCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 96 {
int Itcl_BiInfoVariableCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 97 {
int Itcl_BiInfoBodyCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 98 {
int Itcl_BiInfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
#declare 99 {
# int Itcl_DefaultInfoCmd(ClientData dummy, Tcl_Interp *interp, int objc,
# Tcl_Obj *const objv[])
#}
#
# Ensembles
#
declare 100 {
int Itcl_EnsembleInit(Tcl_Interp *interp)
}
declare 101 {
int Itcl_CreateEnsemble(Tcl_Interp *interp, const char *ensName)
}
declare 102 {
int Itcl_AddEnsemblePart(Tcl_Interp *interp, const char *ensName,
const char *partName, const char *usageInfo, Tcl_ObjCmdProc *objProc,
ClientData clientData, Tcl_CmdDeleteProc *deleteProc)
}
declare 103 {
int Itcl_GetEnsemblePart(Tcl_Interp *interp, const char *ensName,
const char *partName, Tcl_CmdInfo *infoPtr)
}
declare 104 {
int Itcl_IsEnsemble(Tcl_CmdInfo *infoPtr)
}
declare 105 {
int Itcl_GetEnsembleUsage(Tcl_Interp *interp, const char *ensName,
Tcl_Obj *objPtr)
}
declare 106 {
int Itcl_GetEnsembleUsageForObj(Tcl_Interp *interp, Tcl_Obj *ensObjPtr,
Tcl_Obj *objPtr)
}
declare 107 {
int Itcl_EnsembleCmd(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 108 {
int Itcl_EnsPartCmd(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 109 {
int Itcl_EnsembleErrorCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 115 {
void Itcl_Assert(const char *testExpr, const char *fileName, int lineNum)
}
declare 116 {
int Itcl_IsObjectCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 117 {
int Itcl_IsClassCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
#
# new commands to use TclOO functionality
#
declare 140 {
int Itcl_FilterAddCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 141 {
int Itcl_FilterDeleteCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 142 {
int Itcl_ForwardAddCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 143 {
int Itcl_ForwardDeleteCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 144 {
int Itcl_MixinAddCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 145 {
int Itcl_MixinDeleteCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
#
# Helper commands
#
#declare 150 {
# int Itcl_BiInfoCmd(ClientData clientData, Tcl_Interp *interp, int objc,
# Tcl_Obj *const objv[])
#}
declare 151 {
int Itcl_BiInfoUnknownCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 152 {
int Itcl_BiInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 153 {
int Itcl_CanAccess2(ItclClass *iclsPtr, int protection,
Tcl_Namespace *fromNsPtr)
}
declare 160 {
int Itcl_SetCallFrameResolver(Tcl_Interp *interp,
Tcl_Resolve *resolvePtr)
}
declare 161 {
int ItclEnsembleSubCmd(ClientData clientData, Tcl_Interp *interp,
const char *ensembleName, int objc, Tcl_Obj *const *objv,
const char *functionName)
}
declare 162 {
Tcl_Namespace *Itcl_GetUplevelNamespace(Tcl_Interp *interp, int level)
}
declare 163 {
ClientData Itcl_GetCallFrameClientData(Tcl_Interp *interp)
}
declare 165 {
int Itcl_SetCallFrameNamespace(Tcl_Interp *interp, Tcl_Namespace *nsPtr)
}
declare 166 {
int Itcl_GetCallFrameObjc(Tcl_Interp *interp)
}
declare 167 {
Tcl_Obj *const *Itcl_GetCallFrameObjv(Tcl_Interp *interp)
}
declare 168 {
int Itcl_NWidgetCmd(ClientData infoPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 169 {
int Itcl_AddOptionCmd(ClientData infoPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 170 {
int Itcl_AddComponentCmd(ClientData infoPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 171 {
int Itcl_BiInfoOptionCmd(ClientData dummy, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
}
declare 172 {
int Itcl_BiInfoComponentCmd(ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 173 {
int Itcl_RenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName)
}
declare 174 {
int Itcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 175 {
void Itcl_PopCallFrame(Tcl_Interp *interp)
}
declare 176 {
Tcl_CallFrame *Itcl_GetUplevelCallFrame(Tcl_Interp *interp,
int level)
}
declare 177 {
Tcl_CallFrame *Itcl_ActivateCallFrame(Tcl_Interp *interp,
Tcl_CallFrame *framePtr)
}
declare 178 {
const char* ItclSetInstanceVar(Tcl_Interp *interp,
const char *name, const char *name2, const char *value,
ItclObject *contextIoPtr, ItclClass *contextIclsPtr)
}
declare 179 {
Tcl_Obj * ItclCapitalize(const char *str)
}
declare 180 {
int ItclClassBaseCmd(ClientData clientData, Tcl_Interp *interp,
int flags, int objc, Tcl_Obj *const objv[], ItclClass **iclsPtrPtr)
}
declare 181 {
int ItclCreateComponent(Tcl_Interp *interp, ItclClass *iclsPtr,
Tcl_Obj *componentPtr, int type, ItclComponent **icPtrPtr)
}
declare 182 {
void Itcl_SetContext(Tcl_Interp *interp, ItclObject *ioPtr)
}
declare 183 {
void Itcl_UnsetContext(Tcl_Interp *interp)
}
declare 184 {
const char * ItclGetInstanceVar(Tcl_Interp *interp, const char *name,
const char *name2, ItclObject *ioPtr, ItclClass *iclsPtr)
}

194
pkgs/itcl4.2.2/generic/itcl.h Normal file
View File

@@ -0,0 +1,194 @@
/*
* itcl.h --
*
* This file contains definitions for the C-implemeted part of a Itcl
* this version of [incr Tcl] (Itcl) is a completely new implementation
* based on TclOO extension of Tcl 8.5
* It tries to provide the same interfaces as the original implementation
* of Michael J. McLennan
* Some small pieces of code are taken from that implementation
*
* Copyright (c) 2007 by Arnulf P. Wiedemann
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* ------------------------------------------------------------------------
* 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.
*
* ADDING [incr Tcl] TO A Tcl-BASED APPLICATION:
*
* To add [incr Tcl] facilities to a Tcl application, modify the
* Tcl_AppInit() routine as follows:
*
* 1) Include this header file near the top of the file containing
* Tcl_AppInit():
*
* #include "itcl.h"
*
* 2) Within the body of Tcl_AppInit(), add the following lines:
*
* if (Itcl_Init(interp) == TCL_ERROR) {
* return TCL_ERROR;
* }
*
* 3) Link your application with libitcl.a
*
* NOTE: An example file "tclAppInit.c" containing the changes shown
* above is included in this distribution.
*
*---------------------------------------------------------------------
*/
#ifndef ITCL_H_INCLUDED
#define ITCL_H_INCLUDED
#include <tcl.h>
#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
# error Itcl 4 build requires tcl.h from Tcl 8.6 or later
#endif
/*
* For C++ compilers, use extern "C"
*/
#ifdef __cplusplus
extern "C" {
#endif
#ifndef TCL_ALPHA_RELEASE
# define TCL_ALPHA_RELEASE 0
#endif
#ifndef TCL_BETA_RELEASE
# define TCL_BETA_RELEASE 1
#endif
#ifndef TCL_FINAL_RELEASE
# define TCL_FINAL_RELEASE 2
#endif
#define ITCL_MAJOR_VERSION 4
#define ITCL_MINOR_VERSION 2
#define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE
#define ITCL_RELEASE_SERIAL 2
#define ITCL_VERSION "4.2"
#define ITCL_PATCH_LEVEL "4.2.2"
/*
* A special definition used to allow this header file to be included from
* windows resource files so that they can obtain version information.
* RC_INVOKED is defined by default by the windows RC tool.
*
* Resource compilers don't like all the C stuff, like typedefs and function
* declarations, that occur below, so block them out.
*/
#ifndef RC_INVOKED
#define ITCL_NAMESPACE "::itcl"
#ifndef ITCLAPI
# if defined(BUILD_itcl)
# define ITCLAPI MODULE_SCOPE
# else
# define ITCLAPI extern
# undef USE_ITCL_STUBS
# define USE_ITCL_STUBS 1
# endif
#endif
#if defined(BUILD_itcl) && !defined(STATIC_BUILD)
# define ITCL_EXTERN extern DLLEXPORT
#else
# define ITCL_EXTERN extern
#endif
ITCL_EXTERN int Itcl_Init(Tcl_Interp *interp);
ITCL_EXTERN int Itcl_SafeInit(Tcl_Interp *interp);
/*
* Protection levels:
*
* ITCL_PUBLIC - accessible from any namespace
* ITCL_PROTECTED - accessible from namespace that imports in "protected" mode
* ITCL_PRIVATE - accessible only within the namespace that contains it
*/
#define ITCL_PUBLIC 1
#define ITCL_PROTECTED 2
#define ITCL_PRIVATE 3
#define ITCL_DEFAULT_PROTECT 4
/*
* Generic stack.
*/
typedef struct Itcl_Stack {
ClientData *values; /* values on stack */
int len; /* number of values on stack */
int max; /* maximum size of stack */
ClientData space[5]; /* initial space for stack data */
} Itcl_Stack;
#define Itcl_GetStackSize(stackPtr) ((stackPtr)->len)
/*
* Generic linked list.
*/
struct Itcl_List;
typedef struct Itcl_ListElem {
struct Itcl_List* owner; /* list containing this element */
ClientData value; /* value associated with this element */
struct Itcl_ListElem *prev; /* previous element in linked list */
struct Itcl_ListElem *next; /* next element in linked list */
} Itcl_ListElem;
typedef struct Itcl_List {
int validate; /* validation stamp */
int num; /* number of elements */
struct Itcl_ListElem *head; /* previous element in linked list */
struct Itcl_ListElem *tail; /* next element in linked list */
} Itcl_List;
#define Itcl_FirstListElem(listPtr) ((listPtr)->head)
#define Itcl_LastListElem(listPtr) ((listPtr)->tail)
#define Itcl_NextListElem(elemPtr) ((elemPtr)->next)
#define Itcl_PrevListElem(elemPtr) ((elemPtr)->prev)
#define Itcl_GetListLength(listPtr) ((listPtr)->num)
#define Itcl_GetListValue(elemPtr) ((elemPtr)->value)
/*
* Token representing the state of an interpreter.
*/
typedef struct Itcl_InterpState_ *Itcl_InterpState;
/*
* Include all the public API, generated from itcl.decls.
*/
#include "itclDecls.h"
#endif /* RC_INVOKED */
/*
* end block for C++
*/
#ifdef __cplusplus
}
#endif
#endif /* ITCL_H_INCLUDED */

400
pkgs/itcl4.2.2/generic/itcl2TclOO.c Normal file
View File

@@ -0,0 +1,400 @@
/*
* itcl2TclOO.c --
*
* This file contains code to create and manage methods.
*
* Copyright (c) 2007 by Arnulf P. Wiedemann
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <tclInt.h>
#include <tclOOInt.h>
#undef FOREACH_HASH_DECLS
#undef FOREACH_HASH
#undef FOREACH_HASH_VALUE
#include "itclInt.h"
void *
Itcl_GetCurrentCallbackPtr(
Tcl_Interp *interp)
{
return TOP_CB(interp);
}
int
Itcl_NRRunCallbacks(
Tcl_Interp *interp,
void *rootPtr)
{
return TclNRRunCallbacks(interp, TCL_OK, (NRE_callback*)rootPtr);
}
static int
CallFinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *nsPtr = (Tcl_Namespace *)data[0];
TclOO_PostCallProc *postCallProc = (TclOO_PostCallProc *)data[1];
void *clientData = data[2];
/*
* Give the post-call callback a chance to do some cleanup. Note that at
* this point the call frame itself is invalid; it's already been popped.
*/
return postCallProc(clientData, interp, NULL, nsPtr, result);
}
static int
FreeCommand(
void *data[],
Tcl_Interp *dummy,
int result)
{
Command *cmdPtr = (Command *)data[0];
Proc *procPtr = (Proc *)data[1];
(void)dummy;
ckfree(cmdPtr);
procPtr->cmdPtr = NULL;
return result;
}
static int
Tcl_InvokeClassProcedureMethod(
Tcl_Interp *interp,
Tcl_Obj *namePtr, /* name of the method */
Tcl_Namespace *nsPtr, /* namespace for calling method */
ProcedureMethod *pmPtr, /* method type specific data */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
Proc *procPtr = pmPtr->procPtr;
CallFrame *framePtr = NULL;
CallFrame **framePtrPtr1 = &framePtr;
Tcl_CallFrame **framePtrPtr = (Tcl_CallFrame **)framePtrPtr1;
int result;
if (procPtr->cmdPtr == NULL) {
Command *cmdPtr = (Command *)ckalloc(sizeof(Command));
memset(cmdPtr, 0, sizeof(Command));
cmdPtr->nsPtr = (Namespace *) nsPtr;
cmdPtr->clientData = NULL;
procPtr->cmdPtr = cmdPtr;
Tcl_NRAddCallback(interp, FreeCommand, cmdPtr, procPtr, NULL, NULL);
}
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr,
(Namespace *) nsPtr, "body of method", Tcl_GetString(namePtr));
if (result != TCL_OK) {
return result;
}
/*
* Make the stack frame and fill it out with information about this call.
* This operation may fail.
*/
result = TclPushStackFrame(interp, framePtrPtr, nsPtr, FRAME_IS_PROC);
if (result != TCL_OK) {
return result;
}
framePtr->clientData = NULL;
framePtr->objc = objc;
framePtr->objv = objv;
framePtr->procPtr = procPtr;
/*
* Give the pre-call callback a chance to do some setup and, possibly,
* veto the call.
*/
if (pmPtr->preCallProc != NULL) {
int isFinished;
result = pmPtr->preCallProc(pmPtr->clientData, interp, NULL,
(Tcl_CallFrame *) framePtr, &isFinished);
if (isFinished || result != TCL_OK) {
Tcl_PopCallFrame(interp);
TclStackFree(interp, framePtr);
goto done;
}
}
/*
* Now invoke the body of the method. Note that we need to take special
* action when doing unknown processing to ensure that the missing method
* name is passed as an argument.
*/
if (pmPtr->postCallProc) {
Tcl_NRAddCallback(interp, CallFinalizePMCall, nsPtr,
(void *)pmPtr->postCallProc, pmPtr->clientData, NULL);
}
return TclNRInterpProcCore(interp, namePtr, 1, pmPtr->errProc);
done:
return result;
}
int
Itcl_InvokeProcedureMethod(
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
Tcl_Namespace *nsPtr;
Method *mPtr;
mPtr = (Method *)clientData;
if (mPtr->declaringClassPtr == NULL) {
/* that is the case for typemethods */
nsPtr = mPtr->declaringObjectPtr->namespacePtr;
} else {
nsPtr = mPtr->declaringClassPtr->thisPtr->namespacePtr;
}
return Tcl_InvokeClassProcedureMethod(interp, mPtr->namePtr, nsPtr,
(ProcedureMethod *)mPtr->clientData, objc, objv);
}
static int
FreeProcedureMethod(
void *data[],
Tcl_Interp *dummy,
int result)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
(void)dummy;
ckfree(pmPtr);
return result;
}
static void
EnsembleErrorProc(
Tcl_Interp *interp,
Tcl_Obj *procNameObj)
{
int overflow, limit = 60, nameLen;
const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (itcl ensemble part \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
int
Itcl_InvokeEnsembleMethod(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr, /* namespace to call the method in */
Tcl_Obj *namePtr, /* name of the method */
Tcl_Proc *procPtr,
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
ProcedureMethod *pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->procPtr = (Proc *)procPtr;
pmPtr->flags = USE_DECLARER_NS;
pmPtr->errProc = EnsembleErrorProc;
Tcl_NRAddCallback(interp, FreeProcedureMethod, pmPtr, NULL, NULL, NULL);
return Tcl_InvokeClassProcedureMethod(interp, namePtr, nsPtr,
pmPtr, objc, objv);
}
/*
* ----------------------------------------------------------------------
*
* Itcl_PublicObjectCmd, Itcl_PrivateObjectCmd --
*
* Main entry point for object invokations. The Public* and Private*
* wrapper functions are just thin wrappers around the main ObjectCmd
* function that does call chain creation, management and invokation.
*
* ----------------------------------------------------------------------
*/
int
Itcl_PublicObjectCmd(
void *clientData,
Tcl_Interp *interp,
Tcl_Class clsPtr,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr = (Tcl_Object)clientData;
int result;
if (oPtr) {
result = TclOOInvokeObject(interp, oPtr, clsPtr, PUBLIC_METHOD,
objc, objv);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot access object-specific info without an object context",
NULL);
return TCL_ERROR;
}
return result;
}
/*
* ----------------------------------------------------------------------
*
* Itcl_NewProcClassMethod --
*
* Create a new procedure-like method for a class for Itcl.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Itcl_NewProcClassMethod(
Tcl_Interp *interp, /* The interpreter containing the class. */
Tcl_Class clsPtr, /* The class to modify. */
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which may be NULL;
* if so, up to caller to manage storage
* (e.g., because it is a constructor or
* destructor). */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which may be NULL; if so, it is equivalent
* to an empty list. */
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
void **clientData2)
{
Tcl_Method result;
result = TclOONewProcMethodEx(interp, clsPtr, preCallPtr, postCallPtr,
errProc, clientData, nameObj, argsObj, bodyObj,
PUBLIC_METHOD | USE_DECLARER_NS, clientData2);
return result;
}
/*
* ----------------------------------------------------------------------
*
* Itcl_NewProcMethod --
*
* Create a new procedure-like method for an object for Itcl.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Itcl_NewProcMethod(
Tcl_Interp *interp, /* The interpreter containing the object. */
Tcl_Object oPtr, /* The object to modify. */
TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc,
void *clientData,
Tcl_Obj *nameObj, /* The name of the method, which must not be
* NULL. */
Tcl_Obj *argsObj, /* The formal argument list for the method,
* which must not be NULL. */
Tcl_Obj *bodyObj, /* The body of the method, which must not be
* NULL. */
void **clientData2)
{
return TclOONewProcInstanceMethodEx(interp, oPtr, preCallPtr, postCallPtr,
errProc, clientData, nameObj, argsObj, bodyObj,
PUBLIC_METHOD | USE_DECLARER_NS, clientData2);
}
/*
* ----------------------------------------------------------------------
*
* Itcl_NewForwardClassMethod --
*
* Create a new forwarded method for a class for Itcl.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Itcl_NewForwardClassMethod(
Tcl_Interp *interp,
Tcl_Class clsPtr,
int flags,
Tcl_Obj *nameObj,
Tcl_Obj *prefixObj)
{
return (Tcl_Method)TclOONewForwardMethod(interp, (Class *)clsPtr,
flags, nameObj, prefixObj);
}
static Tcl_Obj *
Itcl_TclOOObjectName(
Tcl_Interp *interp,
Object *oPtr)
{
Tcl_Obj *namePtr;
if (oPtr->cachedNameObj) {
return oPtr->cachedNameObj;
}
namePtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
Tcl_IncrRefCount(namePtr);
oPtr->cachedNameObj = namePtr;
return namePtr;
}
int
Itcl_SelfCmd(
void *dummy,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
(void)dummy;
if (!Itcl_IsMethodCallFrame(interp)) {
Tcl_AppendResult(interp, TclGetString(objv[0]),
" may only be called from inside a method", NULL);
return TCL_ERROR;
}
contextPtr = (CallContext *)framePtr->clientData;
if (objc == 1) {
Tcl_SetObjResult(interp, Itcl_TclOOObjectName(interp, contextPtr->oPtr));
return TCL_OK;
}
return TCL_ERROR;
}
int
Itcl_IsMethodCallFrame(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return 0;
}
return 1;
}

33
pkgs/itcl4.2.2/generic/itcl2TclOO.h Normal file
View File

@@ -0,0 +1,33 @@
#ifndef _TCLINT
typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj);
#endif
#ifndef TCL_OO_INTERNAL_H
typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
#endif
MODULE_SCOPE int Itcl_NRRunCallbacks(Tcl_Interp *interp, void *rootPtr);
MODULE_SCOPE void * Itcl_GetCurrentCallbackPtr(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Method Itcl_NewProcClassMethod(Tcl_Interp *interp, Tcl_Class clsPtr,
TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ClientData *clientData2);
MODULE_SCOPE Tcl_Method Itcl_NewProcMethod(Tcl_Interp *interp, Tcl_Object oPtr,
TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ClientData *clientData2);
MODULE_SCOPE int Itcl_PublicObjectCmd(ClientData clientData, Tcl_Interp *interp,
Tcl_Class clsPtr, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE Tcl_Method Itcl_NewForwardClassMethod(Tcl_Interp *interp,
Tcl_Class clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
MODULE_SCOPE int Itcl_SelfCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_IsMethodCallFrame(Tcl_Interp *interp);
MODULE_SCOPE int Itcl_InvokeEnsembleMethod(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *namePtr, Tcl_Proc *procPtr, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int Itcl_InvokeProcedureMethod(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const *objv);

598
pkgs/itcl4.2.2/generic/itclBase.c Normal file
View File

@@ -0,0 +1,598 @@
/*
* itclBase.c --
*
* This file contains the C-implemented startup part of an
* Itcl implemenatation
*
* Copyright (c) 2007 by Arnulf P. Wiedemann
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <stdlib.h>
#include "itclInt.h"
static Tcl_NamespaceDeleteProc FreeItclObjectInfo;
static Tcl_ObjCmdProc ItclSetHullWindowName;
static Tcl_ObjCmdProc ItclCheckSetItclHull;
MODULE_SCOPE const ItclStubs itclStubs;
static int Initialize(Tcl_Interp *interp);
static const char initScript[] =
"namespace eval ::itcl {\n"
" proc _find_init {} {\n"
" global env tcl_library\n"
" variable library\n"
" variable patchLevel\n"
" rename _find_init {}\n"
" if {[info exists library]} {\n"
" lappend dirs $library\n"
" } else {\n"
" set dirs {}\n"
" if {[info exists env(ITCL_LIBRARY)]} {\n"
" lappend dirs $env(ITCL_LIBRARY)\n"
" }\n"
" lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n"
" set bindir [file dirname [info nameofexecutable]]\n"
" lappend dirs [file join . library]\n"
" lappend dirs [file join $bindir .. lib itcl$patchLevel]\n"
" lappend dirs [file join $bindir .. library]\n"
" lappend dirs [file join $bindir .. .. library]\n"
" lappend dirs [file join $bindir .. .. itcl library]\n"
" lappend dirs [file join $bindir .. .. .. itcl library]\n"
" lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n"
" # On *nix, check the directories in the tcl_pkgPath\n"
" # XXX JH - this looks unnecessary, maybe Darwin only?\n"
" if {[string equal $::tcl_platform(platform) \"unix\"]} {\n"
" foreach d $::tcl_pkgPath {\n"
" lappend dirs $d\n"
" lappend dirs [file join $d itcl$patchLevel]\n"
" }\n"
" }\n"
" }\n"
" foreach i $dirs {\n"
" set library $i\n"
" if {![catch {uplevel #0 [list source [file join $i itcl.tcl]]}]} {\n"
" set library $i\n"
" return\n"
" }\n"
" }\n"
" set msg \"Can't find a usable itcl.tcl in the following directories:\n\"\n"
" append msg \" $dirs\n\"\n"
" append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n"
" append msg \"If you know where the Itcl library directory was installed,\n\"\n"
" append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n"
" append msg \"to the library directory.\n\"\n"
" error $msg\n"
" }\n"
" _find_init\n"
"}";
/*
* The following script is used to initialize Itcl in a safe interpreter.
*/
static const char safeInitScript[] =
"proc ::itcl::local {class name args} {\n"
" set ptr [uplevel [list $class $name] $args]\n"
" uplevel [list set itcl-local-$ptr $ptr]\n"
" set cmd [uplevel namespace which -command $ptr]\n"
" uplevel [list trace variable itcl-local-$ptr u \"::itcl::delete object $cmd; list\"]\n"
" return $ptr\n"
"}";
static const char *clazzClassScript =
"::oo::class create ::itcl::clazz {\n"
" superclass ::oo::class\n"
" method unknown args {\n"
" ::tailcall ::itcl::parser::handleClass [::lindex [::info level 0] 0] [self] {*}$args\n"
" }\n"
" unexport create new unknown\n"
"}";
#define ITCL_IS_ENSEMBLE 0x1
#ifdef ITCL_DEBUG_C_INTERFACE
extern void RegisterDebugCFunctions( Tcl_Interp * interp);
#endif
static Tcl_ObjectMetadataDeleteProc Demolition;
static const Tcl_ObjectMetadataType canary = {
TCL_OO_METADATA_VERSION_CURRENT,
"Itcl Foundations",
Demolition,
NULL
};
void
Demolition(
void *clientData)
{
ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
infoPtr->clazzObjectPtr = NULL;
infoPtr->clazzClassPtr = NULL;
}
static const Tcl_ObjectMetadataType objMDT = {
TCL_OO_METADATA_VERSION_CURRENT,
"ItclObject",
ItclDeleteObjectMetadata, /* Not really used yet */
NULL
};
static Tcl_MethodCallProc RootCallProc;
const Tcl_MethodType itclRootMethodType = {
TCL_OO_METHOD_VERSION_CURRENT,
"itcl root method",
RootCallProc,
NULL,
NULL
};
static int
RootCallProc(
void *clientData,
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr = Tcl_ObjectContextObject(context);
ItclObject *ioPtr = (ItclObject *)Tcl_ObjectGetMetadata(oPtr, &objMDT);
ItclRootMethodProc *proc = (ItclRootMethodProc *)clientData;
return (*proc)(ioPtr, interp, objc, objv);
}
/*
* ------------------------------------------------------------------------
* Initialize()
*
* that is the starting point when loading the library
* it initializes all internal stuff
*
* ------------------------------------------------------------------------
*/
static int
Initialize (
Tcl_Interp *interp)
{
Tcl_Namespace *nsPtr;
Tcl_Namespace *itclNs;
Tcl_HashEntry *hPtr;
ItclObjectInfo *infoPtr;
const char * ret;
char *res_option;
int opt;
int isNew;
Tcl_Class tclCls;
Tcl_Object clazzObjectPtr, root;
Tcl_Obj *objPtr, *resPtr;
if (Tcl_InitStubs(interp, "8.6", 0) == NULL) {
return TCL_ERROR;
}
ret = TclOOInitializeStubs(interp, "1.0");
if (ret == NULL) {
return TCL_ERROR;
}
objPtr = Tcl_NewStringObj("::oo::class", -1);
Tcl_IncrRefCount(objPtr);
clazzObjectPtr = Tcl_GetObjectFromObj(interp, objPtr);
if (!clazzObjectPtr || !(tclCls = Tcl_GetObjectAsClass(clazzObjectPtr))) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
Tcl_DecrRefCount(objPtr);
infoPtr = (ItclObjectInfo*)Itcl_Alloc(sizeof(ItclObjectInfo));
nsPtr = Tcl_CreateNamespace(interp, ITCL_NAMESPACE, infoPtr, FreeItclObjectInfo);
if (nsPtr == NULL) {
Itcl_Free(infoPtr);
Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", ITCL_NAMESPACE);
}
nsPtr = Tcl_CreateNamespace(interp, ITCL_INTDICTS_NAMESPACE,
NULL, NULL);
if (nsPtr == NULL) {
Itcl_Free(infoPtr);
Tcl_Panic("Itcl: cannot create namespace: \"%s::internal::dicts\" \n",
ITCL_NAMESPACE);
}
/*
* Create the top-level data structure for tracking objects.
* Store this as "associated data" for easy access, but link
* it to the itcl namespace for ownership.
*/
infoPtr->interp = interp;
infoPtr->class_meta_type = (Tcl_ObjectMetadataType *)ckalloc(
sizeof(Tcl_ObjectMetadataType));
infoPtr->class_meta_type->version = TCL_OO_METADATA_VERSION_CURRENT;
infoPtr->class_meta_type->name = "ItclClass";
infoPtr->class_meta_type->deleteProc = ItclDeleteClassMetadata;
infoPtr->class_meta_type->cloneProc = NULL;
infoPtr->object_meta_type = &objMDT;
Tcl_InitHashTable(&infoPtr->objects, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->objectCmds, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->classes, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->nameClasses);
Tcl_InitHashTable(&infoPtr->namespaceClasses, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->procMethods, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->instances, TCL_STRING_KEYS);
Tcl_InitHashTable(&infoPtr->frameContext, TCL_ONE_WORD_KEYS);
Tcl_InitObjHashTable(&infoPtr->classTypes);
infoPtr->ensembleInfo = (EnsembleInfo *)ckalloc(sizeof(EnsembleInfo));
memset(infoPtr->ensembleInfo, 0, sizeof(EnsembleInfo));
Tcl_InitHashTable(&infoPtr->ensembleInfo->ensembles, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&infoPtr->ensembleInfo->subEnsembles, TCL_ONE_WORD_KEYS);
infoPtr->ensembleInfo->numEnsembles = 0;
infoPtr->protection = ITCL_DEFAULT_PROTECT;
infoPtr->currClassFlags = 0;
infoPtr->buildingWidget = 0;
infoPtr->typeDestructorArgumentPtr = Tcl_NewStringObj("", -1);
Tcl_IncrRefCount(infoPtr->typeDestructorArgumentPtr);
infoPtr->lastIoPtr = NULL;
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classes", NULL, "", 0);
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::objects", NULL, "", 0);
Tcl_SetVar2(interp, ITCL_NAMESPACE"::internal::dicts::classOptions", NULL, "", 0);
Tcl_SetVar2(interp,
ITCL_NAMESPACE"::internal::dicts::classDelegatedOptions", NULL, "", 0);
Tcl_SetVar2(interp,
ITCL_NAMESPACE"::internal::dicts::classComponents", NULL, "", 0);
Tcl_SetVar2(interp,
ITCL_NAMESPACE"::internal::dicts::classVariables", NULL, "", 0);
Tcl_SetVar2(interp,
ITCL_NAMESPACE"::internal::dicts::classFunctions", NULL, "", 0);
Tcl_SetVar2(interp,
ITCL_NAMESPACE"::internal::dicts::classDelegatedFunctions", NULL, "", 0);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("class", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_CLASS);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("type", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_TYPE);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("widget", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_WIDGET);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("widgetadaptor", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_WIDGETADAPTOR);
hPtr = Tcl_CreateHashEntry(&infoPtr->classTypes,
(char *)Tcl_NewStringObj("extendedclass", -1), &isNew);
Tcl_SetHashValue(hPtr, ITCL_ECLASS);
res_option = getenv("ITCL_USE_OLD_RESOLVERS");
if (res_option == NULL) {
opt = 1;
} else {
opt = atoi(res_option);
}
infoPtr->useOldResolvers = opt;
Itcl_InitStack(&infoPtr->clsStack);
Tcl_SetAssocData(interp, ITCL_INTERP_DATA, NULL, infoPtr);
Itcl_PreserveData(infoPtr);
root = Tcl_NewObjectInstance(interp, tclCls, "::itcl::Root",
NULL, 0, NULL, 0);
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
Tcl_NewStringObj("unknown", -1), 0, &itclRootMethodType,
(void *)ItclUnknownGuts);
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
Tcl_NewStringObj("ItclConstructBase", -1), 0,
&itclRootMethodType, (void *)ItclConstructGuts);
Tcl_NewMethod(interp, Tcl_GetObjectAsClass(root),
Tcl_NewStringObj("info", -1), 1,
&itclRootMethodType, (void *)ItclInfoGuts);
/* first create the Itcl base class as root of itcl classes */
if (Tcl_EvalEx(interp, clazzClassScript, -1, 0) != TCL_OK) {
Tcl_Panic("cannot create Itcl root class ::itcl::clazz");
}
resPtr = Tcl_GetObjResult(interp);
/*
* Tcl_GetObjectFromObject can call Tcl_SetObjResult, so increment the
* refcount first.
*/
Tcl_IncrRefCount(resPtr);
clazzObjectPtr = Tcl_GetObjectFromObj(interp, resPtr);
Tcl_DecrRefCount(resPtr);
if (clazzObjectPtr == NULL) {
Tcl_AppendResult(interp,
"ITCL: cannot get Object for ::itcl::clazz for class \"",
"::itcl::clazz", "\"", NULL);
return TCL_ERROR;
}
Tcl_ObjectSetMetadata(clazzObjectPtr, &canary, infoPtr);
infoPtr->clazzObjectPtr = clazzObjectPtr;
infoPtr->clazzClassPtr = Tcl_GetObjectAsClass(clazzObjectPtr);
/*
* Initialize the ensemble package first, since we need this
* for other parts of [incr Tcl].
*/
if (Itcl_EnsembleInit(interp) != TCL_OK) {
return TCL_ERROR;
}
Itcl_ParseInit(interp, infoPtr);
/*
* Create "itcl::builtin" namespace for commands that
* are automatically built into class definitions.
*/
if (Itcl_BiInit(interp, infoPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Export all commands in the "itcl" namespace so that they
* can be imported with something like "namespace import itcl::*"
*/
itclNs = Tcl_FindNamespace(interp, "::itcl", NULL,
TCL_LEAVE_ERR_MSG);
/*
* This was changed from a glob export (itcl::*) to explicit
* command exports, so that the itcl::is command can *not* be
* exported. This is done for concern that the itcl::is command
* imported might be confusing ("is").
*/
if (!itclNs ||
(Tcl_Export(interp, itclNs, "body", /* reset */ 1) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "class", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "code", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "configbody", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "delete", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "delete_helper", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "ensemble", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "filter", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "find", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "forward", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "local", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "mixin", 0) != TCL_OK) ||
(Tcl_Export(interp, itclNs, "scope", 0) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::internal::commands::sethullwindowname",
ItclSetHullWindowName, infoPtr, NULL);
Tcl_CreateObjCommand(interp,
ITCL_NAMESPACE"::internal::commands::checksetitclhull",
ItclCheckSetItclHull, infoPtr, NULL);
/*
* Set up the variables containing version info.
*/
Tcl_SetVar2(interp, "::itcl::version", NULL, ITCL_VERSION, TCL_NAMESPACE_ONLY);
Tcl_SetVar2(interp, "::itcl::patchLevel", NULL, ITCL_PATCH_LEVEL,
TCL_NAMESPACE_ONLY);
#ifdef ITCL_DEBUG_C_INTERFACE
RegisterDebugCFunctions(interp);
#endif
/*
* Package is now loaded.
*/
Tcl_PkgProvideEx(interp, "Itcl", ITCL_PATCH_LEVEL, &itclStubs);
return Tcl_PkgProvideEx(interp, "itcl", ITCL_PATCH_LEVEL, &itclStubs);
}
/*
* ------------------------------------------------------------------------
* Itcl_Init()
*
* Invoked whenever a new INTERPRETER is created to install the
* [incr Tcl] package. Usually invoked within Tcl_AppInit() at
* the start of execution.
*
* Creates the "::itcl" namespace and installs access commands for
* creating classes and querying info.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itcl_Init (
Tcl_Interp *interp)
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, initScript, -1, 0);
}
/*
* ------------------------------------------------------------------------
* Itcl_SafeInit()
*
* Invoked whenever a new SAFE INTERPRETER is created to install
* the [incr Tcl] package.
*
* Creates the "::itcl" namespace and installs access commands for
* creating classes and querying info.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error
* message in the interpreter) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itcl_SafeInit (
Tcl_Interp *interp)
{
if (Initialize(interp) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_EvalEx(interp, safeInitScript, -1, 0);
}
/*
* ------------------------------------------------------------------------
* ItclSetHullWindowName()
*
*
* ------------------------------------------------------------------------
*/
static int
ItclSetHullWindowName(
void *clientData, /* infoPtr */
Tcl_Interp *dummy, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr;
(void)dummy;
infoPtr = (ItclObjectInfo *)clientData;
if ((infoPtr->currIoPtr != NULL) && (objc > 1)) {
infoPtr->currIoPtr->hullWindowNamePtr = objv[1];
Tcl_IncrRefCount(infoPtr->currIoPtr->hullWindowNamePtr);
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclCheckSetItclHull()
*
*
* ------------------------------------------------------------------------
*/
static int
ItclCheckSetItclHull(
void *clientData, /* infoPtr */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_HashEntry *hPtr;
Tcl_Obj *objPtr;
ItclObject *ioPtr;
ItclVariable *ivPtr;
ItclObjectInfo *infoPtr;
const char *valueStr;
if (objc < 3) {
Tcl_AppendResult(interp, "ItclCheckSetItclHull wrong # args should be ",
"<objectName> <value>", NULL);
return TCL_ERROR;
}
/*
* This is an internal command, and is never called with an
* objectName value other than the empty list. Check that with
* an assertion so alternative handling can be removed.
*/
assert( strlen(Tcl_GetString(objv[1])) == 0);
infoPtr = (ItclObjectInfo *)clientData;
{
ioPtr = infoPtr->currIoPtr;
if (ioPtr == NULL) {
Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find object",
NULL);
return TCL_ERROR;
}
}
objPtr = Tcl_NewStringObj("itcl_hull", -1);
hPtr = Tcl_FindHashEntry(&ioPtr->iclsPtr->variables, (char *)objPtr);
Tcl_DecrRefCount(objPtr);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "ItclCheckSetItclHull cannot find itcl_hull",
" variable for object \"", Tcl_GetString(objv[1]), "\"", NULL);
return TCL_ERROR;
}
ivPtr = (ItclVariable *)Tcl_GetHashValue(hPtr);
valueStr = Tcl_GetString(objv[2]);
if (strcmp(valueStr, "2") == 0) {
ivPtr->initted = 2;
} else {
if (strcmp(valueStr, "0") == 0) {
ivPtr->initted = 0;
} else {
Tcl_AppendResult(interp, "ItclCheckSetItclHull bad value \"",
valueStr, "\"", NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* FreeItclObjectInfo()
*
* called when an interp is deleted to free up memory
*
* ------------------------------------------------------------------------
*/
static void
FreeItclObjectInfo(
void *clientData)
{
ItclObjectInfo *infoPtr = (ItclObjectInfo *)clientData;
Tcl_DeleteHashTable(&infoPtr->instances);
Tcl_DeleteHashTable(&infoPtr->classTypes);
Tcl_DeleteHashTable(&infoPtr->procMethods);
Tcl_DeleteHashTable(&infoPtr->objectCmds);
Tcl_DeleteHashTable(&infoPtr->classes);
Tcl_DeleteHashTable(&infoPtr->nameClasses);
Tcl_DeleteHashTable(&infoPtr->namespaceClasses);
assert (infoPtr->infoVarsPtr == NULL);
assert (infoPtr->infoVars4Ptr == NULL);
if (infoPtr->typeDestructorArgumentPtr) {
Tcl_DecrRefCount(infoPtr->typeDestructorArgumentPtr);
infoPtr->typeDestructorArgumentPtr = NULL;
}
/* cleanup ensemble info */
if (infoPtr->ensembleInfo) {
Tcl_DeleteHashTable(&infoPtr->ensembleInfo->ensembles);
Tcl_DeleteHashTable(&infoPtr->ensembleInfo->subEnsembles);
ItclFinishEnsemble(infoPtr);
ckfree((char *)infoPtr->ensembleInfo);
infoPtr->ensembleInfo = NULL;
}
if (infoPtr->class_meta_type) {
ckfree((char *)infoPtr->class_meta_type);
infoPtr->class_meta_type = NULL;
}
/* clean up list pool */
Itcl_FinishList();
Itcl_ReleaseData(infoPtr);
}

3849
pkgs/itcl4.2.2/generic/itclBuiltin.c Normal file
View File

File diff suppressed because it is too large Load Diff

2588
pkgs/itcl4.2.2/generic/itclClass.c Normal file
View File

File diff suppressed because it is too large Load Diff

2193
pkgs/itcl4.2.2/generic/itclCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

211
pkgs/itcl4.2.2/generic/itclDecls.h Normal file
View File

@@ -0,0 +1,211 @@
/*
* This file is (mostly) automatically generated from itcl.decls.
*/
#ifndef _ITCLDECLS
#define _ITCLDECLS
#if defined(USE_ITCL_STUBS)
ITCLAPI const char *Itcl_InitStubs(
Tcl_Interp *, const char *version, int exact);
#else
#define Itcl_InitStubs(interp, version, exact) Tcl_PkgRequireEx(interp,"itcl",version,exact,NULL)
#endif
/* !BEGIN!: Do not edit below this line. */
#define ITCL_STUBS_EPOCH 0
#define ITCL_STUBS_REVISION 152
#ifdef __cplusplus
extern "C" {
#endif
/*
* Exported function declarations:
*/
/* Slot 0 is reserved */
/* Slot 1 is reserved */
/* 2 */
ITCLAPI int Itcl_RegisterC(Tcl_Interp *interp, const char *name,
Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 3 */
ITCLAPI int Itcl_RegisterObjC(Tcl_Interp *interp,
const char *name, Tcl_ObjCmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 4 */
ITCLAPI int Itcl_FindC(Tcl_Interp *interp, const char *name,
Tcl_CmdProc **argProcPtr,
Tcl_ObjCmdProc **objProcPtr,
ClientData *cDataPtr);
/* 5 */
ITCLAPI void Itcl_InitStack(Itcl_Stack *stack);
/* 6 */
ITCLAPI void Itcl_DeleteStack(Itcl_Stack *stack);
/* 7 */
ITCLAPI void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack);
/* 8 */
ITCLAPI ClientData Itcl_PopStack(Itcl_Stack *stack);
/* 9 */
ITCLAPI ClientData Itcl_PeekStack(Itcl_Stack *stack);
/* 10 */
ITCLAPI ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos);
/* 11 */
ITCLAPI void Itcl_InitList(Itcl_List *listPtr);
/* 12 */
ITCLAPI void Itcl_DeleteList(Itcl_List *listPtr);
/* 13 */
ITCLAPI Itcl_ListElem * Itcl_CreateListElem(Itcl_List *listPtr);
/* 14 */
ITCLAPI Itcl_ListElem * Itcl_DeleteListElem(Itcl_ListElem *elemPtr);
/* 15 */
ITCLAPI Itcl_ListElem * Itcl_InsertList(Itcl_List *listPtr, ClientData val);
/* 16 */
ITCLAPI Itcl_ListElem * Itcl_InsertListElem(Itcl_ListElem *pos,
ClientData val);
/* 17 */
ITCLAPI Itcl_ListElem * Itcl_AppendList(Itcl_List *listPtr, ClientData val);
/* 18 */
ITCLAPI Itcl_ListElem * Itcl_AppendListElem(Itcl_ListElem *pos,
ClientData val);
/* 19 */
ITCLAPI void Itcl_SetListValue(Itcl_ListElem *elemPtr,
ClientData val);
/* 20 */
ITCLAPI void Itcl_EventuallyFree(ClientData cdata,
Tcl_FreeProc *fproc);
/* 21 */
ITCLAPI void Itcl_PreserveData(ClientData cdata);
/* 22 */
ITCLAPI void Itcl_ReleaseData(ClientData cdata);
/* 23 */
ITCLAPI Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp *interp, int status);
/* 24 */
ITCLAPI int Itcl_RestoreInterpState(Tcl_Interp *interp,
Itcl_InterpState state);
/* 25 */
ITCLAPI void Itcl_DiscardInterpState(Itcl_InterpState state);
/* 26 */
ITCLAPI void * Itcl_Alloc(size_t size);
/* 27 */
ITCLAPI void Itcl_Free(void *ptr);
typedef struct {
const struct ItclIntStubs *itclIntStubs;
} ItclStubHooks;
typedef struct ItclStubs {
int magic;
int epoch;
int revision;
const ItclStubHooks *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
int (*itcl_RegisterC) (Tcl_Interp *interp, const char *name, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 2 */
int (*itcl_RegisterObjC) (Tcl_Interp *interp, const char *name, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 3 */
int (*itcl_FindC) (Tcl_Interp *interp, const char *name, Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, ClientData *cDataPtr); /* 4 */
void (*itcl_InitStack) (Itcl_Stack *stack); /* 5 */
void (*itcl_DeleteStack) (Itcl_Stack *stack); /* 6 */
void (*itcl_PushStack) (ClientData cdata, Itcl_Stack *stack); /* 7 */
ClientData (*itcl_PopStack) (Itcl_Stack *stack); /* 8 */
ClientData (*itcl_PeekStack) (Itcl_Stack *stack); /* 9 */
ClientData (*itcl_GetStackValue) (Itcl_Stack *stack, int pos); /* 10 */
void (*itcl_InitList) (Itcl_List *listPtr); /* 11 */
void (*itcl_DeleteList) (Itcl_List *listPtr); /* 12 */
Itcl_ListElem * (*itcl_CreateListElem) (Itcl_List *listPtr); /* 13 */
Itcl_ListElem * (*itcl_DeleteListElem) (Itcl_ListElem *elemPtr); /* 14 */
Itcl_ListElem * (*itcl_InsertList) (Itcl_List *listPtr, ClientData val); /* 15 */
Itcl_ListElem * (*itcl_InsertListElem) (Itcl_ListElem *pos, ClientData val); /* 16 */
Itcl_ListElem * (*itcl_AppendList) (Itcl_List *listPtr, ClientData val); /* 17 */
Itcl_ListElem * (*itcl_AppendListElem) (Itcl_ListElem *pos, ClientData val); /* 18 */
void (*itcl_SetListValue) (Itcl_ListElem *elemPtr, ClientData val); /* 19 */
void (*itcl_EventuallyFree) (ClientData cdata, Tcl_FreeProc *fproc); /* 20 */
void (*itcl_PreserveData) (ClientData cdata); /* 21 */
void (*itcl_ReleaseData) (ClientData cdata); /* 22 */
Itcl_InterpState (*itcl_SaveInterpState) (Tcl_Interp *interp, int status); /* 23 */
int (*itcl_RestoreInterpState) (Tcl_Interp *interp, Itcl_InterpState state); /* 24 */
void (*itcl_DiscardInterpState) (Itcl_InterpState state); /* 25 */
void * (*itcl_Alloc) (size_t size); /* 26 */
void (*itcl_Free) (void *ptr); /* 27 */
} ItclStubs;
extern const ItclStubs *itclStubsPtr;
#ifdef __cplusplus
}
#endif
#if defined(USE_ITCL_STUBS)
/*
* Inline function declarations:
*/
/* Slot 0 is reserved */
/* Slot 1 is reserved */
#define Itcl_RegisterC \
(itclStubsPtr->itcl_RegisterC) /* 2 */
#define Itcl_RegisterObjC \
(itclStubsPtr->itcl_RegisterObjC) /* 3 */
#define Itcl_FindC \
(itclStubsPtr->itcl_FindC) /* 4 */
#define Itcl_InitStack \
(itclStubsPtr->itcl_InitStack) /* 5 */
#define Itcl_DeleteStack \
(itclStubsPtr->itcl_DeleteStack) /* 6 */
#define Itcl_PushStack \
(itclStubsPtr->itcl_PushStack) /* 7 */
#define Itcl_PopStack \
(itclStubsPtr->itcl_PopStack) /* 8 */
#define Itcl_PeekStack \
(itclStubsPtr->itcl_PeekStack) /* 9 */
#define Itcl_GetStackValue \
(itclStubsPtr->itcl_GetStackValue) /* 10 */
#define Itcl_InitList \
(itclStubsPtr->itcl_InitList) /* 11 */
#define Itcl_DeleteList \
(itclStubsPtr->itcl_DeleteList) /* 12 */
#define Itcl_CreateListElem \
(itclStubsPtr->itcl_CreateListElem) /* 13 */
#define Itcl_DeleteListElem \
(itclStubsPtr->itcl_DeleteListElem) /* 14 */
#define Itcl_InsertList \
(itclStubsPtr->itcl_InsertList) /* 15 */
#define Itcl_InsertListElem \
(itclStubsPtr->itcl_InsertListElem) /* 16 */
#define Itcl_AppendList \
(itclStubsPtr->itcl_AppendList) /* 17 */
#define Itcl_AppendListElem \
(itclStubsPtr->itcl_AppendListElem) /* 18 */
#define Itcl_SetListValue \
(itclStubsPtr->itcl_SetListValue) /* 19 */
#define Itcl_EventuallyFree \
(itclStubsPtr->itcl_EventuallyFree) /* 20 */
#define Itcl_PreserveData \
(itclStubsPtr->itcl_PreserveData) /* 21 */
#define Itcl_ReleaseData \
(itclStubsPtr->itcl_ReleaseData) /* 22 */
#define Itcl_SaveInterpState \
(itclStubsPtr->itcl_SaveInterpState) /* 23 */
#define Itcl_RestoreInterpState \
(itclStubsPtr->itcl_RestoreInterpState) /* 24 */
#define Itcl_DiscardInterpState \
(itclStubsPtr->itcl_DiscardInterpState) /* 25 */
#define Itcl_Alloc \
(itclStubsPtr->itcl_Alloc) /* 26 */
#define Itcl_Free \
(itclStubsPtr->itcl_Free) /* 27 */
#endif /* defined(USE_ITCL_STUBS) */
/* !END!: Do not edit above this line. */
#endif /* _ITCLDECLS */

2238
pkgs/itcl4.2.2/generic/itclEnsemble.c Normal file
View File

File diff suppressed because it is too large Load Diff

1492
pkgs/itcl4.2.2/generic/itclHelpers.c Normal file
View File

File diff suppressed because it is too large Load Diff

5383
pkgs/itcl4.2.2/generic/itclInfo.c Normal file
View File

File diff suppressed because it is too large Load Diff

843
pkgs/itcl4.2.2/generic/itclInt.h Normal file
View File

@@ -0,0 +1,843 @@
/*
* itclInt.h --
*
* This file contains internal definitions for the C-implemented part of a
* Itcl
*
* Copyright (c) 2007 by Arnulf P. Wiedemann
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef HAVE_STDINT_H
#include <stdint.h>
#endif
/*
* Used to tag functions that are only to be visible within the module being
* built and not outside it (where this is supported by the linker).
*/
#ifndef MODULE_SCOPE
# ifdef __cplusplus
# define MODULE_SCOPE extern "C"
# else
# define MODULE_SCOPE extern
# endif
#endif
#include <string.h>
#include <ctype.h>
#include <tclOO.h>
#include "itcl.h"
#include "itclMigrate2TclCore.h"
#include "itclTclIntStubsFcn.h"
/*
* Utility macros: STRINGIFY takes an argument and wraps it in "" (double
* quotation marks).
*/
#ifndef STRINGIFY
# define STRINGIFY(x) STRINGIFY1(x)
# define STRINGIFY1(x) #x
#endif
/*
* MSVC 8.0 started to mark many standard C library functions depreciated
* including the *printf family and others. Tell it to shut up.
* (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0)
*/
#if defined(_MSC_VER)
# pragma warning(disable:4244)
# if _MSC_VER >= 1400
# pragma warning(disable:4267)
# pragma warning(disable:4996)
# endif
#endif
#ifndef JOIN
# define JOIN(a,b) JOIN1(a,b)
# define JOIN1(a,b) a##b
#endif
#ifndef TCL_UNUSED
# if defined(__cplusplus)
# define TCL_UNUSED(T) T
# else
# define TCL_UNUSED(T) T JOIN(dummy, __LINE__)
# endif
#endif
/*
* Since the Tcl/Tk distribution doesn't perform any asserts,
* dynamic loading can fail to find the __assert function.
* As a workaround, we'll include our own.
*/
#undef assert
#if defined(NDEBUG) && !defined(DEBUG)
#define assert(EX) ((void)0)
#else /* !NDEBUG || DEBUG */
#define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0))
#endif
#define ITCL_INTERP_DATA "itcl_data"
#define ITCL_TK_VERSION "8.6"
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
* does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
* only iterates over values.
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\
*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
/*
* What sort of size of things we like to allocate.
*/
#define ALLOC_CHUNK 8
#define ITCL_INT_NAMESPACE ITCL_NAMESPACE"::internal"
#define ITCL_INTDICTS_NAMESPACE ITCL_INT_NAMESPACE"::dicts"
#define ITCL_VARIABLES_NAMESPACE ITCL_INT_NAMESPACE"::variables"
#define ITCL_COMMANDS_NAMESPACE ITCL_INT_NAMESPACE"::commands"
typedef struct ItclFoundation {
Itcl_Stack methodCallStack;
Tcl_Command dispatchCommand;
} ItclFoundation;
typedef struct ItclArgList {
struct ItclArgList *nextPtr; /* pointer to next argument */
Tcl_Obj *namePtr; /* name of the argument */
Tcl_Obj *defaultValuePtr; /* default value or NULL if none */
} ItclArgList;
/*
* Common info for managing all known objects.
* Each interpreter has one of these data structures stored as
* clientData in the "itcl" namespace. It is also accessible
* as associated data via the key ITCL_INTERP_DATA.
*/
struct ItclClass;
struct ItclObject;
struct ItclMemberFunc;
struct EnsembleInfo;
struct ItclDelegatedOption;
struct ItclDelegatedFunction;
typedef struct ItclObjectInfo {
Tcl_Interp *interp; /* interpreter that manages this info */
Tcl_HashTable objects; /* list of all known objects key is
* ioPtr */
Tcl_HashTable objectCmds; /* list of known objects using accessCmd */
Tcl_HashTable unused5; /* list of known objects using namePtr */
Tcl_HashTable classes; /* list of all known classes,
* key is iclsPtr */
Tcl_HashTable nameClasses; /* maps from fullNamePtr to iclsPtr */
Tcl_HashTable namespaceClasses; /* maps from nsPtr to iclsPtr */
Tcl_HashTable procMethods; /* maps from procPtr to mFunc */
Tcl_HashTable instances; /* maps from instanceNumber to ioPtr */
Tcl_HashTable unused8; /* maps from ioPtr to instanceNumber */
Tcl_HashTable frameContext; /* maps frame to context stack */
Tcl_HashTable classTypes; /* maps from class type i.e. "widget"
* to define value i.e. ITCL_WIDGET */
int protection; /* protection level currently in effect */
int useOldResolvers; /* whether to use the "old" style
* resolvers or the CallFrame resolvers */
Itcl_Stack clsStack; /* stack of class definitions currently
* being parsed */
Itcl_Stack unused; /* Removed */
Itcl_Stack unused6; /* obsolete field */
struct ItclObject *currIoPtr; /* object currently being constructed
* set only during calling of constructors
* otherwise NULL */
Tcl_ObjectMetadataType *class_meta_type;
/* type for getting the Itcl class info
* from a TclOO Tcl_Object */
const Tcl_ObjectMetadataType *object_meta_type;
/* type for getting the Itcl object info
* from a TclOO Tcl_Object */
Tcl_Object clazzObjectPtr; /* the root object of Itcl */
Tcl_Class clazzClassPtr; /* the root class of Itcl */
struct EnsembleInfo *ensembleInfo;
struct ItclClass *currContextIclsPtr;
/* context class for delegated option
* handling */
int currClassFlags; /* flags for the class just in creation */
int buildingWidget; /* set if in construction of a widget */
int unparsedObjc; /* number options not parsed by
ItclExtendedConfigure/-Cget function */
Tcl_Obj **unparsedObjv; /* options not parsed by
ItclExtendedConfigure/-Cget function */
int functionFlags; /* used for creating of ItclMemberCode */
int unused7;
struct ItclDelegatedOption *currIdoPtr;
/* the current delegated option info */
int inOptionHandling; /* used to indicate for type/widget ...
* that there is an option processing
* and methods are allowed to be called */
/* these are the Tcl_Obj Ptrs for the clazz unknown procedure */
/* need to store them to be able to free them at the end */
int itclWidgetInitted; /* set to 1 if itclWidget.tcl has already
* been called
*/
int itclHullCmdsInitted; /* set to 1 if itclHullCmds.tcl has already
* been called
*/
Tcl_Obj *unused2;
Tcl_Obj *unused3;
Tcl_Obj *unused4;
Tcl_Obj *infoVarsPtr;
Tcl_Obj *unused9;
Tcl_Obj *infoVars4Ptr;
Tcl_Obj *typeDestructorArgumentPtr;
struct ItclObject *lastIoPtr; /* last object constructed */
Tcl_Command infoCmd;
} ItclObjectInfo;
typedef struct EnsembleInfo {
Tcl_HashTable ensembles; /* list of all known ensembles */
Tcl_HashTable subEnsembles; /* list of all known subensembles */
int numEnsembles;
Tcl_Namespace *ensembleNsPtr;
} EnsembleInfo;
/*
* Representation for each [incr Tcl] class.
*/
#define ITCL_CLASS 0x1
#define ITCL_TYPE 0x2
#define ITCL_WIDGET 0x4
#define ITCL_WIDGETADAPTOR 0x8
#define ITCL_ECLASS 0x10
#define ITCL_NWIDGET 0x20
#define ITCL_WIDGET_FRAME 0x40
#define ITCL_WIDGET_LABEL_FRAME 0x80
#define ITCL_WIDGET_TOPLEVEL 0x100
#define ITCL_WIDGET_TTK_FRAME 0x200
#define ITCL_WIDGET_TTK_LABEL_FRAME 0x400
#define ITCL_WIDGET_TTK_TOPLEVEL 0x800
#define ITCL_CLASS_IS_DELETED 0x1000
#define ITCL_CLASS_IS_DESTROYED 0x2000
#define ITCL_CLASS_NS_IS_DESTROYED 0x4000
#define ITCL_CLASS_IS_RENAMED 0x8000 /* unused */
#define ITCL_CLASS_IS_FREED 0x10000
#define ITCL_CLASS_DERIVED_RELEASED 0x20000
#define ITCL_CLASS_NS_TEARDOWN 0x40000
#define ITCL_CLASS_NO_VARNS_DELETE 0x80000
#define ITCL_CLASS_SHOULD_VARNS_DELETE 0x100000
#define ITCL_CLASS_DESTRUCTOR_CALLED 0x400000
typedef struct ItclClass {
Tcl_Obj *namePtr; /* class name */
Tcl_Obj *fullNamePtr; /* fully qualified class name */
Tcl_Interp *interp; /* interpreter that manages this info */
Tcl_Namespace *nsPtr; /* namespace representing class scope */
Tcl_Command accessCmd; /* access command for creating instances */
Tcl_Command thisCmd; /* needed for deletion of class */
struct ItclObjectInfo *infoPtr;
/* info about all known objects
* and other stuff like stacks */
Itcl_List bases; /* list of base classes */
Itcl_List derived; /* list of all derived classes */
Tcl_HashTable heritage; /* table of all base classes. Look up
* by pointer to class definition. This
* provides fast lookup for inheritance
* tests. */
Tcl_Obj *initCode; /* initialization code for new objs */
Tcl_HashTable variables; /* definitions for all data members
in this class. Look up simple string
names and get back ItclVariable* ptrs */
Tcl_HashTable options; /* definitions for all option members
in this class. Look up simple string
names and get back ItclOption* ptrs */
Tcl_HashTable components; /* definitions for all component members
in this class. Look up simple string
names and get back ItclComponent* ptrs */
Tcl_HashTable functions; /* definitions for all member functions
in this class. Look up simple string
names and get back ItclMemberFunc* ptrs */
Tcl_HashTable delegatedOptions; /* definitions for all delegated options
in this class. Look up simple string
names and get back
ItclDelegatedOption * ptrs */
Tcl_HashTable delegatedFunctions; /* definitions for all delegated methods
or procs in this class. Look up simple
string names and get back
ItclDelegatedFunction * ptrs */
Tcl_HashTable methodVariables; /* definitions for all methodvariable members
in this class. Look up simple string
names and get back
ItclMethodVariable* ptrs */
int numInstanceVars; /* number of instance vars in variables
table */
Tcl_HashTable classCommons; /* used for storing variable namespace
* string for Tcl_Resolve */
Tcl_HashTable resolveVars; /* all possible names for variables in
* this class (e.g., x, foo::x, etc.) */
Tcl_HashTable resolveCmds; /* all possible names for functions in
* this class (e.g., x, foo::x, etc.) */
Tcl_HashTable contextCache; /* cache for function contexts */
struct ItclMemberFunc *unused2;
/* the class constructor or NULL */
struct ItclMemberFunc *unused3;
/* the class destructor or NULL */
struct ItclMemberFunc *unused1;
Tcl_Resolve *resolvePtr;
Tcl_Obj *widgetClassPtr; /* class name for widget if class is a
* ::itcl::widget */
Tcl_Obj *hullTypePtr; /* hulltype name for widget if class is a
* ::itcl::widget */
Tcl_Object oPtr; /* TclOO class object */
Tcl_Class clsPtr; /* TclOO class */
int numCommons; /* number of commons in this class */
int numVariables; /* number of variables in this class */
int numOptions; /* number of options in this class */
int unique; /* unique number for #auto generation */
int flags; /* maintains class status */
int callRefCount; /* prevent deleting of class if refcount>1 */
Tcl_Obj *typeConstructorPtr; /* initialization for types */
int destructorHasBeenCalled; /* prevent multiple invocations of destrcutor */
int refCount;
} ItclClass;
typedef struct ItclHierIter {
ItclClass *current; /* current position in hierarchy */
Itcl_Stack stack; /* stack used for traversal */
} ItclHierIter;
#define ITCL_OBJECT_IS_DELETED 0x01
#define ITCL_OBJECT_IS_DESTRUCTED 0x02
#define ITCL_OBJECT_IS_DESTROYED 0x04
#define ITCL_OBJECT_IS_RENAMED 0x08
#define ITCL_OBJECT_CLASS_DESTRUCTED 0x10
#define ITCL_TCLOO_OBJECT_IS_DELETED 0x20
#define ITCL_OBJECT_DESTRUCT_ERROR 0x40
#define ITCL_OBJECT_SHOULD_VARNS_DELETE 0x80
#define ITCL_OBJECT_ROOT_METHOD 0x8000
/*
* Representation for each [incr Tcl] object.
*/
typedef struct ItclObject {
ItclClass *iclsPtr; /* most-specific class */
Tcl_Command accessCmd; /* object access command */
Tcl_HashTable* constructed; /* temp storage used during construction */
Tcl_HashTable* destructed; /* temp storage used during destruction */
Tcl_HashTable objectVariables;
/* used for storing Tcl_Var entries for
* variable resolving, key is ivPtr of
* variable, value is varPtr */
Tcl_HashTable objectOptions; /* definitions for all option members
in this object. Look up option namePtr
names and get back ItclOption* ptrs */
Tcl_HashTable objectComponents; /* definitions for all component members
in this object. Look up component namePtr
names and get back ItclComponent* ptrs */
Tcl_HashTable objectMethodVariables;
/* definitions for all methodvariable members
in this object. Look up methodvariable
namePtr names and get back
ItclMethodVariable* ptrs */
Tcl_HashTable objectDelegatedOptions;
/* definitions for all delegated option
members in this object. Look up option
namePtr names and get back
ItclOption* ptrs */
Tcl_HashTable objectDelegatedFunctions;
/* definitions for all delegated function
members in this object. Look up function
namePtr names and get back
ItclMemberFunc * ptrs */
Tcl_HashTable contextCache; /* cache for function contexts */
Tcl_Obj *namePtr;
Tcl_Obj *origNamePtr; /* the original name before any rename */
Tcl_Obj *createNamePtr; /* the temp name before any rename
* mostly used for widgetadaptor
* because that hijackes the name
* often when installing the hull */
Tcl_Interp *interp;
ItclObjectInfo *infoPtr;
Tcl_Obj *varNsNamePtr;
Tcl_Object oPtr; /* the TclOO object */
Tcl_Resolve *resolvePtr;
int flags;
int callRefCount; /* prevent deleting of object if refcount > 1 */
Tcl_Obj *hullWindowNamePtr; /* the window path name for the hull
* (before renaming in installhull) */
int destructorHasBeenCalled; /* is set when the destructor is called
* to avoid callin destructor twice */
int noComponentTrace; /* don't call component traces if
* setting components in DelegationInstall */
int hadConstructorError; /* needed for multiple calls of CallItclObjectCmd */
} ItclObject;
#define ITCL_IGNORE_ERRS 0x002 /* useful for construction/destruction */
typedef struct ItclResolveInfo {
int flags;
ItclClass *iclsPtr;
ItclObject *ioPtr;
} ItclResolveInfo;
#define ITCL_RESOLVE_CLASS 0x01
#define ITCL_RESOLVE_OBJECT 0x02
/*
* Implementation for any code body in an [incr Tcl] class.
*/
typedef struct ItclMemberCode {
int flags; /* flags describing implementation */
int argcount; /* number of args in arglist */
int maxargcount; /* max number of args in arglist */
Tcl_Obj *usagePtr; /* usage string for error messages */
Tcl_Obj *argumentPtr; /* the function arguments */
Tcl_Obj *bodyPtr; /* the function body */
ItclArgList *argListPtr; /* the parsed arguments */
union {
Tcl_CmdProc *argCmd; /* (argc,argv) C implementation */
Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */
} cfunc;
ClientData clientData; /* client data for C implementations */
} ItclMemberCode;
/*
* Flag bits for ItclMemberCode:
*/
#define ITCL_IMPLEMENT_NONE 0x001 /* no implementation */
#define ITCL_IMPLEMENT_TCL 0x002 /* Tcl implementation */
#define ITCL_IMPLEMENT_ARGCMD 0x004 /* (argc,argv) C implementation */
#define ITCL_IMPLEMENT_OBJCMD 0x008 /* (objc,objv) C implementation */
#define ITCL_IMPLEMENT_C 0x00c /* either kind of C implementation */
#define Itcl_IsMemberCodeImplemented(mcode) \
(((mcode)->flags & ITCL_IMPLEMENT_NONE) == 0)
/*
* Flag bits for ItclMember: functions and variables
*/
#define ITCL_COMMON 0x010 /* non-zero => is a "proc" or common
* variable */
/*
* Flag bits for ItclMember: functions
*/
#define ITCL_CONSTRUCTOR 0x020 /* non-zero => is a constructor */
#define ITCL_DESTRUCTOR 0x040 /* non-zero => is a destructor */
#define ITCL_ARG_SPEC 0x080 /* non-zero => has an argument spec */
#define ITCL_BODY_SPEC 0x100 /* non-zero => has an body spec */
#define ITCL_BUILTIN 0x400 /* non-zero => built-in method */
#define ITCL_COMPONENT 0x800 /* non-zero => component */
#define ITCL_TYPE_METHOD 0x1000 /* non-zero => typemethod */
#define ITCL_METHOD 0x2000 /* non-zero => method */
/*
* Flag bits for ItclMember: variables
*/
#define ITCL_THIS_VAR 0x20 /* non-zero => built-in "this" variable */
#define ITCL_OPTIONS_VAR 0x40 /* non-zero => built-in "itcl_options"
* variable */
#define ITCL_TYPE_VAR 0x80 /* non-zero => built-in "type" variable */
/* no longer used ??? */
#define ITCL_SELF_VAR 0x100 /* non-zero => built-in "self" variable */
#define ITCL_SELFNS_VAR 0x200 /* non-zero => built-in "selfns"
* variable */
#define ITCL_WIN_VAR 0x400 /* non-zero => built-in "win" variable */
#define ITCL_COMPONENT_VAR 0x800 /* non-zero => component variable */
#define ITCL_HULL_VAR 0x1000 /* non-zero => built-in "itcl_hull"
* variable */
#define ITCL_OPTION_READONLY 0x2000 /* non-zero => readonly */
#define ITCL_VARIABLE 0x4000 /* non-zero => normal variable */
#define ITCL_TYPE_VARIABLE 0x8000 /* non-zero => typevariable */
#define ITCL_OPTION_INITTED 0x10000 /* non-zero => option has been initialized */
#define ITCL_OPTION_COMP_VAR 0x20000 /* variable to collect option components of extendedclass */
/*
* Instance components.
*/
struct ItclVariable;
typedef struct ItclComponent {
Tcl_Obj *namePtr; /* member name */
struct ItclVariable *ivPtr; /* variable for this component */
int flags;
int haveKeptOptions;
Tcl_HashTable keptOptions; /* table of options to keep */
} ItclComponent;
#define ITCL_COMPONENT_INHERIT 0x01
#define ITCL_COMPONENT_PUBLIC 0x02
typedef struct ItclDelegatedFunction {
Tcl_Obj *namePtr;
ItclComponent *icPtr;
Tcl_Obj *asPtr;
Tcl_Obj *usingPtr;
Tcl_HashTable exceptions;
int flags;
} ItclDelegatedFunction;
/*
* Representation of member functions in an [incr Tcl] class.
*/
typedef struct ItclMemberFunc {
Tcl_Obj* namePtr; /* member name */
Tcl_Obj* fullNamePtr; /* member name with "class::" qualifier */
ItclClass* iclsPtr; /* class containing this member */
int protection; /* protection level */
int flags; /* flags describing member (see above) */
ItclObjectInfo *infoPtr;
ItclMemberCode *codePtr; /* code associated with member */
Tcl_Command accessCmd; /* Tcl command installed for this function */
int argcount; /* number of args in arglist */
int maxargcount; /* max number of args in arglist */
Tcl_Obj *usagePtr; /* usage string for error messages */
Tcl_Obj *argumentPtr; /* the function arguments */
Tcl_Obj *builtinArgumentPtr; /* the function arguments for builtin functions */
Tcl_Obj *origArgsPtr; /* the argument string of the original definition */
Tcl_Obj *bodyPtr; /* the function body */
ItclArgList *argListPtr; /* the parsed arguments */
ItclClass *declaringClassPtr; /* the class which declared the method/proc */
ClientData tmPtr; /* TclOO methodPtr */
ItclDelegatedFunction *idmPtr;
/* if the function is delegated != NULL */
} ItclMemberFunc;
/*
* Instance variables.
*/
typedef struct ItclVariable {
Tcl_Obj *namePtr; /* member name */
Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */
ItclClass *iclsPtr; /* class containing this member */
ItclObjectInfo *infoPtr;
ItclMemberCode *codePtr; /* code associated with member */
Tcl_Obj *init; /* initial value */
Tcl_Obj *arrayInitPtr; /* initial value if variable should be array */
int protection; /* protection level */
int flags; /* flags describing member (see below) */
int initted; /* is set when first time initted, to check
* for example itcl_hull var, which can be only
* initialized once */
} ItclVariable;
struct ItclOption;
typedef struct ItclDelegatedOption {
Tcl_Obj *namePtr;
Tcl_Obj *resourceNamePtr;
Tcl_Obj *classNamePtr;
struct ItclOption *ioptPtr; /* the option name or null for "*" */
ItclComponent *icPtr; /* the component where the delegation goes
* to */
Tcl_Obj *asPtr;
Tcl_HashTable exceptions; /* exceptions from delegation */
} ItclDelegatedOption;
/*
* Instance options.
*/
typedef struct ItclOption {
/* within a class hierarchy there must be only
* one option with the same name !! */
Tcl_Obj *namePtr; /* member name */
Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */
Tcl_Obj *resourceNamePtr;
Tcl_Obj *classNamePtr;
ItclClass *iclsPtr; /* class containing this member */
int protection; /* protection level */
int flags; /* flags describing member (see below) */
ItclMemberCode *codePtr; /* code associated with member */
Tcl_Obj *defaultValuePtr; /* initial value */
Tcl_Obj *cgetMethodPtr;
Tcl_Obj *cgetMethodVarPtr;
Tcl_Obj *configureMethodPtr;
Tcl_Obj *configureMethodVarPtr;
Tcl_Obj *validateMethodPtr;
Tcl_Obj *validateMethodVarPtr;
ItclDelegatedOption *idoPtr;
/* if the option is delegated != NULL */
} ItclOption;
/*
* Instance methodvariables.
*/
typedef struct ItclMethodVariable {
Tcl_Obj *namePtr; /* member name */
Tcl_Obj *fullNamePtr; /* member name with "class::" qualifier */
ItclClass *iclsPtr; /* class containing this member */
int protection; /* protection level */
int flags; /* flags describing member (see below) */
Tcl_Obj *defaultValuePtr;
Tcl_Obj *callbackPtr;
} ItclMethodVariable;
#define VAR_TYPE_VARIABLE 1
#define VAR_TYPE_COMMON 2
#define CMD_TYPE_METHOD 1
#define CMD_TYPE_PROC 2
typedef struct ItclClassCmdInfo {
int type;
int protection;
int cmdNum;
Tcl_Namespace *nsPtr;
Tcl_Namespace *declaringNsPtr;
} ItclClassCmdInfo;
/*
* Instance variable lookup entry.
*/
typedef struct ItclVarLookup {
ItclVariable* ivPtr; /* variable definition */
int usage; /* number of uses for this record */
int accessible; /* non-zero => accessible from class with
* this lookup record in its resolveVars */
char *leastQualName; /* simplist name for this variable, with
* the fewest qualifiers. This string is
* taken from the resolveVars table, so
* it shouldn't be freed. */
int varNum;
Tcl_Var varPtr;
} ItclVarLookup;
/*
* Instance command lookup entry.
*/
typedef struct ItclCmdLookup {
ItclMemberFunc* imPtr; /* function definition */
int cmdNum;
ItclClassCmdInfo *classCmdInfoPtr;
Tcl_Command cmdPtr;
} ItclCmdLookup;
typedef struct ItclCallContext {
int objectFlags;
Tcl_Namespace *nsPtr;
ItclObject *ioPtr;
ItclMemberFunc *imPtr;
int refCount;
} ItclCallContext;
/*
* The macro below is used to modify a "char" value (e.g. by casting
* it to an unsigned character) so that it can be used safely with
* macros such as isspace.
*/
#define UCHAR(c) ((unsigned char) (c))
/*
* Macros used to cast between pointers and integers (e.g. when storing an int
* in ClientData), on 64-bit architectures they avoid gcc warning about "cast
* to/from pointer from/to integer of different size".
*/
#if !defined(INT2PTR) && !defined(PTR2INT)
# if defined(HAVE_INTPTR_T) || defined(intptr_t)
# define INT2PTR(p) ((void*)(intptr_t)(p))
# define PTR2INT(p) ((int)(intptr_t)(p))
# else
# define INT2PTR(p) ((void*)(p))
# define PTR2INT(p) ((int)(p))
# endif
#endif
#ifdef ITCL_DEBUG
MODULE_SCOPE int _itcl_debug_level;
MODULE_SCOPE void ItclShowArgs(int level, const char *str, int objc,
Tcl_Obj * const* objv);
#else
#define ItclShowArgs(a,b,c,d) do {(void)(c);(void)(d);} while(0)
#endif
MODULE_SCOPE Tcl_ObjCmdProc ItclCallCCommand;
MODULE_SCOPE Tcl_ObjCmdProc ItclObjectUnknownCommand;
MODULE_SCOPE int ItclCheckCallProc(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished);
MODULE_SCOPE void ItclPreserveClass(ItclClass *iclsPtr);
MODULE_SCOPE void ItclReleaseClass(ClientData iclsPtr);
MODULE_SCOPE ItclFoundation *ItclGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_ObjCmdProc ItclClassCommandDispatcher;
MODULE_SCOPE Tcl_Command Itcl_CmdAliasProc(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *cmdName, ClientData clientData);
MODULE_SCOPE Tcl_Var Itcl_VarAliasProc(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *VarName, ClientData clientData);
MODULE_SCOPE int ItclIsClass(Tcl_Interp *interp, Tcl_Command cmd);
MODULE_SCOPE int ItclCheckCallMethod(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext contextPtr, Tcl_CallFrame *framePtr, int *isFinished);
MODULE_SCOPE int ItclAfterCallMethod(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext contextPtr, Tcl_Namespace *nsPtr, int result);
MODULE_SCOPE void ItclReportObjectUsage(Tcl_Interp *interp,
ItclObject *contextIoPtr, Tcl_Namespace *callerNsPtr,
Tcl_Namespace *contextNsPtr);
MODULE_SCOPE int ItclMapMethodNameProc(Tcl_Interp *interp, Tcl_Object oPtr,
Tcl_Class *startClsPtr, Tcl_Obj *methodObj);
MODULE_SCOPE int ItclCreateArgList(Tcl_Interp *interp, const char *str,
int *argcPtr, int *maxArgcPtr, Tcl_Obj **usagePtr,
ItclArgList **arglistPtrPtr, ItclMemberFunc *imPtr,
const char *commandName);
MODULE_SCOPE int ItclObjectCmd(ClientData clientData, Tcl_Interp *interp,
Tcl_Object oPtr, Tcl_Class clsPtr, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int ItclCreateObject (Tcl_Interp *interp, const char* name,
ItclClass *iclsPtr, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void ItclDeleteObjectVariablesNamespace(Tcl_Interp *interp,
ItclObject *ioPtr);
MODULE_SCOPE void ItclDeleteClassVariablesNamespace(Tcl_Interp *interp,
ItclClass *iclsPtr);
MODULE_SCOPE int ItclInfoInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr);
MODULE_SCOPE Tcl_HashEntry *ItclResolveVarEntry(
ItclClass* iclsPtr, const char *varName);
struct Tcl_ResolvedVarInfo;
MODULE_SCOPE int Itcl_ClassCmdResolver(Tcl_Interp *interp, const char* name,
Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr);
MODULE_SCOPE int Itcl_ClassVarResolver(Tcl_Interp *interp, const char* name,
Tcl_Namespace *nsPtr, int flags, Tcl_Var *rPtr);
MODULE_SCOPE int Itcl_ClassCompiledVarResolver(Tcl_Interp *interp,
const char* name, int length, Tcl_Namespace *nsPtr,
struct Tcl_ResolvedVarInfo **rPtr);
MODULE_SCOPE int Itcl_ClassCmdResolver2(Tcl_Interp *interp, const char* name,
Tcl_Namespace *nsPtr, int flags, Tcl_Command *rPtr);
MODULE_SCOPE int Itcl_ClassVarResolver2(Tcl_Interp *interp, const char* name,
Tcl_Namespace *nsPtr, int flags, Tcl_Var *rPtr);
MODULE_SCOPE int Itcl_ClassCompiledVarResolver2(Tcl_Interp *interp,
const char* name, int length, Tcl_Namespace *nsPtr,
struct Tcl_ResolvedVarInfo **rPtr);
MODULE_SCOPE int ItclSetParserResolver(Tcl_Namespace *nsPtr);
MODULE_SCOPE void ItclProcErrorProc(Tcl_Interp *interp, Tcl_Obj *procNameObj);
MODULE_SCOPE int Itcl_CreateOption (Tcl_Interp *interp, ItclClass *iclsPtr,
ItclOption *ioptPtr);
MODULE_SCOPE int ItclCreateMethodVariable(Tcl_Interp *interp,
ItclVariable *ivPtr, Tcl_Obj* defaultPtr, Tcl_Obj* callbackPtr,
ItclMethodVariable** imvPtrPtr);
MODULE_SCOPE int DelegationInstall(Tcl_Interp *interp, ItclObject *ioPtr,
ItclClass *iclsPtr);
MODULE_SCOPE ItclClass *ItclNamespace2Class(Tcl_Namespace *nsPtr);
MODULE_SCOPE const char* ItclGetCommonInstanceVar(Tcl_Interp *interp,
const char *name, const char *name2, ItclObject *contextIoPtr,
ItclClass *contextIclsPtr);
MODULE_SCOPE int ItclCreateMethod(Tcl_Interp* interp, ItclClass *iclsPtr,
Tcl_Obj *namePtr, const char* arglist, const char* body,
ItclMemberFunc **imPtrPtr);
MODULE_SCOPE int Itcl_WidgetParseInit(Tcl_Interp *interp,
ItclObjectInfo *infoPtr);
MODULE_SCOPE void ItclDeleteObjectMetadata(ClientData clientData);
MODULE_SCOPE void ItclDeleteClassMetadata(ClientData clientData);
MODULE_SCOPE void ItclDeleteArgList(ItclArgList *arglistPtr);
MODULE_SCOPE int Itcl_ClassOptionCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int DelegatedOptionsInstall(Tcl_Interp *interp,
ItclClass *iclsPtr);
MODULE_SCOPE int Itcl_HandleDelegateOptionCmd(Tcl_Interp *interp,
ItclObject *ioPtr, ItclClass *iclsPtr, ItclDelegatedOption **idoPtrPtr,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int Itcl_HandleDelegateMethodCmd(Tcl_Interp *interp,
ItclObject *ioPtr, ItclClass *iclsPtr,
ItclDelegatedFunction **idmPtrPtr, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int DelegateFunction(Tcl_Interp *interp, ItclObject *ioPtr,
ItclClass *iclsPtr, Tcl_Obj *componentNamePtr,
ItclDelegatedFunction *idmPtr);
MODULE_SCOPE int ItclInitObjectMethodVariables(Tcl_Interp *interp,
ItclObject *ioPtr, ItclClass *iclsPtr, const char *name);
MODULE_SCOPE int InitTclOOFunctionPointers(Tcl_Interp *interp);
MODULE_SCOPE ItclOption* ItclNewOption(Tcl_Interp *interp, ItclObject *ioPtr,
ItclClass *iclsPtr, Tcl_Obj *namePtr, const char *resourceName,
const char *className, char *init, ItclMemberCode *mCodePtr);
MODULE_SCOPE int ItclParseOption(ItclObjectInfo *infoPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[], ItclClass *iclsPtr,
ItclObject *ioPtr, ItclOption **ioptPtrPtr);
MODULE_SCOPE void ItclDestroyClassNamesp(ClientData cdata);
MODULE_SCOPE int ExpandDelegateAs(Tcl_Interp *interp, ItclObject *ioPtr,
ItclClass *iclsPtr, ItclDelegatedFunction *idmPtr,
const char *funcName, Tcl_Obj *listPtr);
MODULE_SCOPE int ItclCheckForInitializedComponents(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclObject *ioPtr);
MODULE_SCOPE int ItclCreateDelegatedFunction(Tcl_Interp *interp,
ItclClass *iclsPtr, Tcl_Obj *methodNamePtr, ItclComponent *icPtr,
Tcl_Obj *targetPtr, Tcl_Obj *usingPtr, Tcl_Obj *exceptionsPtr,
ItclDelegatedFunction **idmPtrPtr);
MODULE_SCOPE void ItclDeleteDelegatedOption(char *cdata);
MODULE_SCOPE void Itcl_FinishList();
MODULE_SCOPE void ItclDeleteDelegatedFunction(ItclDelegatedFunction *idmPtr);
MODULE_SCOPE void ItclFinishEnsemble(ItclObjectInfo *infoPtr);
MODULE_SCOPE int Itcl_EnsembleDeleteCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE int ItclAddClassesDictInfo(Tcl_Interp *interp, ItclClass *iclsPtr);
MODULE_SCOPE int ItclDeleteClassesDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr);
MODULE_SCOPE int ItclAddObjectsDictInfo(Tcl_Interp *interp, ItclObject *ioPtr);
MODULE_SCOPE int ItclDeleteObjectsDictInfo(Tcl_Interp *interp,
ItclObject *ioPtr);
MODULE_SCOPE int ItclAddOptionDictInfo(Tcl_Interp *interp, ItclClass *iclsPtr,
ItclOption *ioptPtr);
MODULE_SCOPE int ItclAddDelegatedOptionDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclDelegatedOption *idoPtr);
MODULE_SCOPE int ItclAddClassComponentDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclComponent *icPtr);
MODULE_SCOPE int ItclAddClassVariableDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclVariable *ivPtr);
MODULE_SCOPE int ItclAddClassFunctionDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclMemberFunc *imPtr);
MODULE_SCOPE int ItclAddClassDelegatedFunctionDictInfo(Tcl_Interp *interp,
ItclClass *iclsPtr, ItclDelegatedFunction *idmPtr);
MODULE_SCOPE int ItclClassCreateObject(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void ItclRestoreInfoVars(ClientData clientData);
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyProcCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiInstallComponentCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiCallInstanceCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiGetInstanceVarCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyTypeMethodCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyMethodCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyTypeVarCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiMyVarCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_BiItclHullCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_ThisCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_ExtendedClassCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_TypeClassCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddObjectOptionCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddDelegatedOptionCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_AddDelegatedFunctionCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_SetComponentCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_ClassHullTypeCmd;
MODULE_SCOPE Tcl_ObjCmdProc Itcl_ClassWidgetClassCmd;
typedef int (ItclRootMethodProc)(ItclObject *ioPtr, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE const Tcl_MethodType itclRootMethodType;
MODULE_SCOPE ItclRootMethodProc ItclUnknownGuts;
MODULE_SCOPE ItclRootMethodProc ItclConstructGuts;
MODULE_SCOPE ItclRootMethodProc ItclInfoGuts;
#include "itcl2TclOO.h"
/*
* Include all the private API, generated from itcl.decls.
*/
#include "itclIntDecls.h"

1046
pkgs/itcl4.2.2/generic/itclIntDecls.h Normal file
View File

File diff suppressed because it is too large Load Diff

326
pkgs/itcl4.2.2/generic/itclLinkage.c Normal file
View File

@@ -0,0 +1,326 @@
/*
* ------------------------------------------------------------------------
* 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.
*
* This part adds a mechanism for integrating C procedures into
* [incr Tcl] classes as methods and procs. Each C procedure must
* either be declared via Itcl_RegisterC() or dynamically loaded.
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
*
* overhauled version author: Arnulf Wiedemann
* ========================================================================
* 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"
/*
* These records store the pointers for all "RegisterC" functions.
*/
typedef struct ItclCfunc {
Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */
Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */
ClientData clientData; /* client data passed into this function */
Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */
} ItclCfunc;
static Tcl_HashTable* ItclGetRegisteredProcs(Tcl_Interp *interp);
static void ItclFreeC(ClientData clientData, Tcl_Interp *interp);
/*
* ------------------------------------------------------------------------
* Itcl_RegisterC()
*
* Used to associate a symbolic name with an (argc,argv) C procedure
* that handles a Tcl command. Procedures that are registered in this
* manner can be referenced in the body of an [incr Tcl] class
* definition to specify C procedures to acting as methods/procs.
* Usually invoked in an initialization routine for an extension,
* called out in Tcl_AppInit() at the start of an application.
*
* Each symbolic procedure can have an arbitrary client data value
* associated with it. This value is passed into the command
* handler whenever it is invoked.
*
* A symbolic procedure name can be used only once for a given style
* (arg/obj) handler. If the name is defined with an arg-style
* handler, it can be redefined with an obj-style handler; or if
* the name is defined with an obj-style handler, it can be redefined
* with an arg-style handler. In either case, any previous client
* data is discarded and the new client data is remembered. However,
* if a name is redefined to a different handler of the same style,
* this procedure returns an error.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
* in interp->result) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itcl_RegisterC(
Tcl_Interp *interp, /* interpreter handling this registration */
const char *name, /* symbolic name for procedure */
Tcl_CmdProc *proc, /* procedure handling Tcl command */
ClientData clientData, /* client data associated with proc */
Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */
{
int newEntry;
Tcl_HashEntry *entry;
Tcl_HashTable *procTable;
ItclCfunc *cfunc;
/*
* Make sure that a proc was specified.
*/
if (!proc) {
Tcl_AppendResult(interp, "initialization error: null pointer for ",
"C procedure \"", name, "\"",
NULL);
return TCL_ERROR;
}
/*
* Add a new entry for the given procedure. If an entry with
* this name already exists, then make sure that it was defined
* with the same proc.
*/
procTable = ItclGetRegisteredProcs(interp);
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
if (!newEntry) {
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) {
Tcl_AppendResult(interp, "initialization error: C procedure ",
"with name \"", name, "\" already defined",
NULL);
return TCL_ERROR;
}
if (cfunc->deleteProc != NULL) {
(*cfunc->deleteProc)(cfunc->clientData);
}
} else {
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
cfunc->objCmdProc = NULL;
}
cfunc->argCmdProc = proc;
cfunc->clientData = clientData;
cfunc->deleteProc = deleteProc;
Tcl_SetHashValue(entry, cfunc);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_RegisterObjC()
*
* Used to associate a symbolic name with an (objc,objv) C procedure
* that handles a Tcl command. Procedures that are registered in this
* manner can be referenced in the body of an [incr Tcl] class
* definition to specify C procedures to acting as methods/procs.
* Usually invoked in an initialization routine for an extension,
* called out in Tcl_AppInit() at the start of an application.
*
* Each symbolic procedure can have an arbitrary client data value
* associated with it. This value is passed into the command
* handler whenever it is invoked.
*
* A symbolic procedure name can be used only once for a given style
* (arg/obj) handler. If the name is defined with an arg-style
* handler, it can be redefined with an obj-style handler; or if
* the name is defined with an obj-style handler, it can be redefined
* with an arg-style handler. In either case, any previous client
* data is discarded and the new client data is remembered. However,
* if a name is redefined to a different handler of the same style,
* this procedure returns an error.
*
* Returns TCL_OK on success, or TCL_ERROR (along with an error message
* in interp->result) if anything goes wrong.
* ------------------------------------------------------------------------
*/
int
Itcl_RegisterObjC(
Tcl_Interp *interp, /* interpreter handling this registration */
const char *name, /* symbolic name for procedure */
Tcl_ObjCmdProc *proc, /* procedure handling Tcl command */
ClientData clientData, /* client data associated with proc */
Tcl_CmdDeleteProc *deleteProc) /* proc called to free up client data */
{
int newEntry;
Tcl_HashEntry *entry;
Tcl_HashTable *procTable;
ItclCfunc *cfunc;
/*
* Make sure that a proc was specified.
*/
if (!proc) {
Tcl_AppendResult(interp, "initialization error: null pointer for ",
"C procedure \"", name, "\"",
NULL);
return TCL_ERROR;
}
/*
* Add a new entry for the given procedure. If an entry with
* this name already exists, then make sure that it was defined
* with the same proc.
*/
procTable = ItclGetRegisteredProcs(interp);
entry = Tcl_CreateHashEntry(procTable, name, &newEntry);
if (!newEntry) {
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) {
Tcl_AppendResult(interp, "initialization error: C procedure ",
"with name \"", name, "\" already defined",
NULL);
return TCL_ERROR;
}
if (cfunc->deleteProc != NULL) {
(*cfunc->deleteProc)(cfunc->clientData);
}
}
else {
cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc));
cfunc->argCmdProc = NULL;
}
cfunc->objCmdProc = proc;
cfunc->clientData = clientData;
cfunc->deleteProc = deleteProc;
Tcl_SetHashValue(entry, cfunc);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_FindC()
*
* Used to query a C procedure via its symbolic name. Looks at the
* list of procedures registered previously by either Itcl_RegisterC
* or Itcl_RegisterObjC and returns pointers to the appropriate
* (argc,argv) or (objc,objv) handlers. Returns non-zero if the
* name is recognized and pointers are returned; returns zero
* otherwise.
* ------------------------------------------------------------------------
*/
int
Itcl_FindC(
Tcl_Interp *interp, /* interpreter handling this registration */
const char *name, /* symbolic name for procedure */
Tcl_CmdProc **argProcPtr, /* returns (argc,argv) command handler */
Tcl_ObjCmdProc **objProcPtr, /* returns (objc,objv) command handler */
ClientData *cDataPtr) /* returns client data */
{
Tcl_HashEntry *entry;
Tcl_HashTable *procTable;
ItclCfunc *cfunc;
*argProcPtr = NULL; /* assume info won't be found */
*objProcPtr = NULL;
*cDataPtr = NULL;
if (interp) {
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp,
"itcl_RegC", NULL);
if (procTable) {
entry = Tcl_FindHashEntry(procTable, name);
if (entry) {
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
*argProcPtr = cfunc->argCmdProc;
*objProcPtr = cfunc->objCmdProc;
*cDataPtr = cfunc->clientData;
}
}
}
return (*argProcPtr != NULL || *objProcPtr != NULL);
}
/*
* ------------------------------------------------------------------------
* ItclGetRegisteredProcs()
*
* Returns a pointer to a hash table containing the list of registered
* procs in the specified interpreter. If the hash table does not
* already exist, it is created.
* ------------------------------------------------------------------------
*/
static Tcl_HashTable*
ItclGetRegisteredProcs(
Tcl_Interp *interp) /* interpreter handling this registration */
{
Tcl_HashTable* procTable;
/*
* If the registration table does not yet exist, then create it.
*/
procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC",
NULL);
if (!procTable) {
procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(procTable, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC,
procTable);
}
return procTable;
}
/*
* ------------------------------------------------------------------------
* ItclFreeC()
*
* When an interpreter is deleted, this procedure is called to
* free up the associated data created by Itcl_RegisterC and
* Itcl_RegisterObjC.
* ------------------------------------------------------------------------
*/
static void
ItclFreeC(
ClientData clientData, /* associated data */
TCL_UNUSED(Tcl_Interp *)) /* interpreter being deleted */
{
Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData;
Tcl_HashSearch place;
Tcl_HashEntry *entry;
ItclCfunc *cfunc;
entry = Tcl_FirstHashEntry(tablePtr, &place);
while (entry) {
cfunc = (ItclCfunc*)Tcl_GetHashValue(entry);
if (cfunc->deleteProc != NULL) {
(*cfunc->deleteProc)(cfunc->clientData);
}
ckfree ( (char*)cfunc );
entry = Tcl_NextHashEntry(&place);
}
Tcl_DeleteHashTable(tablePtr);
ckfree((char*)tablePtr);
}

2718
pkgs/itcl4.2.2/generic/itclMethod.c Normal file
View File

File diff suppressed because it is too large Load Diff

250
pkgs/itcl4.2.2/generic/itclMigrate2TclCore.c Normal file
View File

@@ -0,0 +1,250 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tcl]
* DESCRIPTION: Object-Oriented Extensions to Tcl
*
* This file contains procedures that belong in the Tcl/Tk core.
* Hopefully, they'll migrate there soon.
*
* ========================================================================
* AUTHOR: Arnulf Wiedemann
*
* ========================================================================
* 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 <tclInt.h>
#include "itclInt.h"
int
Itcl_SetCallFrameResolver(
Tcl_Interp *interp,
Tcl_Resolve *resolvePtr)
{
CallFrame *framePtr = ((Interp *)interp)->framePtr;
if (framePtr != NULL) {
#ifdef ITCL_USE_MODIFIED_TCL_H
framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER;
framePtr->resolvePtr = resolvePtr;
#elif defined(__cplusplus)
(void)resolvePtr;
#endif
return TCL_OK;
}
return TCL_ERROR;
}
int
_Tcl_SetNamespaceResolver(
Tcl_Namespace *nsPtr,
Tcl_Resolve *resolvePtr)
{
if (nsPtr == NULL) {
return TCL_ERROR;
}
#ifdef ITCL_USE_MODIFIED_TCL_H
((Namespace *)nsPtr)->resolvePtr = resolvePtr;
#elif defined(__cplusplus)
(void)resolvePtr;
#endif
return TCL_OK;
}
Tcl_Var
Tcl_NewNamespaceVar(
TCL_UNUSED(Tcl_Interp *),
Tcl_Namespace *nsPtr,
const char *varName)
{
Var *varPtr = NULL;
int isNew;
if ((nsPtr == NULL) || (varName == NULL)) {
return NULL;
}
varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable,
varName, &isNew);
TclSetVarNamespaceVar(varPtr);
return (Tcl_Var)varPtr;
}
void
Itcl_PreserveVar(
Tcl_Var var)
{
Var *varPtr = (Var *)var;
VarHashRefCount(varPtr)++;
}
void
Itcl_ReleaseVar(
Tcl_Var var)
{
Var *varPtr = (Var *)var;
VarHashRefCount(varPtr)--;
TclCleanupVar(varPtr, NULL);
}
Tcl_CallFrame *
Itcl_GetUplevelCallFrame(
Tcl_Interp *interp,
int level)
{
CallFrame *framePtr;
if (level < 0) {
return NULL;
}
framePtr = ((Interp *)interp)->varFramePtr;
while ((framePtr != NULL) && (level-- > 0)) {
framePtr = framePtr->callerVarPtr;
}
if (framePtr == NULL) {
return NULL;
}
return (Tcl_CallFrame *)framePtr;
}
Tcl_CallFrame *
Itcl_ActivateCallFrame(
Tcl_Interp *interp,
Tcl_CallFrame *framePtr)
{
Interp *iPtr = (Interp*)interp;
CallFrame *oldFramePtr;
oldFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = (CallFrame *) framePtr;
return (Tcl_CallFrame *) oldFramePtr;
}
Tcl_Namespace *
Itcl_GetUplevelNamespace(
Tcl_Interp *interp,
int level)
{
CallFrame *framePtr;
if (level < 0) {
return NULL;
}
framePtr = ((Interp *)interp)->framePtr;
while ((framePtr != NULL) && (level-- > 0)) {
framePtr = framePtr->callerVarPtr;
}
if (framePtr == NULL) {
return NULL;
}
return (Tcl_Namespace *)framePtr->nsPtr;
}
ClientData
Itcl_GetCallFrameClientData(
Tcl_Interp *interp)
{
/* suggested fix for SF bug #250 use varFramePtr instead of framePtr
* seems to have no side effect concerning test suite, but does NOT fix the bug
*/
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
if (framePtr == NULL) {
return NULL;
}
return framePtr->clientData;
}
int
Itcl_SetCallFrameNamespace(
Tcl_Interp *interp,
Tcl_Namespace *nsPtr)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
if (framePtr == NULL) {
return TCL_ERROR;
}
((Interp *)interp)->varFramePtr->nsPtr = (Namespace *)nsPtr;
return TCL_OK;
}
int
Itcl_GetCallVarFrameObjc(
Tcl_Interp *interp)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
if (framePtr == NULL) {
return 0;
}
return framePtr->objc;
}
Tcl_Obj * const *
Itcl_GetCallVarFrameObjv(
Tcl_Interp *interp)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
if (framePtr == NULL) {
return NULL;
}
return framePtr->objv;
}
int
Itcl_GetCallFrameObjc(
Tcl_Interp *interp)
{
CallFrame *framePtr = ((Interp *)interp)->framePtr;
if (framePtr == NULL) {
return 0;
}
return ((Interp *)interp)->framePtr->objc;
}
Tcl_Obj * const *
Itcl_GetCallFrameObjv(
Tcl_Interp *interp)
{
CallFrame *framePtr = ((Interp *)interp)->framePtr;
if (framePtr == NULL) {
return NULL;
}
return ((Interp *)interp)->framePtr->objv;
}
int
Itcl_IsCallFrameArgument(
Tcl_Interp *interp,
const char *name)
{
CallFrame *varFramePtr = ((Interp *)interp)->framePtr;
Proc *procPtr;
if (varFramePtr == NULL) {
return 0;
}
if (!varFramePtr->isProcCallFrame) {
return 0;
}
procPtr = varFramePtr->procPtr;
/*
* Search through compiled locals first...
*/
if (procPtr) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
int nameLen = strlen(name);
for (;localPtr != NULL; localPtr = localPtr->nextPtr) {
if (TclIsVarArgument(localPtr)) {
char *localName = localPtr->name;
if ((name[0] == localName[0])
&& (nameLen == localPtr->nameLength)
&& (strcmp(name, localName) == 0)) {
return 1;
}
}
}
}
return 0;
}

83
pkgs/itcl4.2.2/generic/itclMigrate2TclCore.h Normal file
View File

@@ -0,0 +1,83 @@
#ifndef ITCL_USE_MODIFIED_TCL_H
/* this is just to provide the definition. This struct is only used if
* infoPtr->useOldResolvers == 0 which is not the default
*/
#define FRAME_HAS_RESOLVER 0x100
typedef Tcl_Command (Tcl_CmdAliasProc)(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *cmdName,
ClientData clientData);
typedef Tcl_Var (Tcl_VarAliasProc)(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *varName,
ClientData clientData);
#ifndef _TCL_RESOLVE_DEFINED
typedef struct Tcl_Resolve {
Tcl_VarAliasProc *varProcPtr;
Tcl_CmdAliasProc *cmdProcPtr;
ClientData clientData;
} Tcl_Resolve;
#define _TCL_RESOLVE_DEFINED 1
#endif
#endif
#ifndef _TCLINT
struct Tcl_ResolvedVarInfo;
typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp,
struct Tcl_ResolvedVarInfo *vinfoPtr);
typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr);
/*
* The following structure encapsulates the routines needed to resolve a
* variable reference at runtime. Any variable specific state will typically
* be appended to this structure.
*/
typedef struct Tcl_ResolvedVarInfo {
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp *interp,
const char *name, int length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
typedef int (Tcl_ResolveVarProc) (Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
typedef int (Tcl_ResolveCmdProc) (Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
typedef struct Tcl_ResolverInfo {
Tcl_ResolveCmdProc *cmdResProc;
/* Procedure handling command name
* resolution. */
Tcl_ResolveVarProc *varResProc;
/* Procedure handling variable name resolution
* for variables that can only be handled at
* runtime. */
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* Procedure handling variable name resolution
* at compile time. */
} Tcl_ResolverInfo;
#endif
/* here come the definitions for code which should be migrated to Tcl core */
/* these functions DO NOT exist and are not published */
#ifndef _TCL_PROC_DEFINED
typedef struct Tcl_Proc_ *Tcl_Proc;
#define _TCL_PROC_DEFINED 1
#endif
MODULE_SCOPE Tcl_Var Tcl_NewNamespaceVar(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *varName);
MODULE_SCOPE void Itcl_PreserveVar(Tcl_Var var);
MODULE_SCOPE void Itcl_ReleaseVar(Tcl_Var var);
MODULE_SCOPE int Itcl_IsCallFrameArgument(Tcl_Interp *interp, const char *name);
MODULE_SCOPE int Itcl_GetCallVarFrameObjc(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * const * Itcl_GetCallVarFrameObjv(Tcl_Interp *interp);
#define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver
MODULE_SCOPE int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr,
struct Tcl_Resolve *resolvePtr);

3753
pkgs/itcl4.2.2/generic/itclObject.c Normal file
View File

File diff suppressed because it is too large Load Diff

4306
pkgs/itcl4.2.2/generic/itclParse.c Normal file
View File

File diff suppressed because it is too large Load Diff

693
pkgs/itcl4.2.2/generic/itclResolve.c Normal file
View File

@@ -0,0 +1,693 @@
/*
* ------------------------------------------------------------------------
* 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 command and variable resolution
*
* ========================================================================
* AUTHOR: Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* mmclennan@lucent.com
* http://www.tcltk.com/itcl
* ========================================================================
* 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"
/*
* This structure is a subclass of Tcl_ResolvedVarInfo that contains the
* ItclVarLookup info needed at runtime.
*/
typedef struct ItclResolvedVarInfo {
Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */
ItclVarLookup *vlookup; /* Pointer to lookup info. */
} ItclResolvedVarInfo;
static Tcl_Var ItclClassRuntimeVarResolver(
Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr);
/*
* ------------------------------------------------------------------------
* Itcl_ClassCmdResolver()
*
* Used by the class namespaces to handle name resolution for all
* commands. This procedure looks for references to class methods
* and procs, and returns TCL_OK along with the appropriate Tcl
* command in the rPtr argument. If a particular command is private,
* this procedure returns TCL_ERROR and access to the command is
* denied. If a command is not recognized, this procedure returns
* TCL_CONTINUE, and lookup continues via the normal Tcl name
* resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCmdResolver(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the command being accessed */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
int flags, /* TCL_LEAVE_ERR_MSG => leave error messages
* in interp if anything goes wrong */
Tcl_Command *rPtr) /* returns: resolved command */
{
Tcl_HashEntry *hPtr;
Tcl_Obj *objPtr;
Tcl_Obj *namePtr;
ItclClass *iclsPtr;
ItclObjectInfo *infoPtr;
ItclMemberFunc *imPtr;
int inOptionHandling;
int isCmdDeleted;
if ((name[0] == 't') && (strcmp(name, "this") == 0)) {
return TCL_CONTINUE;
}
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
/*
* If the command is a member function
*/
imPtr = NULL;
objPtr = Tcl_NewStringObj(name, -1);
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
Tcl_DecrRefCount(objPtr);
if (hPtr == NULL) {
ItclCmdLookup *clookup;
if ((iclsPtr->flags & ITCL_ECLASS)) {
namePtr = Tcl_NewStringObj(name, -1);
hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions,
(char *)namePtr);
if (hPtr != NULL) {
objPtr = Tcl_NewStringObj("unknown", -1);
hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr);
Tcl_DecrRefCount(objPtr);
}
Tcl_DecrRefCount(namePtr);
}
if (hPtr == NULL) {
return TCL_CONTINUE;
}
clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
imPtr = clookup->imPtr;
} else {
ItclCmdLookup *clookup;
clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr);
imPtr = clookup->imPtr;
}
if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) {
/* FIXME check if called from an (instance) method (not from a typemethod) and only then error */
int isOk = 0;
if (strcmp(name, "info") == 0) {
isOk = 1;
}
if (strcmp(name, "mytypemethod") == 0) {
isOk = 1;
}
if (strcmp(name, "myproc") == 0) {
isOk = 1;
}
if (strcmp(name, "mymethod") == 0) {
isOk = 1;
}
if (strcmp(name, "mytypevar") == 0) {
isOk = 1;
}
if (strcmp(name, "myvar") == 0) {
isOk = 1;
}
if (strcmp(name, "itcl_hull") == 0) {
isOk = 1;
}
if (strcmp(name, "callinstance") == 0) {
isOk = 1;
}
if (strcmp(name, "getinstancevar") == 0) {
isOk = 1;
}
if (strcmp(name, "installcomponent") == 0) {
isOk = 1;
}
if (! isOk) {
if ((imPtr->flags & ITCL_TYPE_METHOD) != 0) {
Tcl_AppendResult(interp, "invalid command name \"", name,
"\"", NULL);
return TCL_ERROR;
}
inOptionHandling = imPtr->iclsPtr->infoPtr->inOptionHandling;
if (((imPtr->flags & ITCL_COMMON) == 0) && !inOptionHandling) {
/* a method cannot be called directly in ITCL_TYPE
* so look, if there is a corresponding proc in the
* namespace one level up (i.e. for example ::). If yes
* use that.
*/
Tcl_Namespace *nsPtr2;
Tcl_Command cmdPtr;
nsPtr2 = Itcl_GetUplevelNamespace(interp, 1);
cmdPtr = NULL;
if (nsPtr != nsPtr2) {
cmdPtr = Tcl_FindCommand(interp, name, nsPtr2, 0);
}
if (cmdPtr != NULL) {
*rPtr = cmdPtr;
return TCL_OK;
}
Tcl_AppendResult(interp, "invalid command name \"", name,
"\"", NULL);
return TCL_ERROR;
}
}
}
/*
* Looks like we found an accessible member function.
*
* TRICKY NOTE: Check to make sure that the command handle
* is still valid. If someone has deleted or renamed the
* command, it may not be. This is just the time to catch
* it--as it is being resolved again by the compiler.
*/
/*
* The following #if is needed so itcl can be compiled with
* all versions of Tcl. The integer "deleted" was renamed to
* "flags" in tcl8.4a2. This #if is also found in itcl_ensemble.c .
* We're using a runtime check with itclCompatFlags to adjust for
* the behavior of this change, too.
*
*/
/* FIXME !!! */
isCmdDeleted = 0;
/* isCmdDeleted = (!imPtr->accessCmd || imPtr->accessCmd->flags); */
if (isCmdDeleted) {
imPtr->accessCmd = NULL;
if ((flags & TCL_LEAVE_ERR_MSG) != 0) {
Tcl_AppendResult(interp,
"can't access \"", name, "\": deleted or redefined\n",
"(use the \"body\" command to redefine methods/procs)",
NULL);
}
return TCL_ERROR; /* disallow access! */
}
*rPtr = imPtr->accessCmd;
return TCL_OK;
}
/* #define VAR_DEBUG */
/*
* ------------------------------------------------------------------------
* Itcl_ClassVarResolver()
*
* Used by the class namespaces to handle name resolution for runtime
* variable accesses. This procedure looks for references to both
* common variables and instance variables at runtime. It is used as
* a second line of defense, to handle references that could not be
* resolved as compiled locals.
*
* If a variable is found, this procedure returns TCL_OK along with
* the appropriate Tcl variable in the rPtr argument. If a particular
* variable is private, this procedure returns TCL_ERROR and access
* to the variable is denied. If a variable is not recognized, this
* procedure returns TCL_CONTINUE, and lookup continues via the normal
* Tcl name resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassVarResolver(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the variable being accessed */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
int flags, /* TCL_LEAVE_ERR_MSG => leave error messages
* in interp if anything goes wrong */
Tcl_Var *rPtr) /* returns: resolved variable */
{
ItclObjectInfo *infoPtr;
ItclClass *iclsPtr;
ItclObject *contextIoPtr;
Tcl_HashEntry *hPtr;
ItclVarLookup *vlookup;
contextIoPtr = NULL;
/*
* If this is a global variable, handle it in the usual
* Tcl manner.
*/
if (flags & TCL_GLOBAL_ONLY) {
return TCL_CONTINUE;
}
/*
* See if this is a formal parameter in the current proc scope.
* If so, that variable has precedence.
*/
if ((strstr(name,"::") == NULL) &&
Itcl_IsCallFrameArgument(interp, name)) {
return TCL_CONTINUE;
}
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
/*
* See if the variable is a known data member and accessible.
*/
hPtr = ItclResolveVarEntry(iclsPtr, name);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
if (!vlookup->accessible) {
return TCL_CONTINUE;
}
/*
* If this is a common data member, then its variable
* is easy to find. Return it directly.
*/
if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) {
hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
(char *)vlookup->ivPtr);
if (hPtr != NULL) {
*rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
return TCL_OK;
}
}
/*
* If this is an instance variable, then we have to
* find the object context,
*/
if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr)
|| (contextIoPtr == NULL)) {
return TCL_CONTINUE;
}
/* Check that the object hasn't already been destroyed. */
hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) {
if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) {
hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr,
Tcl_GetString(vlookup->ivPtr->namePtr));
if (hPtr != NULL) {
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
}
}
}
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables,
(char *)vlookup->ivPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
if (strcmp(name, "this") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) {
/* deletion of class is running */
Tcl_DStringAppend(&buffer,
Tcl_GetCurrentNamespace(interp)->fullName, -1);
} else {
Tcl_DStringAppend(&buffer,
vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1);
}
Tcl_DStringAppend(&buffer, "::this", 6);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0);
if (varPtr != NULL) {
*rPtr = varPtr;
return TCL_OK;
}
}
if (strcmp(name, "itcl_options") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
Tcl_DStringAppend(&buffer, "::itcl_options", -1);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0);
Tcl_DStringFree(&buffer);
if (varPtr != NULL) {
*rPtr = varPtr;
return TCL_OK;
}
}
if (strcmp(name, "itcl_option_components") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
Tcl_DStringAppend(&buffer, "::itcl_option_components", -1);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0);
Tcl_DStringFree(&buffer);
if (varPtr != NULL) {
*rPtr = varPtr;
return TCL_OK;
}
}
if (hPtr != NULL) {
*rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
return TCL_OK;
}
return TCL_CONTINUE;
}
/*
* ------------------------------------------------------------------------
* Itcl_ClassCompiledVarResolver()
*
* Used by the class namespaces to handle name resolution for compile
* time variable accesses. This procedure looks for references to
* both common variables and instance variables at compile time. If
* the variables are found, they are characterized in a generic way
* by their ItclVarLookup record. At runtime, Tcl constructs the
* compiled local variables by calling ItclClassRuntimeVarResolver.
*
* If a variable is found, this procedure returns TCL_OK along with
* information about the variable in the rPtr argument. If a particular
* variable is private, this procedure returns TCL_ERROR and access
* to the variable is denied. If a variable is not recognized, this
* procedure returns TCL_CONTINUE, and lookup continues via the normal
* Tcl name resolution rules.
* ------------------------------------------------------------------------
*/
int
Itcl_ClassCompiledVarResolver(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the variable being accessed */
int length, /* number of characters in name */
Tcl_Namespace *nsPtr, /* namespace performing the resolution */
Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to
* resolve the variable at runtime */
{
ItclClass *iclsPtr;
ItclObjectInfo *infoPtr;
Tcl_HashEntry *hPtr;
ItclVarLookup *vlookup;
char *buffer;
char storage[64];
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp,
ITCL_INTERP_DATA, NULL);
hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr);
if (hPtr == NULL) {
return TCL_CONTINUE;
}
iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr);
/*
* Copy the name to local storage so we can NULL terminate it.
* If the name is long, allocate extra space for it.
*/
if ((unsigned int)length < sizeof(storage)) {
buffer = storage;
} else {
buffer = (char*)ckalloc((unsigned)(length+1));
}
memcpy((void*)buffer, (void*)name, (size_t)length);
buffer[length] = '\0';
hPtr = ItclResolveVarEntry(iclsPtr, buffer);
if (buffer != storage) {
ckfree(buffer);
}
/*
* If the name is not found, or if it is inaccessible,
* continue on with the normal Tcl name resolution rules.
*/
if (hPtr == NULL) {
return TCL_CONTINUE;
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
if (!vlookup->accessible) {
return TCL_CONTINUE;
}
/*
* Return the ItclVarLookup record. At runtime, Tcl will
* call ItclClassRuntimeVarResolver with this record, to
* plug in the appropriate variable for the current object
* context.
*/
(*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo));
(*rPtr)->fetchProc = ItclClassRuntimeVarResolver;
(*rPtr)->deleteProc = NULL;
((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup;
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclClassRuntimeVarResolver()
*
* Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc
* at runtime. Resolves data members identified earlier by
* Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation
* for the data member.
* ------------------------------------------------------------------------
*/
static Tcl_Var
ItclClassRuntimeVarResolver(
Tcl_Interp *interp, /* current interpreter */
Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep
* for variable */
{
ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup;
ItclClass *iclsPtr;
ItclObject *contextIoPtr;
Tcl_HashEntry *hPtr;
/*
* If this is a common data member, then the associated
* variable is known directly.
*/
if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) {
hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
(char *)vlookup->ivPtr);
if (hPtr != NULL) {
return (Tcl_Var)Tcl_GetHashValue(hPtr);
}
}
/*
* Otherwise, get the current object context and find the
* variable in its data table.
*
* TRICKY NOTE: Get the index for this variable using the
* virtual table for the MOST-SPECIFIC class.
*/
if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr)
|| (contextIoPtr == NULL)) {
return NULL;
}
if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) {
if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) {
/* only for the this variable we need the one of the
* contextIoPtr class */
hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr,
Tcl_GetString(vlookup->ivPtr->namePtr));
if (hPtr != NULL) {
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
}
}
}
hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables,
(char *)vlookup->ivPtr);
if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) {
Tcl_DStringAppend(&buffer,
Tcl_GetCurrentNamespace(interp)->fullName, -1);
} else {
Tcl_DStringAppend(&buffer,
vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1);
}
Tcl_DStringAppend(&buffer, "::this", 6);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer),
NULL, 0);
if (varPtr != NULL) {
return varPtr;
}
}
if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr),
"itcl_options") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
Tcl_DStringAppend(&buffer, "::itcl_options", -1);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer),
NULL, 0);
Tcl_DStringFree(&buffer);
if (varPtr != NULL) {
return varPtr;
}
}
if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr),
"itcl_option_components") == 0) {
Tcl_Var varPtr;
Tcl_DString buffer;
Tcl_DStringInit(&buffer);
Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1);
Tcl_DStringAppend(&buffer,
(Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1);
Tcl_DStringAppend(&buffer, "::itcl_option_components", -1);
varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer),
NULL, 0);
Tcl_DStringFree(&buffer);
if (varPtr != NULL) {
return varPtr;
}
}
if (hPtr != NULL) {
return (Tcl_Var)Tcl_GetHashValue(hPtr);
}
return NULL;
}
/*
* ------------------------------------------------------------------------
* Itcl_ParseVarResolver()
*
* Used by the "parser" namespace to resolve variable accesses to
* common variables. The runtime resolver procedure is consulted
* whenever a variable is accessed within the namespace. It can
* deny access to certain variables, or perform special lookups itself.
*
* This procedure allows access only to "common" class variables that
* have been declared within the class or inherited from another class.
* A "set" command can be used to initialized common data members within
* the body of the class definition itself:
*
* itcl::class Foo {
* common colors
* set colors(red) #ff0000
* set colors(green) #00ff00
* set colors(blue) #0000ff
* ...
* }
*
* itcl::class Bar {
* inherit Foo
* set colors(gray) #a0a0a0
* set colors(white) #ffffff
*
* common numbers
* set numbers(0) zero
* set numbers(1) one
* }
*
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
int
Itcl_ParseVarResolver(
Tcl_Interp *interp, /* current interpreter */
const char* name, /* name of the variable being accessed */
Tcl_Namespace *contextNs, /* namespace context */
int flags, /* TCL_GLOBAL_ONLY => global variable
* TCL_NAMESPACE_ONLY => namespace variable */
Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */
{
ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData;
ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack);
Tcl_HashEntry *hPtr;
ItclVarLookup *vlookup;
(void)flags;
/*
* See if the requested variable is a recognized "common" member.
* If it is, make sure that access is allowed.
*/
hPtr = ItclResolveVarEntry(iclsPtr, name);
if (!hPtr) {
return TCL_CONTINUE;
}
vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr);
if ((vlookup->ivPtr->flags & ITCL_COMMON) == 0) {
return TCL_CONTINUE;
}
if (!vlookup->accessible) {
Tcl_AppendResult(interp,
"can't access \"", name, "\": ",
Itcl_ProtectionStr(vlookup->ivPtr->protection),
" variable", NULL);
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons,
(char *)vlookup->ivPtr);
if (!hPtr) {
return TCL_CONTINUE;
}
*rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr);
return TCL_OK;
}
int
ItclSetParserResolver(
Tcl_Namespace *nsPtr)
{
Itcl_SetNamespaceResolvers(nsPtr, NULL,
Itcl_ParseVarResolver, NULL);
return TCL_OK;
}

242
pkgs/itcl4.2.2/generic/itclStubInit.c Normal file
View File

@@ -0,0 +1,242 @@
/*
* This file is (mostly) automatically generated from itcl.decls.
* It is compiled and linked in with the itcl package proper.
*/
#include "itclInt.h"
MODULE_SCOPE const ItclStubs itclStubs;
/* !BEGIN!: Do not edit below this line. */
static const ItclIntStubs itclIntStubs = {
TCL_STUB_MAGIC,
ITCLINT_STUBS_EPOCH,
ITCLINT_STUBS_REVISION,
0,
Itcl_IsClassNamespace, /* 0 */
Itcl_IsClass, /* 1 */
Itcl_FindClass, /* 2 */
Itcl_FindObject, /* 3 */
Itcl_IsObject, /* 4 */
Itcl_ObjectIsa, /* 5 */
Itcl_Protection, /* 6 */
Itcl_ProtectionStr, /* 7 */
Itcl_CanAccess, /* 8 */
Itcl_CanAccessFunc, /* 9 */
0, /* 10 */
Itcl_ParseNamespPath, /* 11 */
Itcl_DecodeScopedCommand, /* 12 */
Itcl_EvalArgs, /* 13 */
Itcl_CreateArgs, /* 14 */
0, /* 15 */
0, /* 16 */
Itcl_GetContext, /* 17 */
Itcl_InitHierIter, /* 18 */
Itcl_DeleteHierIter, /* 19 */
Itcl_AdvanceHierIter, /* 20 */
Itcl_FindClassesCmd, /* 21 */
Itcl_FindObjectsCmd, /* 22 */
0, /* 23 */
Itcl_DelClassCmd, /* 24 */
Itcl_DelObjectCmd, /* 25 */
Itcl_ScopeCmd, /* 26 */
Itcl_CodeCmd, /* 27 */
Itcl_StubCreateCmd, /* 28 */
Itcl_StubExistsCmd, /* 29 */
Itcl_IsStub, /* 30 */
Itcl_CreateClass, /* 31 */
Itcl_DeleteClass, /* 32 */
Itcl_FindClassNamespace, /* 33 */
Itcl_HandleClass, /* 34 */
0, /* 35 */
0, /* 36 */
0, /* 37 */
Itcl_BuildVirtualTables, /* 38 */
Itcl_CreateVariable, /* 39 */
Itcl_DeleteVariable, /* 40 */
Itcl_GetCommonVar, /* 41 */
0, /* 42 */
0, /* 43 */
Itcl_CreateObject, /* 44 */
Itcl_DeleteObject, /* 45 */
Itcl_DestructObject, /* 46 */
0, /* 47 */
Itcl_GetInstanceVar, /* 48 */
0, /* 49 */
Itcl_BodyCmd, /* 50 */
Itcl_ConfigBodyCmd, /* 51 */
Itcl_CreateMethod, /* 52 */
Itcl_CreateProc, /* 53 */
Itcl_CreateMemberFunc, /* 54 */
Itcl_ChangeMemberFunc, /* 55 */
Itcl_DeleteMemberFunc, /* 56 */
Itcl_CreateMemberCode, /* 57 */
Itcl_DeleteMemberCode, /* 58 */
Itcl_GetMemberCode, /* 59 */
0, /* 60 */
Itcl_EvalMemberCode, /* 61 */
0, /* 62 */
0, /* 63 */
0, /* 64 */
0, /* 65 */
0, /* 66 */
Itcl_GetMemberFuncUsage, /* 67 */
Itcl_ExecMethod, /* 68 */
Itcl_ExecProc, /* 69 */
0, /* 70 */
Itcl_ConstructBase, /* 71 */
Itcl_InvokeMethodIfExists, /* 72 */
0, /* 73 */
Itcl_ReportFuncErrors, /* 74 */
Itcl_ParseInit, /* 75 */
Itcl_ClassCmd, /* 76 */
Itcl_ClassInheritCmd, /* 77 */
Itcl_ClassProtectionCmd, /* 78 */
Itcl_ClassConstructorCmd, /* 79 */
Itcl_ClassDestructorCmd, /* 80 */
Itcl_ClassMethodCmd, /* 81 */
Itcl_ClassProcCmd, /* 82 */
Itcl_ClassVariableCmd, /* 83 */
Itcl_ClassCommonCmd, /* 84 */
Itcl_ParseVarResolver, /* 85 */
Itcl_BiInit, /* 86 */
Itcl_InstallBiMethods, /* 87 */
Itcl_BiIsaCmd, /* 88 */
Itcl_BiConfigureCmd, /* 89 */
Itcl_BiCgetCmd, /* 90 */
Itcl_BiChainCmd, /* 91 */
Itcl_BiInfoClassCmd, /* 92 */
Itcl_BiInfoInheritCmd, /* 93 */
Itcl_BiInfoHeritageCmd, /* 94 */
Itcl_BiInfoFunctionCmd, /* 95 */
Itcl_BiInfoVariableCmd, /* 96 */
Itcl_BiInfoBodyCmd, /* 97 */
Itcl_BiInfoArgsCmd, /* 98 */
0, /* 99 */
Itcl_EnsembleInit, /* 100 */
Itcl_CreateEnsemble, /* 101 */
Itcl_AddEnsemblePart, /* 102 */
Itcl_GetEnsemblePart, /* 103 */
Itcl_IsEnsemble, /* 104 */
Itcl_GetEnsembleUsage, /* 105 */
Itcl_GetEnsembleUsageForObj, /* 106 */
Itcl_EnsembleCmd, /* 107 */
Itcl_EnsPartCmd, /* 108 */
Itcl_EnsembleErrorCmd, /* 109 */
0, /* 110 */
0, /* 111 */
0, /* 112 */
0, /* 113 */
0, /* 114 */
Itcl_Assert, /* 115 */
Itcl_IsObjectCmd, /* 116 */
Itcl_IsClassCmd, /* 117 */
0, /* 118 */
0, /* 119 */
0, /* 120 */
0, /* 121 */
0, /* 122 */
0, /* 123 */
0, /* 124 */
0, /* 125 */
0, /* 126 */
0, /* 127 */
0, /* 128 */
0, /* 129 */
0, /* 130 */
0, /* 131 */
0, /* 132 */
0, /* 133 */
0, /* 134 */
0, /* 135 */
0, /* 136 */
0, /* 137 */
0, /* 138 */
0, /* 139 */
Itcl_FilterAddCmd, /* 140 */
Itcl_FilterDeleteCmd, /* 141 */
Itcl_ForwardAddCmd, /* 142 */
Itcl_ForwardDeleteCmd, /* 143 */
Itcl_MixinAddCmd, /* 144 */
Itcl_MixinDeleteCmd, /* 145 */
0, /* 146 */
0, /* 147 */
0, /* 148 */
0, /* 149 */
0, /* 150 */
Itcl_BiInfoUnknownCmd, /* 151 */
Itcl_BiInfoVarsCmd, /* 152 */
Itcl_CanAccess2, /* 153 */
0, /* 154 */
0, /* 155 */
0, /* 156 */
0, /* 157 */
0, /* 158 */
0, /* 159 */
Itcl_SetCallFrameResolver, /* 160 */
ItclEnsembleSubCmd, /* 161 */
Itcl_GetUplevelNamespace, /* 162 */
Itcl_GetCallFrameClientData, /* 163 */
0, /* 164 */
Itcl_SetCallFrameNamespace, /* 165 */
Itcl_GetCallFrameObjc, /* 166 */
Itcl_GetCallFrameObjv, /* 167 */
Itcl_NWidgetCmd, /* 168 */
Itcl_AddOptionCmd, /* 169 */
Itcl_AddComponentCmd, /* 170 */
Itcl_BiInfoOptionCmd, /* 171 */
Itcl_BiInfoComponentCmd, /* 172 */
Itcl_RenameCommand, /* 173 */
Itcl_PushCallFrame, /* 174 */
Itcl_PopCallFrame, /* 175 */
Itcl_GetUplevelCallFrame, /* 176 */
Itcl_ActivateCallFrame, /* 177 */
ItclSetInstanceVar, /* 178 */
ItclCapitalize, /* 179 */
ItclClassBaseCmd, /* 180 */
ItclCreateComponent, /* 181 */
Itcl_SetContext, /* 182 */
Itcl_UnsetContext, /* 183 */
ItclGetInstanceVar, /* 184 */
};
static const ItclStubHooks itclStubHooks = {
&itclIntStubs
};
const ItclStubs itclStubs = {
TCL_STUB_MAGIC,
ITCL_STUBS_EPOCH,
ITCL_STUBS_REVISION,
&itclStubHooks,
0, /* 0 */
0, /* 1 */
Itcl_RegisterC, /* 2 */
Itcl_RegisterObjC, /* 3 */
Itcl_FindC, /* 4 */
Itcl_InitStack, /* 5 */
Itcl_DeleteStack, /* 6 */
Itcl_PushStack, /* 7 */
Itcl_PopStack, /* 8 */
Itcl_PeekStack, /* 9 */
Itcl_GetStackValue, /* 10 */
Itcl_InitList, /* 11 */
Itcl_DeleteList, /* 12 */
Itcl_CreateListElem, /* 13 */
Itcl_DeleteListElem, /* 14 */
Itcl_InsertList, /* 15 */
Itcl_InsertListElem, /* 16 */
Itcl_AppendList, /* 17 */
Itcl_AppendListElem, /* 18 */
Itcl_SetListValue, /* 19 */
Itcl_EventuallyFree, /* 20 */
Itcl_PreserveData, /* 21 */
Itcl_ReleaseData, /* 22 */
Itcl_SaveInterpState, /* 23 */
Itcl_RestoreInterpState, /* 24 */
Itcl_DiscardInterpState, /* 25 */
Itcl_Alloc, /* 26 */
Itcl_Free, /* 27 */
};
/* !END!: Do not edit above this line. */

69
pkgs/itcl4.2.2/generic/itclStubLib.c Normal file
View File

@@ -0,0 +1,69 @@
/*
* SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
*/
#define USE_TCL_STUBS 1
#define USE_ITCL_STUBS 1
#include "itclInt.h"
#undef Itcl_InitStubs
MODULE_SCOPE const ItclStubs *itclStubsPtr;
MODULE_SCOPE const ItclIntStubs *itclIntStubsPtr;
const ItclStubs *itclStubsPtr = NULL;
const ItclIntStubs *itclIntStubsPtr = NULL;
/*
*----------------------------------------------------------------------
*
* Itcl_InitStubs --
* Load the tclOO package, initialize stub table pointer. Do not call
* this function directly, use Itcl_InitStubs() macro instead.
*
* Results:
* The actual version of the package that satisfies the request, or
* NULL to indicate that an error occurred.
*
* Side effects:
* Sets the stub table pointer.
*
*/
const char *
Itcl_InitStubs(
Tcl_Interp *interp,
const char *version,
int exact)
{
const char *packageName = "itcl";
const char *errMsg = NULL;
ClientData clientData = NULL;
const ItclStubs *stubsPtr;
const ItclIntStubs *intStubsPtr;
const char *actualVersion;
actualVersion =
Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData);
stubsPtr = (const ItclStubs *)clientData;
if ((actualVersion == NULL) || (clientData == NULL)) {
return NULL;
}
intStubsPtr = stubsPtr->hooks ?
stubsPtr->hooks->itclIntStubs : NULL;
if (!stubsPtr || !intStubsPtr) {
errMsg = "missing stub table pointer";
goto error;
}
itclStubsPtr = stubsPtr;
itclIntStubsPtr = intStubsPtr;
return actualVersion;
error:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "Error loading ", packageName, " package",
" (requested version '", version, "', loaded version '",
actualVersion, "'): ", errMsg, NULL);
return NULL;
}

231
pkgs/itcl4.2.2/generic/itclStubs.c Normal file
View File

@@ -0,0 +1,231 @@
/*
* itclStubs.c --
*
* This file contains the C-implemeted part of Itcl object-system
* Itcl
*
* Copyright (c) 2006 by Arnulf P. Wiedemann
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "itclInt.h"
static void ItclDeleteStub(ClientData cdata);
static int ItclHandleStubCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]);
/*
* ------------------------------------------------------------------------
* Itcl_IsStub()
*
* Checks the given Tcl command to see if it represents an autoloading
* stub created by the "stub create" command. Returns non-zero if
* the command is indeed a stub.
* ------------------------------------------------------------------------
*/
int
Itcl_IsStub(
Tcl_Command cmdPtr) /* command being tested */
{
Tcl_CmdInfo cmdInfo;
/*
* This may be an imported command, but don't try to get the
* original. Just check to see if this particular command
* is a stub. If we really want the original command, we'll
* find it at a higher level.
*/
if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) == 1) {
if (cmdInfo.deleteProc == ItclDeleteStub) {
return 1;
}
}
return 0;
}
/*
* ------------------------------------------------------------------------
* Itcl_StubCreateCmd()
*
* Invoked by Tcl whenever the user issues a "stub create" command to
* create an autoloading stub for imported commands. Handles the
* following syntax:
*
* stub create <name>
*
* Creates a command called <name>. Executing this command will cause
* the real command <name> to be autoloaded.
* ------------------------------------------------------------------------
*/
int
Itcl_StubCreateCmd(
TCL_UNUSED(ClientData), /* not used */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Command cmdPtr;
char *cmdName;
Tcl_CmdInfo cmdInfo;
ItclShowArgs(1, "Itcl_StubCreateCmd", objc, objv);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
cmdName = Tcl_GetString(objv[1]);
/*
* Create a stub command with the characteristic ItclDeleteStub
* procedure. That way, we can recognize this command later
* on as a stub. Save the cmd token as client data, so we can
* get the full name of this command later on.
*/
cmdPtr = Tcl_CreateObjCommand(interp, cmdName,
ItclHandleStubCmd, NULL,
(Tcl_CmdDeleteProc*)ItclDeleteStub);
Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo);
cmdInfo.objClientData = cmdPtr;
Tcl_SetCommandInfoFromToken(cmdPtr, &cmdInfo);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itcl_StubExistsCmd()
*
* Invoked by Tcl whenever the user issues a "stub exists" command to
* see if an existing command is an autoloading stub. Handles the
* following syntax:
*
* stub exists <name>
*
* Looks for a command called <name> and checks to see if it is an
* autoloading stub. Returns a boolean result.
* ------------------------------------------------------------------------
*/
int
Itcl_StubExistsCmd(
TCL_UNUSED(ClientData), /* not used */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Command cmdPtr;
char *cmdName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
cmdName = Tcl_GetString(objv[1]);
cmdPtr = Tcl_FindCommand(interp, cmdName, NULL, 0);
if ((cmdPtr != NULL) && Itcl_IsStub(cmdPtr)) {
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* ItclHandleStubCmd()
*
* Invoked by Tcl to handle commands created by "stub create".
* Calls "auto_load" with the full name of the current command to
* trigger autoloading of the real implementation. Then, calls the
* command to handle its function. If successful, this command
* returns TCL_OK along with the result from the real implementation
* of this command. Otherwise, it returns TCL_ERROR, along with an
* error message in the interpreter.
* ------------------------------------------------------------------------
*/
static int
ItclHandleStubCmd(
ClientData clientData, /* command token for this stub */
Tcl_Interp *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
Tcl_Command cmdPtr;
Tcl_Obj **cmdlinev;
Tcl_Obj *objAutoLoad[2];
Tcl_Obj *objPtr;
Tcl_Obj *cmdNamePtr;
Tcl_Obj *cmdlinePtr;
char *cmdName;
int result;
int loaded;
int cmdlinec;
ItclShowArgs(1, "ItclHandleStubCmd", objc, objv);
cmdPtr = (Tcl_Command) clientData;
cmdNamePtr = Tcl_NewStringObj(NULL, 0);
Tcl_IncrRefCount(cmdNamePtr);
Tcl_GetCommandFullName(interp, cmdPtr, cmdNamePtr);
cmdName = Tcl_GetString(cmdNamePtr);
/*
* Try to autoload the real command for this stub.
*/
objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1);
objAutoLoad[1] = cmdNamePtr;
result = Tcl_EvalObjv(interp, 2, objAutoLoad, 0);
if (result != TCL_OK) {
Tcl_DecrRefCount(cmdNamePtr);
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
result = Tcl_GetIntFromObj(interp, objPtr, &loaded);
if ((result != TCL_OK) || !loaded) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't autoload \"", cmdName, "\"", NULL);
Tcl_DecrRefCount(cmdNamePtr);
return TCL_ERROR;
}
/*
* At this point, the real implementation has been loaded.
* Invoke the command again with the arguments passed in.
*/
cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc - 1, objv + 1);
(void) Tcl_ListObjGetElements(NULL, cmdlinePtr,
&cmdlinec, &cmdlinev);
Tcl_DecrRefCount(cmdNamePtr);
Tcl_ResetResult(interp);
ItclShowArgs(1, "ItclHandleStubCmd", cmdlinec - 1, cmdlinev + 1);
result = Tcl_EvalObjv(interp, cmdlinec - 1, cmdlinev + 1, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(cmdlinePtr);
Tcl_DecrRefCount(objAutoLoad[0]);
return result;
}
/*
* ------------------------------------------------------------------------
* ItclDeleteStub()
*
* Invoked by Tcl whenever a stub command is deleted. This procedure
* does nothing, but its presence identifies a command as a stub.
* ------------------------------------------------------------------------
*/
/* ARGSUSED */
static void
ItclDeleteStub(
TCL_UNUSED(ClientData)) /* not used */
{
/* do nothing */
}

143
pkgs/itcl4.2.2/generic/itclTclIntStubsFcn.c Normal file
View File

@@ -0,0 +1,143 @@
/*
* ------------------------------------------------------------------------
* PACKAGE: [incr Tcl]
* DESCRIPTION: Object-Oriented Extensions to Tcl
*
* This file contains procedures that use the internal Tcl core stubs
* entries.
*
* ========================================================================
* AUTHOR: Arnulf Wiedemann
*
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <tclInt.h>
#include "itclInt.h"
Tcl_Command
_Tcl_GetOriginalCommand(
Tcl_Command command)
{
return TclGetOriginalCommand(command);
}
int
_Tcl_CreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
Tcl_Namespace *nsPtr, /* Namespace containing this proc. */
const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */
{
int code = TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr,
bodyPtr, (Proc **)procPtrPtr);
(*(Proc **)procPtrPtr)->cmdPtr = NULL;
return code;
}
Tcl_ObjCmdProc *
_Tcl_GetObjInterpProc(
void)
{
return (Tcl_ObjCmdProc *)TclGetObjInterpProc();
}
void
_Tcl_ProcDeleteProc(
ClientData clientData)
{
TclProcDeleteProc(clientData);
}
int
Itcl_RenameCommand(
Tcl_Interp *interp,
const char *oldName,
const char *newName)
{
return TclRenameCommand(interp, oldName, newName);
}
int
Itcl_PushCallFrame(
Tcl_Interp * interp,
Tcl_CallFrame * framePtr,
Tcl_Namespace * nsPtr,
int isProcCallFrame)
{
return Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame);
}
void
Itcl_PopCallFrame(
Tcl_Interp * interp)
{
Tcl_PopCallFrame(interp);
}
void
Itcl_GetVariableFullName(
Tcl_Interp * interp,
Tcl_Var variable,
Tcl_Obj * objPtr)
{
Tcl_GetVariableFullName(interp, variable, objPtr);
}
Tcl_Var
Itcl_FindNamespaceVar(
Tcl_Interp * interp,
const char * name,
Tcl_Namespace * contextNsPtr,
int flags)
{
return Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags);
}
void
Itcl_SetNamespaceResolvers (
Tcl_Namespace * namespacePtr,
Tcl_ResolveCmdProc * cmdProc,
Tcl_ResolveVarProc * varProc,
Tcl_ResolveCompiledVarProc * compiledVarProc)
{
Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc);
}
Tcl_HashTable *
Itcl_GetNamespaceCommandTable(
Tcl_Namespace *nsPtr)
{
return TclGetNamespaceCommandTable(nsPtr);
}
Tcl_HashTable *
Itcl_GetNamespaceChildTable(
Tcl_Namespace *nsPtr)
{
return TclGetNamespaceChildTable(nsPtr);
}
int
Itcl_InitRewriteEnsemble(
Tcl_Interp *interp,
int numRemoved,
int numInserted,
TCL_UNUSED(int) /* objc */,
Tcl_Obj *const *objv)
{
return TclInitRewriteEnsemble(interp, numRemoved, numInserted, objv);
}
void
Itcl_ResetRewriteEnsemble(
Tcl_Interp *interp,
int isRootEnsemble)
{
TclResetRewriteEnsemble(interp, isRootEnsemble);
}

38
pkgs/itcl4.2.2/generic/itclTclIntStubsFcn.h Normal file
View File

@@ -0,0 +1,38 @@
/* these functions are Tcl internal stubs so make an Itcl_* wrapper */
MODULE_SCOPE void Itcl_GetVariableFullName (Tcl_Interp * interp,
Tcl_Var variable, Tcl_Obj * objPtr);
MODULE_SCOPE Tcl_Var Itcl_FindNamespaceVar (Tcl_Interp * interp,
const char * name, Tcl_Namespace * contextNsPtr, int flags);
MODULE_SCOPE void Itcl_SetNamespaceResolvers (Tcl_Namespace * namespacePtr,
Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc,
Tcl_ResolveCompiledVarProc * compiledVarProc);
#ifndef _TCL_PROC_DEFINED
typedef struct Tcl_Proc_ *Tcl_Proc;
#define _TCL_PROC_DEFINED 1
#endif
#ifndef _TCL_RESOLVE_DEFINED
struct Tcl_Resolve;
#endif
#define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand
#define Tcl_CreateProc _Tcl_CreateProc
#define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc
#define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc
MODULE_SCOPE Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command);
MODULE_SCOPE int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr,
Tcl_Proc *procPtrPtr);
MODULE_SCOPE void _Tcl_ProcDeleteProc(ClientData clientData);
MODULE_SCOPE Tcl_ObjCmdProc *_Tcl_GetObjInterpProc(void);
MODULE_SCOPE int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName,
const char *newName);
MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr);
MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr);
MODULE_SCOPE int Itcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
int numInserted, int objc, Tcl_Obj *const *objv);
MODULE_SCOPE void Itcl_ResetRewriteEnsemble(Tcl_Interp *interp,
int isRootEnsemble);

128
pkgs/itcl4.2.2/generic/itclTestRegisterC.c Normal file
View File

@@ -0,0 +1,128 @@
/*
* ------------------------------------------------------------------------
* 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.
*
* This part adds a mechanism for integrating C procedures into
* [incr Tcl] classes as methods and procs. Each C procedure must
* either be declared via Itcl_RegisterC() or dynamically loaded.
*
* ========================================================================
* AUTHOR: Arnulf Wiedemann
* ========================================================================
* Copyright (c) Arnulf Wiedemann
* ------------------------------------------------------------------------
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifdef ITCL_DEBUG_C_INTERFACE
#include <stdio.h>
#include "itclInt.h"
Tcl_CmdProc cArgFunc;
Tcl_ObjCmdProc cObjFunc;
int
cArgFunc(
ClientData clientData,
Tcl_Interp *interp,
int argc,
const char **argv)
{
int result;
ItclObjectInfo * infoPtr = NULL;
ItclClass *iclsPtr = NULL;
ItclClass * classPtr;
ItclObject * rioPtr = (ItclObject *)1;
Tcl_Obj * objv[4];
FOREACH_HASH_DECLS;
//fprintf(stderr, "argc: %d\n", argc);
if (argc != 4) {
Tcl_AppendResult(interp, "wrong #args: should be ::itcl::parser::handleClass className className objectName", NULL);
return TCL_ERROR;
}
objv[0] = Tcl_NewStringObj(argv[0], -1);
objv[1] = Tcl_NewStringObj(argv[1], -1); /* class name */
objv[2] = Tcl_NewStringObj(argv[2], -1); /* full class name */
objv[3] = Tcl_NewStringObj(argv[3], -1); /* object name */
Tcl_IncrRefCount(objv[0]);
Tcl_IncrRefCount(objv[1]);
Tcl_IncrRefCount(objv[2]);
Tcl_IncrRefCount(objv[3]);
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) {
if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 ||
strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) {
iclsPtr = classPtr;
break;
}
}
if (iclsPtr == NULL) {
Tcl_AppendResult(interp, "no such class: ", Tcl_GetString(objv[2]), NULL);
return TCL_ERROR;
}
/* try to create an object for a class as a test for calling a C function from
* an Itcl class. See file CreateItclObjectWithC_example.tcl in library directory
*/
result = Itcl_CreateObject(interp, Tcl_GetString(objv[3]), iclsPtr, 4, objv, &rioPtr);
return result;
}
int
cObjFunc(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
ItclObjectInfo * infoPtr = NULL;
ItclClass *iclsPtr = NULL;
ItclClass * classPtr;
FOREACH_HASH_DECLS;
int i;
ItclShowArgs(0, "cObjFunc called", objc, objv);
fprintf(stderr, "objv: %d %p\n", objc, objv);
for(i = 0; i<objc;i++) {
fprintf(stderr, "arg:%d:%s:\n", i, Tcl_GetString(objv[i]));
}
nsPtr = Tcl_GetCurrentNamespace(interp);
fprintf(stderr, "IP:%p %p %p !%s!\n",interp, clientData, nsPtr, nsPtr->fullName);
infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL);
FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) {
if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 ||
strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) {
iclsPtr = classPtr;
break;
}
}
fprintf(stderr, "IP2:%p %p %p\n",interp, clientData, iclsPtr);
return TCL_OK;
}
void
RegisterDebugCFunctions(Tcl_Interp *interp)
{
int result;
/* args: interp, name, c-function, clientdata, deleteproc */
result = Itcl_RegisterC(interp, "cArgFunc", cArgFunc, NULL, NULL);
result = Itcl_RegisterObjC(interp, "cObjFunc", cObjFunc, NULL, NULL);
if (result != 0) {
}
}
#endif

1107
pkgs/itcl4.2.2/generic/itclUtil.c Normal file
View File

File diff suppressed because it is too large Load Diff