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

Import Tcl 8.6.10

Browse Source
This commit is contained in:
Steve Dower
2020-09-24 22:53:56 +01:00
parent 0343d03b22
commit 3bb8e3e086
1005 changed files with 593700 additions and 41637 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
pkgs/itcl4.2.0/.project Normal file
View File

@@ -0,0 +1,11 @@
<?xml version="1.0" encoding="UTF-8"?>
<projectDescription>
<name>itcl</name>
<comment></comment>
<projects>
</projects>
<buildSpec>
</buildSpec>
<natures>
</natures>
</projectDescription>

608
pkgs/itcl4.2.0/ChangeLog Normal file
View File

@@ -0,0 +1,608 @@
NOTICE: This ChangeLog is no longer being maintained. To examine
the series of changes checked into Itcl sources, follow the Timeline
https://core.tcl-lang.org/itcl/timeline
2014-11-06 Don Porter <dgp@Users.sourceforge.net>
* generic/itclMigrate2TclCore.c: Fix for SF Bug 259.
* tests/sfbugs.test: Test for Bug 250 fix.
2014-11-02 Don Porter <dgp@Users.sourceforge.net>
* generic/itclMethod.c: Completely different fix for SF bug #243
* geneirc/itclObject.c: that has the benefit of not completely
breaking Itk and Iwidgets. :)
2014-09-20 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclParse.c:
* generic/itclObject.c: Fixes for SF bug #257
* tests/sfbugs.test: added test for SF bug #257 and fixed test 254 to
use an own interpreter for avoiding problems with following tests.
2014-09-13 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: Fixes for SF bug #256
* tests/sfbugs.test: added test for fossil bug #8 and for SF bug #254
and #256
* generic/itclObject.c: fix for fossil bug
2cd667f270b68ef66d668338e09d144e20405e23 (fossil bug # 8).
* generic/itcl.decls:
* generic/itclBase.c:
* generic/itclClass.c:
* generic/itclInt.h:
* generic/itclIntDecls.h:
* generic/itclObject.c:
* generic/itclTestRegisterC.c: Implementation of Itcl_CreateObject
stubs Interface (now complete) SF bug #252.
2014-09-07 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: small fixes to save code.
2014-09-07 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclParse.c: fix for making Itcl_CallCCommand working again.
2014-09-07 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itcl.decls:
* generic/itclClass.c:
* generic/itclDecls.h:
* generic/itclInt.h:
* generic/itclIntDecls.h:
* generic/itclObject.c:
* generic/itclStubInit.c: Start of implementation of Itcl_CreateObject
stubs interface.
2014-09-07 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itcl2TclOO.h:
* generic/itcl2TclOO.c:
* generic/itclBase.c: Work around for SF bug #254 using call
Itcl_IncrObjectRefCount until fix in TclOO is done.
2014-09-07 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: fix for SF bug #255 in CallItclObjectCmd.
Check for built in commands and do not set oPtr in that case.
2014-02-19 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclCmd.c: fix for SF bug #238 in Itcl_ScopeCmd. Use
Tcl_AppendResult instead of TclAppendElement.
2014-02-18 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: again a fix for SF bug #244 to make it work
correctly.
2014-02-18 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* tests/sfbugs.test: added a test file for bugs reported on SF incrtcl
tracker.
2014-02-18 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclResolve.c:
* generic/itclObject.c: fix for upvar problem (SF bug #187) in
splitting up the trace handlers for this, win, type, self and selfns.
Also doing traces for linked variables to one of these.
2014-02-16 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c:
* generic/itclMigrate2TclCore.h:
* generic/itclMigrate2TclCore.c: 2nd fix for uplevel problem (SF bug #250).
2014-02-13 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMigrate2TclCore.c: fix for uplevel 2nd problem (SF bug #250).
2014-01-24 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: added some code for special handling of
relative method name with namespace parts (SF bug #243)
When calling Itcl_EvalMemberCode strip off the namespace parts
if no constructor.
2014-01-24 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c:
* generic/itclObject.c:
* generic/itclMigrate2TclCore.c:
* generic/itclMigrate2TclCore.h: added some code for special handling
of an uplevel call to get the appropriate oPtr (SF bug #244).
The uplevel environment is checked by looking if the framePtr
and the varFramePtr are different (maybe not enough ?).
2014-01-24 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMigrate2TclCore.h: use same type for Tcl_Var as in tcl.h
SF bug #248.
2013-11-09 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* library/itcl.tcl: rename variable cmd to __cmd to avoid conflicts
with user variable of the same name SF bug #246
2013-06-16 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclInfo.c: Added new command: info context
* generic/itclBuiltin.c:
* library/itclHullCmds.tcl: new code for extendedclass component
handling
* generic/itclObject.c: removed not necessary code
* generic/itclCmd.c: code for extendedclass
2013-06-09 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclParse.c:
* generic/itclObject.c:
* generic/itclMethod.c:
* generic/itclBuiltin.c: renaming of removecomponentoption to
ignorekomponentoption, removing of addcomponentoption
move code for keepcomponentoption from itclBuiltin.c as Tcl code to
itclHullCmds.tcl
* library/itclHullCmds.tcl: moved keepcomponentoption from
itclBuiltin.c to here as Tcl code. renaming of removecomponentoption
to ignorekomponentoption
2013-06-02 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclResolve.c:
* generic/itclClass.c:
* generic/itclObject.c: Changed code to avoid some compiler warnings.
Added code for extendedclass variable itcl_option_components.
* generic/itclInfo.c: Fix for info classoptions to only use current
class options
* generic/itclBuiltin.c: Fixed typo which used hPtr instead of hPtr2
Fixes for compiler warnings. Added 3 internal builtin commands
addoptioncomponent, removeoptioncomponent, renameoptioncomponent for
extendedclass.
* generic/itclInt.h: Added define ITCL_OPTION_COMP_VAR
* generic/itclHelpers.c: Fixes for compiler warnings
* generic/itclMethod.c:
* generic/itclParse.c: Fixes for compiler warnings. Added 3 internal
builtin commands addoptioncomponent,
removeoptioncomponent, renameoptioncomponent for extendedclass.
* library/itclHullCmds.c: New code for seeting component options
depending on itcl_option_components arra
2013-05-26 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclBuiltin.c: Removed unused code, added some code for
BiInitOptionsCmd also that code seems to be no
longer used instead a Tcl implementation of that code is used at least
on some places
* generic/itclCmd.c: Removed unused code
* generic/itclInfo.c: Added new command "info classoptions"
(Itcl_BiInfoClassOptionsCmd), removed some unused code.
* generic/itclInt.h: Added define ITCL_OPTION_INITTED
* library/itclHullCmds.tcl: Added proc itcl_initoptions. A lot of
changes and fixes in initoptions.
2013-03-11 Don Porter <dgp@Users.sourceforge.net>
* Makefile.n: SF Bug #239 - support -singleproc 1 testing.
2013-03-02 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclMethod.c: fixes for constructor problems with
itclwidgets
* generic/itclObject.c:
* library/itclHullCmds.tcl:
2013-03-02 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* configure: bumped version number already to 4.0.1 no real version yet!
* configure.in:
* generic/itcl.h:
2013-02-17 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclBuiltin.c: fix for SF Bug #237
2013-02-03 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclBase.c: fix for SF Bug #3591018 new #232
* generic/itclObject.c: fix for SF Bug #3600923 new #???
* generic/itcl2TclOO.h:
* generic/itcl2TclOO.c:
* library/itclHullCmds.tcl: fix for Problem with itclWidgets
2012-12-11 Don Porter <dgp@Users.sourceforge.net>
* first stable release 4.0.0
* generic/itcl.h:
* configure, configure.in, Makefile.in: Bump version to 4.0.0
2012-09-11 Jan Nijtmans <nijtmans@users.sf.net>
* Makefile.in: Make tests runnable from withing Tcl's pkgs,
directory, without Itcl being installed.
2012-08-29 Jan Nijtmans <nijtmans@users.sf.net>
* generic/*.c: Remove all (deprecated) usage of _ANSI_ARGS_
2012-07-17 Jan Nijtmans <nijtmans@users.sf.net>
* win/makefile.vc: [Bug 3544932]: Visual studio compiler check fails
2012-07-12 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* generic/itclBase.c: make the info command call in clazzUnknownBody a
list to avoid problems with class names
containing spaces. i
Fix for [incr Tcl] bug ID: 3536018
2012-05-17 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* generic/itclResolve.c: fixed problem with access to protected class
variables when not from top level context
reported from Rene Zaumseil for his itk
emulation
2012-03-25 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* generic/itclInfo.c: fixed problem with info exists command.
fossil ticket id: d4ee728817f951d0b2aa8e8f9b030ea854e92c9f
2012-02-25 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* generic/itclObject.c: special case: we found the class for the class command,
for a relative or absolute class path name
but we have no method in that class that fits.
Problem of Rene Zaumseil when having the object
for a class in a child namespace of the class
fossil ticket id: 36577626c340ad59615f0a0238d67872c009a8c9
* generic/itclCmd.c: typo fix
2011-11-07 Jan Nijtmans <nijtmans@users.sourceforge.net>
* tools/genStubs.tcl: Make stub table symbols and pointers const
* generic/itcl.decls: Remove Itcl_(Safe)Init from Stub table
* generic/itcl.h:
* generic/itcl2TclOO.c: Remove unnecessary includes, and consistent
* generic/itclBase.c: use of include <file> resp include "file"
* generic/itclInt.h:
* generic/itclMigrate2TclCore.c:
* generic/itclParse.c:
* generic/itclResolve2.c:
* generic/itclStubLib.c:
* generic/itclStubs.c:
* generic/itclTclIntStubsFcn.c:
* generic/itclTestRegisterC.c:
* generic/itclVarsAndCmds.c:
* generic/itclDecls.h: (regenerated)
* generic/itclIntDecls.h:
* generic/itclStubInit.c:
2011-10-28 Don Porter <dgp@Users.sourceforge.net>
* generic/itcl.h:
* configure, configure.in, Makefile.in: Bump version to 4.0b8
2011-10-20 Jan Nijtmans <nijtmans@users.sourceforge.net>
* generic/itclMigrate2TclCore.h: [Bug 3424948]: trunk does not link
* generic/itclTclIntStubsFcn.h
* generic/itcl2TclOO.h
* generic/itcl2TclOO.c
* generic/itcl.decls: [Frq 3423707]: TIP #27 related signature changes
* generic/itclIntDecls.h: (regenerated)
* generic/itcl2TclOO.h
* generic/itclBase.c
* generic/itclBuiltin.c
* generic/itclClass.c
* generic/itclCmd.c
* generic/itclEnsemble.c
* generic/itclHelpers.c
* generic/itclInfo.c
* generic/itclMethod.c
* generic/itclObject.c
* generic/itclParse.c
* generic/itclUtil.c
2011-10-14 Jan Nijtmans <nijtmans@users.sourceforge.net>
* generic/itcl2TclOO.h: [Bug 3369931]: unneeded exported functions
* generic/itclBase.c
* generic/itclBuiltin.c
* generic/itclClass.c
* generic/itclCmd.c
* generic/itclInt.h
* generic/itclMigrate2TclCore.h
* generic/itclTclIntStubsFcn.h
* generic/itclNeededFromTclOO.h (removed)
* generic/itclNeededFromTclOO.c (removed)
* configure
* configure.in
* win/makefile.vc
* generic/itclEnsemble.c: Fix various gcc warnings, discovered
* generic/itclHelpers.c with -Wwrite-strings
* generic/itclInfo.c
* generic/itclParse.c
* generic/itclResolve.c
2011-08-03 Don Porter <dgp@Users.sourceforge.net>
* generic/itclInt.h: fix for SF bug #3385041
2011-08-01 Don Porter <dgp@Users.sourceforge.net>
* win/makefile.vc: MSVC support updates. Thanks to Twylite.
* win/rules.vc:
2011-07-15 Don Porter <dgp@Users.sourceforge.net>
* generic/itcl.h:
* configure, configure.in, Makefile.in: Bump version to 4.0b7
2011-06-30 Don Porter <dgp@Users.sourceforge.net>
* configure.in: Build system changes to accomodate TEA updates
* Makefile.in:
* generic/itcl.h:
2011-04-29 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* generic/itcl.h:
* configure, configure.in, Makefile.in: Bump version to 4.0b6
2010-09-26 Miguel Sofer <msofer@users.sf.net>
* itcl/generic/itcl2TclOO.c (Itcl_NRRunCallbacks):
Tcl's [Patch 3072080] (a saner NRE): TclNRRunCallbacks lost one
argument.
2010-08-22 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* itclInt.h, itclObject.c, itclInfo.c: fix for BiInfoHeritageCmd
and BiInfoInheritCmd function, if we have no object context
2010-08-17 Jeff Hobbs <jeffh@ActiveState.com>
* itclConfig.sh.in, releasenotes.txt, generic/itcl.h:
* itclWidget/tclconfig/tcl.m4, itclWidget/Makefile.in:
* itclWidget/configure, itclWidget/configure.in:
* itclWidget/itclWidgetConfig.sh.in (removed):
* configure, configure.in, Makefile.in: Bump version to 4.0b5
Update to TEA 3.9
Remove unnecessary itcl_INCLUDE_DIR (dup of itcl_INCLUDE_SPEC)
2010-05-17 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* itclClass.c: undo change from 2010-05-16
2010-05-16 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* itclClass.c: allow variable namespace to exist
2010-05-02 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* itclClass.c: fix for SF bug #2993540
* itcl2Tcloo.c: fix for SF bug #2993648
* itcl2Tcloo.h: fix for SF bug #2993648
* itclBuiltin.c: added an empty line for beautifying
* itclCmd.c: in Itcl_IsObjectCmd if in constructor use the correct ioPtr
* itclObject.c: in Itcl_ObjectIsa check for contextIoPtr == NULL
to avoid segmentation violation
2010-04-21 Arnulf P.Wiedemann <wiede@users.sourceforge.net>
* itclCmd.c: Add missing Tcl_DStringFree for [itcl Bug 2983809]
* itclEnsemble.c:
* itclObject.c:
* itclParse.c:
* itclResolve.c:
* itclParse.c: better error message when using: public mthod ...
instead of public method ...
2010-04-08 Don Porter <dgp@Users.sourceforge.net>
* itclInt.h: Add #ifdef guards to attempt inclusion of
a unistd.h header file only where one exists.
2010-04-05 Don Porter <dgp@Users.sourceforge.net>
* itclTclIntStubsFcn.c: Remove attempt to return value from
Itcl_ResetRewriteEnsemle() which is declared
as returning (void). Thanks to Andreas
Kupried for reporting the compiler errors.
2010-03-28 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* typeinfo.test: integrated fix for [Tcl Bug 2821935] and
* typeoption.test: other fixes from Donal Fellows. This helps
* itclParse.c: work around a limitation in the MSVC 6.0
* itclBuiltin.c: compiler.
* itclBase.c:
* itcl2TclOO.c:
2010-03-19 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* configure.in: add missing include files for install,thanks to Reinhard Max for
the patch
* itclInfo.c: removed "uplevel 1" in Itcl_BiInfoUnknownCmd.c, which made problems
with "info complete", reported by Reinhard Max
* itclMethod.c: fixed bug, which caused core dump in CallItclObjectCmd, thanks to
Reinhard Max for the patch
2010-03-06 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* itcl.decls: changed CONST in declarations to const
* itclDecls.h:
* itclIntDecls.h
* itcl2TclOO.c: adaption to typedef change in TclOO for TclOO_PreCallProc and
TclOO_PostCallProc
* itclNeededFromTclOO.h:
* itclBuiltin.c: allow installcomponent for ::itcl::type too typeclass.test install-1.7
* itclClass.c: use "new" style params in Itcl_FindClass
2009-10-25 Arnulf P. Wiedemann <wiede@users.sf.net>
* itclCmd.c: fix for Itcl_AddOptionCmd
2009-10-24 Arnulf P. Wiedemann <wiede@users.sf.net>
* itclMethod.c: if during call of constructor, when building
an object there were multiple recursive calls
on CallItclObjectCmd and errors have not been
propagated. Now hadConstructorError
field in ItclObject struct is used for that
purpose.
* itclInt.h:
* itclObject.c:
* itclObject.c: allow %:var_name substitution in delegate
method using part for extendedclass
* itclObject.c: allow call of delegated methods in constructor
of ::itcl::extendedclass
* itclBuiltin.c:
* itclMethod.c:
2009-10-23 Arnulf P. Wiedemann <wiede@users.sf.net>
* generic/itcl.h: bumped version to 4.0b4
* configure.in:
* configure:
* itclClass.c: fixed bug which prevented correct error
reporting when there was a problem when
creating an object, also fixed to use correct
NRE calling
2009-10-23 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* itclMigrate2TclCore.c: added Itcl_GetUplevelCallFrame and
Itcl_ActivateCallFrame functions
same as in Itcl3.4. They are needed to call
the itk_component command with the suitable
call frame as this is needed for access to the
proc local vars. This was the fix for SF
bug #2840994
* itclStubInit.c:
* itcl.decls:
* itclDecls.h:
* itclIntDecls.h:
* itclResolve.c: added special_resolve_vars. Also needed
for SF bug #2840994
2009-10-22 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* itclLinkage.c: changed CONST in declarations to const
* itclMethod.c:
* itclBase.c:
* itclBuiltin.c:
* itclStubs.c:
* itclObject.c: added an empty line (beautifying)
* itclInfo.c: no extra method for info exists, use the
ItclBiInfoUnknownCmd instead
fix for bug # 2738459
* itclObject.c: fix for bug # 2789473
* itclResolve.c: fix for bug # 2495261
* itclCmd.c: use of new Tcl functions as suggested from dkf
* itclHelpers.c:
* itclMigrate2TclCore.c:
* itclMigrate2TclCore.h:
* itclTclIntStubsFcn.c:
* itclTclIntStubsFcn.h:
2009-10-20 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclParse.c: fix for bug #2871541.
added a lot of checks if within a class
environment (iclsPtr != NULL), as there
were a lot of similar cases
2009-10-18 Arnulf P. Wiedemann <wiede@users.sourceforge.net>
* generic/itclInfo.c: fix for bug #2830946.
* pkgIndex.tcl.in: fix for bug #2856166.
* itclInt.h: for linux we need inclusion of unistd.h otherwise
intprt_t type is not defined
* itclResolve2.c: changed CONST in declarations to const
* itclTclIntStubsFcn.c:
* itclObject.c:
* itclParse.c:
* itclClass.c:
* ItclEnsemble.c:
* itclHelpers.c:
* itclCmd.c:
* itclUtil.c:
2009-07-18 Daniel A. Steffen <das@users.sourceforge.net>
* generic/itclClass.c: fix warnings.
* generic/itclParse.c:
* generic/itclResolve.c:
* configure.in: check for intptr_t type and include sys/types.h
* generic/itclInt.h: to make INT2PTR & PTR2INT macros actually work.
* itclng/generic/itclngInt.h:
* configure: autoconf-2.59
2009-05-09 David Gravereaux <davygrvy@pobox.com>
* generic/itcl.h:
* generic/itclDecls.h: Better C++ support.
* generic/itclStubLib.c: #define USE_TCL_STUBS is required
2009-03-19 Jeff Hobbs <jeffh@ActiveState.com>
* generic/itclBase.c: reduce size of initScript to satisfy MSVC6.
2008-02-21 Arnulf P. Wiedemann <wiede@users.sf.net>
* fix for SF bug 2595708 itclParse.c and itclBuiltin.c
* fix for problem with scope command path reported by
* Harald Krummeck on c.l.t ItclCmd.c
2008-02-02 Arnulf P. Wiedemann <wiede@users.sf.net>
* generic/itcl.h configure.in:
bumped version to 4.0b3
2008-02-01 Arnulf P. Wiedemann <wiede@users.sf.net>
* tests/widgetadaptor.test and tests/widgetclass.test:
removed package require Tk to avoid running the tests
always
2008-01-24 Arnulf P. Wiedemann <wiede@users.sf.net>
* generic/itclBase.c: added *Dict*Info functions to allow fully
* generic/itclBuiltin.c:integration of itclWidget package.
* generic/itclClass.c: itclWidget package is no longer needed.
* generic/itclCmd.c: The *Dict*Info* function also allow in the
* generic/itclObject.c: future to replace itclInfo.c by a scripted
* generic/itclParse.c: version written in tcl.
* generic/itclInfo.c: For replacing itclWidget package itclWidget.tcl
* generic/itclMethod.c: has been filled with new procs, which are
* library/itclWidget.tcl:called from the C parts, when needed.
* generic/itclHelpers.c:here one can find all the *Dict*Info functions
* library/ictlHullCmds.tcl:
here are similar funtions to itclWidget.tcl for
use by ::itcl::extendedclass
* generic/itclUtil.c: malloc.h include now bracketed with
#ifdef ITCL_PRESERVE_DEBUG as it is only used
for debugging. I have to look for a solution
using memory.h as a portable version, but
for that I have to understand that first.
With #ifdef ITCL_PRESERVE_DEBUG, the malloc
and free calls can be used again, these are
necessary, as im am checking stuff done by
ckalloc and ckfree, so these cannot be used.
2009-01-15 David Gravereaux <davygrvy@pobox.com>
* generic/itcl2TclOO.h: More cleanups changing the last of the
* generic/itclClass.c: 'EXTERN' macros to just be 'extern' as we
* win/.cvsignore: aren't importing the declaration, just
* win/itcl.rc: sharing it internally. This caused warnings
* win/makefile.vc: on windows during the link stage as it was
* win/nmakehlp.c: getting confused about 'why are you
* win/rules.vc: importing an internal function?'
2009-01-15 David Gravereaux <davygrvy@pobox.com>
* generic/itclMigrate2TclCore.h: All build errors squashed
* generic/itclStubLib.c:
* generic/itclTclIntStubFcn.h:
* win/makefile.vc:
2009-01-14 David Gravereaux <davygrvy@pobox.com>
* generic/itclBase.c:
* generic/itclBuiltin.c:
* generic/itclClass.c:
* generic/itclCmd.c:
* generic/itclEnsemble.c:
* generic/itclHelpers.c:
* generic/itclInfo.c:
* generic/itclMethod.c:
* generic/itclMigrate2TclCore.c:
* generic/itclObject.c:
* generic/itclParse.c:
* generic/itclResolve.c
* generic/itclStubs.c
* generic/itclTclIntStubsFcn.c:
* win/makefile.vc:
Changes to allow compiling on windows with
MSVC++. Double declaration of internal
functions not yet repaired. DOESN'T
BUILD YET with makefile.vc.
2009-01-14 Daniel A. Steffen <das@users.sourceforge.net>
* Makefile.in: fix itclConfig.sh install location to match TEA convention
* aclocal.m4: match minimum autoconf requirement with TEA
* configure: autoconf-2.59
* generic/itclUtil.c: fix Mac OS X build failure (dkf) [Bug 2505545]
2008-12-11 Arnulf P. Wiedemann <wiede@users.sf.net>
* itcl-ng first beta release 4.0b1
2008-12-06 Arnulf P. Wiedemann <wiede@users.sf.net>
* built enhanced functions for chasing memory leaks in adding
* functionality to the functions available in Tcl core
* and fixed a lot of leaks of that class
2008-11-30 Arnulf P. Wiedemann <wiede@users.sf.net>
* built functions for chasing memory leaks and fixed a lot of those
2008-11-16 Arnulf P. Wiedemann <wiede@users.sf.net>
* second alpha release 4.0a1
2008-11-14 Arnulf P. Wiedemann <wiede@users.sf.net>
* 207 tests for snit like functionality running
2008-10-19 Arnulf P. Wiedemann <wiede@users.sf.net>
* the snit like commands are mostly implemented
* starting with tests for snit like functionality
2008-10-18 Arnulf P. Wiedemann <wiede@users.sf.net>
* first alpha release 4.0a0
2007-10-15 Arnulf P. Wiedemann <wiede@users.sf.net>
* added the following commands:
* ::itcl::extendedclass
* ::itcl::adddelegatedoption
* ::itcl::adddelegatedmethod
* ::itcl::setComponent
2007-10-12 Arnulf P. Wiedemann <wiede@users.sf.net>
* started to add commands in snit like class types:
* option
* typemethod
* delegate option
* delegate typemethod
* delegate method
* component
* widgetclass
2007-09-29 Arnulf P. Wiedemann <wiede@users.sf.net>
* started to add snit like commands and classtypes
* these are ::itcl::type, ::itcl::widget, ::itcl::widgetadaptor
2007-09-29 Arnulf P. Wiedemann <wiede@users.sf.net>
* new commands ::itcl::struct, ::itcl::nwidget ::itcl::addoption and
* ::itcl::addcomponent
* some rearraging of functions for options and delegation, so that
* these can be used in the above commands without the need to load
* the ItclWidget package
* The above commands will be used for a prototype implementation
* of NexTk (from George Peter Staplin) with Itcl using the megapkg
* package of George Peter Staplin as a base
2007-09-29 Arnulf P. Wiedemann <wiede@users.sf.net>
* fixed configuration files
* new/modified code for ItclWidget package (missing code for specification)
* added
2007-09-09 Arnulf P. Wiedemann <wiede@users.sf.net>
* beautifying and fixes for stack backtrace handling
* too many files to list here (nearly all)
2007-09-08 Arnulf P. Wiedemann <wiede@users.sf.net>
* all new modules installed and added
This is the ChangeLog file for itcl-ng/itcl
it is here as Itcl and itcl-ng/itcl will be different modules in the future

472
pkgs/itcl4.2.0/Makefile.in Normal file
View File

@@ -0,0 +1,472 @@
# Makefile.in --
#
# This file is a Makefile for Sample TEA Extension. If it has the name
# "Makefile.in" then it is a template for a Makefile; to generate the
# actual Makefile, run "./configure", which is a configuration script
# generated by the "autoconf" program (constructs like "@foo@" will get
# replaced in the actual Makefile.
#
# Copyright (c) 1999 Scriptics Corporation.
# Copyright (c) 2002-2005 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#========================================================================
# Add additional lines to handle any additional AC_SUBST cases that
# have been added in a customized configure script.
#========================================================================
#SAMPLE_NEW_VAR = @SAMPLE_NEW_VAR@
#========================================================================
# Nothing of the variables below this line should need to be changed.
# Please check the TARGETS section below to make sure the make targets
# are correct.
#========================================================================
#========================================================================
# The names of the source files is defined in the configure script.
# The object files are used for linking into the final library.
# This will be used when a dist target is added to the Makefile.
# It is not important to specify the directory, as long as it is the
# $(srcdir) or in the generic, win or unix subdirectory.
#========================================================================
PKG_SOURCES = @PKG_SOURCES@
PKG_OBJECTS = @PKG_OBJECTS@
PKG_STUB_SOURCES = @PKG_STUB_SOURCES@
PKG_STUB_OBJECTS = @PKG_STUB_OBJECTS@
#========================================================================
# PKG_TCL_SOURCES identifies Tcl runtime files that are associated with
# this package that need to be installed, if any.
#========================================================================
PKG_TCL_SOURCES = @PKG_TCL_SOURCES@
#========================================================================
# This is a list of header files to be installed
# itk.h includes itclInt.h, which needs itclIntDecls.h,
# so we must install them.
#========================================================================
PKG_HEADERS = @PKG_HEADERS@
#========================================================================
# "PKG_LIB_FILE" refers to the library (dynamic or static as per
# configuration options) composed of the named objects.
#========================================================================
PKG_LIB_FILE = @PKG_LIB_FILE@
PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@
lib_BINARIES = $(PKG_LIB_FILE) $(PKG_STUB_LIB_FILE)
BINARIES = $(lib_BINARIES)
SHELL = @SHELL@
srcdir = @srcdir@
prefix = @prefix@
exec_prefix = @exec_prefix@
bindir = @bindir@
libdir = @libdir@
includedir = @includedir@
datarootdir = @datarootdir@
datadir = @datadir@
mandir = @mandir@
DESTDIR =
PKG_DIR = $(PACKAGE_NAME)$(PACKAGE_VERSION)
pkgdatadir = $(datadir)/$(PKG_DIR)
pkglibdir = $(libdir)/$(PKG_DIR)
pkgincludedir = $(includedir)/$(PKG_DIR)
top_builddir = @abs_top_builddir@
INSTALL_OPTIONS =
INSTALL = @INSTALL@ $(INSTALL_OPTIONS)
INSTALL_DATA_DIR = @INSTALL_DATA_DIR@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INSTALL_LIBRARY = @INSTALL_LIBRARY@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_VERSION = @PACKAGE_VERSION@
CC = @CC@
CFLAGS_DEFAULT = @CFLAGS_DEFAULT@
CFLAGS_WARNING = @CFLAGS_WARNING@
EXEEXT = @EXEEXT@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
MAKE_LIB = @MAKE_LIB@
MAKE_SHARED_LIB = @MAKE_SHARED_LIB@
MAKE_STATIC_LIB = @MAKE_STATIC_LIB@
MAKE_STUB_LIB = @MAKE_STUB_LIB@
OBJEXT = @OBJEXT@
RANLIB = @RANLIB@
RANLIB_STUB = @RANLIB_STUB@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_LD = @SHLIB_LD@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
STLIB_LD = @STLIB_LD@
#TCL_DEFS = @TCL_DEFS@
TCL_BIN_DIR = @TCL_BIN_DIR@
TCL_SRC_DIR = @TCL_SRC_DIR@
#TK_BIN_DIR = @TK_BIN_DIR@
#TK_SRC_DIR = @TK_SRC_DIR@
# Not used, but retained for reference of what libs Tcl required
#TCL_LIBS = @TCL_LIBS@
#========================================================================
# TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our
# package without installing. The other environment variables allow us
# to test against an uninstalled Tcl. Add special env vars that you
# require for testing here (like TCLX_LIBRARY).
#========================================================================
EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR)
#EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR):$(TK_BIN_DIR)
TCLLIBPATH = $(top_builddir)
TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library`
PKG_ENV = @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \
PATH="$(EXTRA_PATH):$(PATH)" \
ITCL_LIBRARY=`@CYGPATH@ $(srcdir)/library` \
TCLLIBPATH="$(TCLLIBPATH)"
TCLSH_PROG = @TCLSH_PROG@
TCLSH = $(TCLSH_ENV) $(PKG_ENV) $(TCLSH_PROG)
TESTLOADARG = if {[catch {package present ${PACKAGE_NAME}}]} {package forget ${PACKAGE_NAME}}; \
package ifneeded ${PACKAGE_NAME} ${PACKAGE_VERSION} \
[list load `@CYGPATH@ $(top_builddir)/$(PKG_LIB_FILE)` $(PACKAGE_NAME)]
#WISH_ENV = TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library`
#WISH_PROG = @WISH_PROG@
#WISH = $(PKG_ENV) $(TCLSH_ENV) $(WISH_ENV) $(WISH_PROG)
SHARED_BUILD = @SHARED_BUILD@
STUBS_BUILD = @STUBS_BUILD@
INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@
#INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@
PKG_CFLAGS = @PKG_CFLAGS@
# TCL_DEFS is not strictly need here, but if you remove it, then you
# must make sure that configure.ac checks for the necessary components
# that your library may use. TCL_DEFS can actually be a problem if
# you do not compile with a similar machine setup as the Tcl core was
# compiled with.
#DEFS = $(TCL_DEFS) @DEFS@ $(PKG_CFLAGS)
DEFS = @DEFS@ $(PKG_CFLAGS) -DITCL_LIBRARY=\"$(pkglibdir)\"
# Move pkgIndex.tcl to 'BINARIES' var if it is generated in the Makefile
CONFIG_CLEAN_FILES = @CONFIG_CLEAN_FILES@ Makefile itclConfig.sh pkgIndex.tcl
CLEANFILES = @CLEANFILES@
CPPFLAGS = @CPPFLAGS@
LIBS = @PKG_LIBS@ @LIBS@
AR = @AR@
CFLAGS = @CFLAGS@ -DTCL_NO_DEPRECATED
COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
GDB = gdb
VALGRIND = valgrind
VALGRINDARGS = --tool=memcheck --num-callers=8 --leak-resolution=high \
--leak-check=yes --show-reachable=yes -v
.SUFFIXES: .c .$(OBJEXT)
#========================================================================
# Start of user-definable TARGETS section
#========================================================================
#========================================================================
# TEA TARGETS. Please note that the "libraries:" target refers to platform
# independent files, and the "binaries:" target includes executable programs and
# platform-dependent libraries. Modify these targets so that they install
# the various pieces of your package. The make and install rules
# for the BINARIES that you specified above have already been done.
#========================================================================
all: binaries libraries doc
#========================================================================
# The binaries target builds executable programs, Windows .dll's, unix
# shared/static libraries, and any other platform-dependent files.
# The list of targets to build for "binaries:" is specified at the top
# of the Makefile, in the "BINARIES" variable.
#========================================================================
binaries: $(BINARIES)
libraries:
#========================================================================
# Your doc target should differentiate from doc builds (by the developer)
# and doc installs (see install-doc), which just install the docs on the
# end user machine when building from source.
#========================================================================
doc:
install: all install-binaries install-libraries install-doc
install-binaries: binaries install-lib-binaries install-bin-binaries
#========================================================================
# This rule installs platform-independent files, such as header files.
# The list=...; for p in $$list handles the empty list case x-platform.
#========================================================================
install-libraries: libraries
@$(INSTALL_DATA_DIR) $(DESTDIR)$(includedir)
@echo "Installing header files in $(DESTDIR)$(includedir)"
@list='$(PKG_HEADERS)'; for i in $$list; do \
echo "Installing $(srcdir)/$$i" ; \
$(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir) ; \
done;
#========================================================================
# Install documentation. Unix manpages should go in the $(mandir)
# directory.
#========================================================================
install-doc: doc
@$(INSTALL_DATA_DIR) $(DESTDIR)$(mandir)/mann
@echo "Installing documentation in $(DESTDIR)$(mandir)"
@list='$(srcdir)/doc/*.n'; for i in $$list; do \
if test X"$$i" = X'$(srcdir)/doc/*.n'; then break; fi; \
bi=`basename $$i`; \
echo "Installing $$bi"; \
sed -e '/man\.macros/r $(srcdir)/doc/man.macros' -e '/man\.macros/d' $$i > $$bi.tmp \
&& $(INSTALL_DATA) $$bi.tmp $(DESTDIR)$(mandir)/mann/$$bi \
&& rm -f $$bi.tmp; \
done
test: binaries libraries
$(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) -load "$(TESTLOADARG)"
shell: binaries libraries
@$(TCLSH) $(SCRIPT)
gdb:
$(TCLSH_ENV) $(PKG_ENV) $(GDB) $(TCLSH_PROG) $(SCRIPT)
gdb-test: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(GDB) \
--args $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` \
$(TESTFLAGS) -singleproc 1 -load "$(TESTLOADARG)"
valgrind: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) \
`@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS)
valgrindshell: binaries libraries
$(TCLSH_ENV) $(PKG_ENV) $(VALGRIND) $(VALGRINDARGS) $(TCLSH_PROG) $(SCRIPT)
depend:
genstubs: $(srcdir)/tools/genStubs.tcl $(srcdir)/generic/itcl.decls
$(TCLSH) $(srcdir)/tools/genStubs.tcl $(srcdir)/generic $(srcdir)/generic/itcl.decls
#========================================================================
# $(PKG_LIB_FILE) should be listed as part of the BINARIES variable
# mentioned above. That will ensure that this target is built when you
# run "make binaries".
#
# The $(PKG_OBJECTS) objects are created and linked into the final
# library. In most cases these object files will correspond to the
# source files above.
#========================================================================
$(PKG_LIB_FILE): $(PKG_OBJECTS)
-rm -f $(PKG_LIB_FILE)
${MAKE_LIB}
$(RANLIB) $(PKG_LIB_FILE)
$(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS)
-rm -f $(PKG_STUB_LIB_FILE)
${MAKE_STUB_LIB}
$(RANLIB_STUB) $(PKG_STUB_LIB_FILE)
#========================================================================
# We need to enumerate the list of .c to .o lines here.
#
# In the following lines, $(srcdir) refers to the toplevel directory
# containing your extension. If your sources are in a subdirectory,
# you will have to modify the paths to reflect this:
#
# sample.$(OBJEXT): $(srcdir)/generic/sample.c
# $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@
#
# Setting the VPATH variable to a list of paths will cause the makefile
# to look into these paths when resolving .c to .obj dependencies.
# As necessary, add $(srcdir):$(srcdir)/compat:....
#========================================================================
VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/macosx
.c.@OBJEXT@:
$(COMPILE) -c `@CYGPATH@ $<` -o $@
#========================================================================
# Distribution creation
# You may need to tweak this target to make it work correctly.
#========================================================================
#COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar
COMPRESS = tar zcvf $(PKG_DIR).tar.gz $(PKG_DIR)
DIST_ROOT = /tmp/dist
DIST_DIR = $(DIST_ROOT)/$(PKG_DIR)
DIST_INSTALL_DATA = CPPROG='cp -p' $(INSTALL) -m 644
DIST_INSTALL_SCRIPT = CPPROG='cp -p' $(INSTALL) -m 755
dist-clean:
rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.*
dist: dist-clean doc
$(INSTALL_DATA_DIR) $(DIST_DIR)
# TEA files
$(DIST_INSTALL_DATA) $(srcdir)/Makefile.in \
$(srcdir)/aclocal.m4 $(srcdir)/configure.ac \
$(DIST_DIR)/
$(DIST_INSTALL_SCRIPT) $(srcdir)/configure $(DIST_DIR)/
$(INSTALL_DATA_DIR) $(DIST_DIR)/tclconfig
$(DIST_INSTALL_DATA) $(srcdir)/tclconfig/README.txt \
$(srcdir)/tclconfig/tcl.m4 $(srcdir)/tclconfig/install-sh \
$(DIST_DIR)/tclconfig/
# Extension files
$(DIST_INSTALL_DATA) \
$(srcdir)/ChangeLog \
$(srcdir)/license.terms \
$(srcdir)/README \
$(srcdir)/pkgIndex.tcl.in \
$(srcdir)/itclConfig.sh.in \
$(srcdir)/TODO $(srcdir)/releasenotes.txt \
$(srcdir)/.project \
$(DIST_DIR)/
list='doc generic library tests tools win'; \
for p in $$list; do \
if test -d $(srcdir)/$$p ; then \
$(INSTALL_DATA_DIR) $(DIST_DIR)/$$p; \
for q in $(srcdir)/$$p/*; do \
if test -f $$q ; then \
$(DIST_INSTALL_DATA) $$q $(DIST_DIR)/$$p/; \
fi; \
done; \
fi; \
done
(cd $(DIST_ROOT); $(COMPRESS);)
#========================================================================
# End of user-definable section
#========================================================================
#========================================================================
# Don't modify the file to clean here. Instead, set the "CLEANFILES"
# variable in configure.ac
#========================================================================
clean:
-test -z "$(BINARIES)" || rm -f $(BINARIES)
-rm -f *.$(OBJEXT) core *.core
-test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
distclean: clean
-rm -f *.tab.c
-rm -f $(CONFIG_CLEAN_FILES)
-rm -f config.cache config.log config.status
#========================================================================
# Install binary object libraries. On Windows this includes both .dll and
# .lib files. Because the .lib files are not explicitly listed anywhere,
# we need to deduce their existence from the .dll file of the same name.
# Library files go into the lib directory.
# In addition, this will generate the pkgIndex.tcl
# file in the install location (assuming it can find a usable tclsh shell)
#
# You should not have to modify this target.
#========================================================================
install-lib-binaries: binaries
@$(INSTALL_DATA_DIR) $(DESTDIR)$(pkglibdir)
@list='$(lib_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_LIBRARY) $$p $(DESTDIR)$(pkglibdir)/$$p"; \
$(INSTALL_LIBRARY) $$p $(DESTDIR)$(pkglibdir)/$$p; \
ext=`echo $$p|sed -e "s/.*\.//"`; \
if test "x$$ext" = "xdll"; then \
lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \
if test -f $$lib; then \
echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \
$(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib; \
fi; \
fi; \
fi; \
done
@list='$(PKG_TCL_SOURCES)'; for p in $$list; do \
if test -f $(srcdir)/$$p; then \
destp=`basename $$p`; \
echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \
$(INSTALL_DATA) $(srcdir)/$$p $(DESTDIR)$(pkglibdir)/$$destp; \
fi; \
done
@if test "x$(SHARED_BUILD)" = "x1"; then \
echo " Install pkgIndex.tcl $(DESTDIR)$(pkglibdir)"; \
$(INSTALL_DATA) pkgIndex.tcl $(DESTDIR)$(pkglibdir); \
fi
$(INSTALL_DATA) itclConfig.sh $(DESTDIR)$(pkglibdir)
#========================================================================
# Install binary executables (e.g. .exe files and dependent .dll files)
# This is for files that must go in the bin directory (located next to
# wish and tclsh), like dependent .dll files on Windows.
#
# You should not have to modify this target, except to define bin_BINARIES
# above if necessary.
#========================================================================
install-bin-binaries: binaries
@$(INSTALL_DATA_DIR) $(DESTDIR)$(bindir)
@list='$(bin_BINARIES)'; for p in $$list; do \
if test -f $$p; then \
echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \
$(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p; \
fi; \
done
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
cd $(top_builddir) \
&& CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
uninstall-binaries:
list='$(lib_BINARIES)'; for p in $$list; do \
rm -f $(DESTDIR)$(pkglibdir)/$$p; \
done
list='$(PKG_TCL_SOURCES)'; for p in $$list; do \
p=`basename $$p`; \
rm -f $(DESTDIR)$(pkglibdir)/$$p; \
done
list='$(bin_BINARIES)'; for p in $$list; do \
rm -f $(DESTDIR)$(bindir)/$$p; \
done
.PHONY: all binaries clean depend distclean doc install libraries test
.PHONY: gdb gdb-test valgrind valgrindshell
.PHONY: genstubs
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:

52
pkgs/itcl4.2.0/README Normal file
View File

@@ -0,0 +1,52 @@
README: Itcl
This is the 4.2.0 source distribution of Itcl, an object oriented
extension for Tcl. Itcl releases are available from Sourceforge at:
https://sourceforge.net/projects/incrtcl/files/%5Bincr%20Tcl_Tk%5D-4-source/
1. Introduction
This directory contains the source code, documentation, and test scripts
for the itcl extension. This version is the next major release to follow
Itcl 3.4. This version claims to be script level compatible with Itcl 3.4.
Itcl is a freely-available open source package as in the past.
You can do virtually anything you like with it, such as modifying it,
redistributing it, and selling it either in whole or in part. See the file
"license.terms" for complete information.
2. Compiling and Installing.
Itcl is built in much the same way that Tcl itself is. Once you have
a Tcl build environment set up, you should be able to simply
enter the commands:
cd itcl
./configure
make all
make test
make install
3. Mailing lists
SourceForge hosts a mailing list, incrtcl-users to discuss issues with using
and developing Itcl. For more information and to subscribe, visit
http://sourceforge.net/projects/incrtcl
and go to the 'Mailing Lists' page.
4. Support
We are very interested in receiving bug reports, patches, and suggestions
for improvements. We prefer that you send this information to us via the
bug database, rather than emailing us directly. The bug database is at:
https://core.tcl.tk/itcl/ticket
We will log and follow-up on each bug, although we cannot promise a
specific turn-around time. Enhancements, reported via the Feature
Requests form at the same web site, may take longer and may not happen
at all unless there is widespread support for them.

9
pkgs/itcl4.2.0/TODO Normal file
View File

@@ -0,0 +1,9 @@
This is the TODO list:
- finish the feature list of ::itcl::extendedclass
- describe the API's for ::itcl::extendedclass
- enhance documentation (all parts)
- maybe: add some demo examples for preferred use of ::itcl::extendedclass

9
pkgs/itcl4.2.0/aclocal.m4 vendored Normal file
View File

@@ -0,0 +1,9 @@
#
# Include the TEA standard macro set
#
builtin(include,tclconfig/tcl.m4)
#
# Add here whatever m4 macros you want to define for your package
#

9655
pkgs/itcl4.2.0/configure vendored Normal file
View File

File diff suppressed because it is too large Load Diff

275
pkgs/itcl4.2.0/configure.ac Normal file
View File

@@ -0,0 +1,275 @@
#!/bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#-----------------------------------------------------------------------
# Sample configure.ac for Tcl Extensions. The only places you should
# need to modify this file are marked by the string __CHANGE__
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# __CHANGE__
# Set your package name and version numbers here.
#
# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided. These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_<PACKAGE_NAME>
# so that we create the export library with the dll.
#-----------------------------------------------------------------------
AC_INIT([itcl], [4.2.0])
#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
#--------------------------------------------------------------------
TEA_INIT()
#--------------------------------------------------------------------
# Try to ensure the existence of a tclconfig directory in either
# $srcdir or the current dir, if one can't be found in $srcdir.
# If this package is being built as part of a bundle then a tclconfig
# directory might exist in $srcdir's parent directory.
#--------------------------------------------------------------------
AC_PROG_LN_S
CONFIG_CLEAN_FILES=
if test ! -d $srcdir/tclconfig ; then
if test -d $srcdir/../tclconfig ; then
$LN_S $srcdir/../tclconfig tclconfig
CONFIG_CLEAN_FILES=tclconfig
fi
fi
AC_SUBST(CONFIG_CLEAN_FILES)
#--------------------------------------------------------------------
# Tell autoconf where to find tcl.m4 and install.sh.
#--------------------------------------------------------------------
AC_CONFIG_AUX_DIR(tclconfig)
#--------------------------------------------------------------------
# Load the tclConfig.sh file
#--------------------------------------------------------------------
TEA_PATH_TCLCONFIG
TEA_LOAD_TCLCONFIG
#--------------------------------------------------------------------
# Tcl 8.6+ required.
#--------------------------------------------------------------------
if test "${TCL_MAJOR_VERSION}" -lt 8; then
AC_MSG_ERROR([${TCL_BIN_DIR}/tclConfig.sh is for Tcl ${TCL_VERSION}.
Itcl ${PACKAGE_VERSION} needs Tcl 8.6 or higher.
Use --with-tcl= option to indicate location of tclConfig.sh file for Tcl 8.6+.])
fi
if test "${TCL_MINOR_VERSION}" -lt 6 -a "${TCL_MAJOR_VERSION}" -eq 8; then
AC_MSG_ERROR([${TCL_BIN_DIR}/tclConfig.sh is for Tcl ${TCL_VERSION}.
Itcl ${PACKAGE_VERSION} needs Tcl 8.6 or higher.
Use --with-tcl= option to indicate location of tclConfig.sh file for Tcl 8.6+.])
fi
#--------------------------------------------------------------------
# Load the tkConfig.sh file if necessary (Tk extension)
#--------------------------------------------------------------------
#TEA_PATH_TKCONFIG
#TEA_LOAD_TKCONFIG
#-----------------------------------------------------------------------
# Handle the --prefix=... option by defaulting to what Tcl gave.
# Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER.
#-----------------------------------------------------------------------
TEA_PREFIX
#-----------------------------------------------------------------------
# Standard compiler checks.
# This sets up CC by using the CC env var, or looks for gcc otherwise.
# This also calls AC_PROG_CC and a few others to create the basic setup
# necessary to compile executables.
#-----------------------------------------------------------------------
TEA_SETUP_COMPILER
#-----------------------------------------------------------------------
# __CHANGE__
# Specify the C source files to compile in TEA_ADD_SOURCES,
# public headers that need to be installed in TEA_ADD_HEADERS,
# stub library C source files to compile in TEA_ADD_STUB_SOURCES,
# and runtime Tcl library files in TEA_ADD_TCL_SOURCES.
# This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS
# and PKG_TCL_SOURCES.
#-----------------------------------------------------------------------
TEA_ADD_SOURCES([
itcl2TclOO.c
itclBase.c
itclBuiltin.c
itclClass.c
itclCmd.c
itclEnsemble.c
itclHelpers.c
itclInfo.c
itclLinkage.c
itclMethod.c
itclObject.c
itclParse.c
itclStubs.c
itclStubInit.c
itclResolve.c
itclTclIntStubsFcn.c
itclUtil.c
itclMigrate2TclCore.c
itclTestRegisterC.c
])
TEA_ADD_HEADERS([generic/itcl.h
generic/itclDecls.h
generic/itclInt.h
generic/itclMigrate2TclCore.h
generic/itclTclIntStubsFcn.h
generic/itcl2TclOO.h
generic/itclIntDecls.h
])
TEA_ADD_INCLUDES([-I. -I\"`${CYGPATH} ${srcdir}/generic`\"])
TEA_ADD_LIBS([])
TEA_ADD_CFLAGS([])
TEA_ADD_STUB_SOURCES(itclStubLib.c)
TEA_ADD_TCL_SOURCES([library/itcl.tcl library/itclWidget.tcl library/itclHullCmds.tcl])
#--------------------------------------------------------------------
# __CHANGE__
#
# You can add more files to clean if your extension creates any extra
# files by extending CLEANFILES.
# Add pkgIndex.tcl if it is generated in the Makefile instead of ./configure
# and change Makefile.in to move it from CONFIG_CLEAN_FILES to BINARIES var.
#
# A few miscellaneous platform-specific items:
# TEA_ADD_* any platform specific compiler/build info here.
#--------------------------------------------------------------------
#CLEANFILES="$CLEANFILES pkgIndex.tcl"
if test "${TEA_PLATFORM}" = "windows" ; then
# Ensure no empty if clauses
:
#TEA_ADD_SOURCES([win/winFile.c])
#TEA_ADD_INCLUDES([-I\"$(${CYGPATH} ${srcdir}/win)\"])
TEA_ADD_SOURCES([dllEntryPoint.c])
else
# Ensure no empty else clauses
:
#TEA_ADD_SOURCES([unix/unixFile.c])
#TEA_ADD_LIBS([-lsuperfly])
fi
#--------------------------------------------------------------------
# __CHANGE__
# Choose which headers you need. Extension authors should try very
# hard to only rely on the Tcl public header files. Internal headers
# contain private data structures and are subject to change without
# notice.
# This MUST be called after TEA_LOAD_TCLCONFIG / TEA_LOAD_TKCONFIG
#--------------------------------------------------------------------
#TEA_PUBLIC_TCL_HEADERS
TEA_PRIVATE_TCL_HEADERS
#TEA_PUBLIC_TK_HEADERS
#TEA_PRIVATE_TK_HEADERS
#TEA_PATH_X
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
# This auto-enables if Tcl was compiled threaded.
#--------------------------------------------------------------------
TEA_ENABLE_THREADS
#--------------------------------------------------------------------
# The statement below defines a collection of symbols related to
# building as a shared library instead of a static library.
#--------------------------------------------------------------------
TEA_ENABLE_SHARED
#--------------------------------------------------------------------
# This macro figures out what flags to use with the compiler/linker
# when building shared/static debug/optimized objects. This information
# can be taken from the tclConfig.sh file, but this figures it all out.
#--------------------------------------------------------------------
TEA_CONFIG_CFLAGS
#--------------------------------------------------------------------
# Set the default compiler switches based on the --enable-symbols option.
#--------------------------------------------------------------------
TEA_ENABLE_SYMBOLS
#--------------------------------------------------------------------
# Check for intptr_t (for INT2PTR & PTR2INT macros).
#--------------------------------------------------------------------
AC_CHECK_TYPE([intptr_t], [
AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
for tcl_cv_intptr_t in "int" "long" "long long" none; do
if test "$tcl_cv_intptr_t" != none; then
AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT],
[[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])],
[tcl_ok=yes], [tcl_ok=no])
test "$tcl_ok" = yes && break; fi
done])
if test "$tcl_cv_intptr_t" != none; then
AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer
type wide enough to hold a pointer.])
fi
])
#--------------------------------------------------------------------
# This macro generates a line to use when building a library. It
# depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
# and TEA_LOAD_TCLCONFIG macros above.
#--------------------------------------------------------------------
TEA_MAKE_LIB
#--------------------------------------------------------------------
# Determine the name of the tclsh and/or wish executables in the
# Tcl and Tk build directories or the location they were installed
# into. These paths are used to support running test cases only,
# the Makefile should not be making use of these paths to generate
# a pkgIndex.tcl file or anything else at extension build time.
#--------------------------------------------------------------------
TEA_PROG_TCLSH
#TEA_PROG_WISH
#--------------------------------------------------------------------
# These are for itclConfig.sh
#--------------------------------------------------------------------
TEA_EXPORT_CONFIG([itcl])
# itcl_SRC_DIR must be a fully qualified path
eval itcl_SRC_DIR="$srcdir"
itcl_SRC_DIR=`cd "${itcl_SRC_DIR}"; pwd`
AC_SUBST(itcl_SRC_DIR)
eval itcl_INCLUDE_SPEC="-I${itcl_SRC_DIR}/generic"
AC_SUBST(itcl_INCLUDE_SPEC)
#--------------------------------------------------------------------
# Finally, substitute all of the various values into the Makefile.
# You may alternatively have a special pkgIndex.tcl.in or other files
# which require substituting the AC variables in. Include these here.
#--------------------------------------------------------------------
AC_OUTPUT([Makefile pkgIndex.tcl itclConfig.sh])

55
pkgs/itcl4.2.0/doc/Class.3 Normal file
View File

@@ -0,0 +1,55 @@
'\"
'\" 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.
'\"
.TH Itcl_CreateClass 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_CreateClass, Itcl_DeleteClass, Itcl_FindClass, Itcl_IsClass, Itcl_IsClassNamespace \- Manipulate classes.
.SH SYNOPSIS
.nf
\fB#include <itclInt.h>\fR
int
\fBItcl_CreateClass\fR(\fIinterp, path, info, rPtr\fR)
int
\fBItcl_DeleteClass\fR(\fIinterp, cdefnPtr\fR)
ItclClass *
\fBItcl_FindClass\fR(\fIinterp, path, autoload\fR)
int
\fBItcl_IsClass\fR(\fIcmd\fR)
int
\fBItcl_IsClassNamespace\fR(\fInamesp\fR)
.fi
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Interpreter to modify.
.AP "CONST char" *path in
Path of the class.
.AP ItclObjectInfo *info in
TODO.
.AP ItclClass **rPtr in/out
The address of the pointer to modify.
.AP ItclClass *cdefnPtr in
Pointer to class info struct.
.AP int autoload in
Flag value for if the class should be autoloaded
.AP Tcl_Command cmd in
Command to check.
.AP Tcl_Namespace *namesp in
Namespace to check.
.BE
.SH DESCRIPTION
.PP
.SH KEYWORDS
class, find

58
pkgs/itcl4.2.0/doc/List.3 Normal file
View File

@@ -0,0 +1,58 @@
'\"
'\" 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.
'\"
.TH Itcl_InitList 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_InitList, Itcl_DeleteList, Itcl_CreateListElem, Itcl_DeleteListElem, Itcl_InsertList, Itcl_InsertListElem, Itcl_AppendList, Itcl_AppendListElem, Itcl_SetListValue \- Manipulate an Itcl list object.
.SH SYNOPSIS
.nf
\fB#include <itcl.h>\fR
void
\fBItcl_InitList\fR(\fIlist\fR)
void
\fBItcl_DeleteList\fR(\fIlist\fR)
Itcl_ListElem *
\fBItcl_CreateListElem\fR(\fIlist\fR)
Itcl_ListElem *
\fBItcl_DeleteListElem\fR(\fIelem\fR)
Itcl_ListElem *
\fBItcl_InsertList\fR(\fIlist, clientData\fR)
Itcl_ListElem *
\fBItcl_InsertListElem\fR(\fIelem, clientData\fR)
Itcl_ListElem *
\fBItcl_AppendList\fR(\fIlist, clientData\fR)
Itcl_ListElem *
\fBItcl_AppendListElem\fR(\fIelem, clientData\fR)
void
\fBItcl_SetListValue\fR(\fIelem, clientData\fR)
.fi
.SH ARGUMENTS
.AP Itcl_List *list in
List info structure.
.AP Itcl_ListElem *elem in
List element info structure.
.AP ClientData clientData in
Arbitrary one-word value to save in the list.
.BE
.SH DESCRIPTION
.PP
.SH KEYWORDS
list

38
pkgs/itcl4.2.0/doc/Object.3 Normal file
View File

@@ -0,0 +1,38 @@
'\"
'\" 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.
'\"
.TH Itcl_CreateObject 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_CreateObject, Itcl_DeleteObject, Itcl_FindObject, Itcl_IsObject, Itcl_IsObjectIsa \- Manipulate an class instance.
.SH SYNOPSIS
.nf
\fB#include <itclInt.h>\fR
void
\fBItcl_PreserveData\fR(\fIcdata\fR)
void
\fBItcl_ReleaseData\fR(\fIcdata\fR)
void
\fBItcl_EventuallyFree\fR(\fIcdata, fproc\fR)
.fi
.SH ARGUMENTS
.AP Tcl_FreeProc *fproc in
Address of function to call when the block is to be freed.
.AP ClientData clientData in
Arbitrary one-word value.
.BE
.SH DESCRIPTION
.PP
.SH KEYWORDS
free, memory

83
pkgs/itcl4.2.0/doc/Preserve.3 Normal file
View File

@@ -0,0 +1,83 @@
'\"
'\" 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.
'\"
.TH Itcl_PreserveData 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_Alloc, Itcl_Free, Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object.
.SH SYNOPSIS
.nf
\fB#include <itcl.h>\fR
void *
\fBItcl_Alloc\fR(\fIsize\fR)
void
\fBItcl_PreserveData\fR(\fIptr\fR)
void
\fBItcl_ReleaseData\fR(\fIptr\fR)
void
\fBItcl_EventuallyFree\fR(\fIptr, fproc\fR)
void
\fBItcl_Free\fR(\fIptr\fR)
.fi
.SH ARGUMENTS
.AP size_t size in
Number of bytes to allocate.
.AP void *ptr in
Pointer value allocated by \fBItcl_Alloc\fR.
.AP Tcl_FreeProc *fproc in
Address of function to call when the block is to be freed.
.BE
.SH DESCRIPTION
.PP
These procedures are used to allocate and release memory, especially blocks
of memory that will be used by multiple independent modules. They are similar
in function to the routines in the public Tcl interface, \fBTcl_Alloc\fR,
\fBTcl_Free\fR, \fBTcl_Preserve\fR, \fBTcl_Release\fR, and
\fBTcl_EventuallyFree\fR. The Tcl routines suffer from issues with
performance scaling as the number of blocks managed grows large. The facilities
of Itcl encounter these performance scaling issues and require an
alternative that does not suffer from them.
.PP
\fBItcl_Alloc\fR returns an untyped pointer to an allocated block
of memory of at least \fIsize\fR bytes. All \fIsize\fR bytes are
initialized to zero.
.PP
A module calls \fBItcl_PreserveData\fR on a pointer \fIptr\fR
allocated by \fBItcl_Alloc\fR to prevent deallocation of that memory while
the module remains interested in it.
.PP
A module calls \fBItcl_ReleaseData\fR on a pointer \fIptr\fR previously
preserved by \fBItcl_PreserveData\fR to indicate the module no longer has
an interest in the block of memory, and will not be disturbed by its
deallocation.
.PP
\fBItcl_EventuallyFree\fR is called on a pointer \fIptr\fR allocated by
\fBItcl_Alloc\fR to register a deallocation routine \fIfproc\fR to be
called when the number of calls to \fBItcl_ReleaseData\fR on \fIptr\fR
matches the number of calls to \fBItcl_PreserveData\fR on \fIptr\fR. This
condition indicates all modules have ended their interest in the block
of memory and a call to \fIfproc\fR with argument \fIptr\fR will deallocate
the memory that no module needs anymore.
.PP
\fBItcl_Free\fR is a deallocation routine for a \fIptr\fR value allocated
by \fBItcl_Alloc\fR. It may be called on any \fIptr\fR with no history of
an \fBItcl_PreserveData\fR call unmatched by an \fBItcl_ReleaseData\fR
call. It is best used as an \fIfproc\fR argument to \fBItcl_EventuallyFree\fR
or as a routine called from within such an \fIfproc\fR routine. It can also
be used to deallocate a \fIptr\fR value when it can be assured that value
has never been passed to \fBItcl_PreserveData\fR or \fBItcl_EventuallyFree\fR.
.SH KEYWORDS
free, memory

123
pkgs/itcl4.2.0/doc/RegisterC.3 Normal file
View File

@@ -0,0 +1,123 @@
'\"
'\" 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.
'\"
.TH Itcl_RegisterC 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_RegisterC, Itcl_RegisterObjC, Itcl_FindC \- Associate a symbolic name with a C procedure.
.SH SYNOPSIS
.nf
\fB#include <itcl.h>\fR
int
\fBItcl_RegisterC\fR(\fIinterp, cmdName, argProc, clientData, deleteProc\fR)
int
\fBItcl_RegisterObjC\fR(\fIinterp, cmdName, objProc, clientData, deleteProc\fR)
int
\fBItcl_FindC\fR(\fIinterp, cmdName, argProcPtr, objProcPtr, cDataPtr\fR)
.fi
.SH ARGUMENTS
.AP Tcl_Interp *interp in
Interpreter in which to create new command.
.VS 8.4
.AP "CONST char" *cmdName in
.VE
Name of command.
.AP Tcl_CmdProc *argProc in
Implementation of new command: \fIargProc\fR will be called whenever
.AP Tcl_CmdProc **argProcPtr in/out
The Tcl_CmdProc * to receive the pointer.
.AP Tcl_ObjCmdProc *objProc in
Implementation of the new command: \fIobjProc\fR will be called whenever
.AP Tcl_ObjCmdProc **objProcPtr in/out
The Tcl_ObjCmdProc * to receive the pointer.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR.
.AP ClientData *cDataPtr in/out
The ClientData to receive the pointer.
.AP Tcl_CmdDeleteProc *deleteProc in
Procedure to call before \fIcmdName\fR is deleted from the interpreter;
allows for command-specific cleanup. If NULL, then no procedure is
called before the command is deleted.
.BE
.SH DESCRIPTION
.PP
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.
.PP
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.
.PP
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.
.PP
Returns TCL_OK on success, or TCL_ERROR (along with an error message
in interp->result) if anything goes wrong.
.PP
C procedures can be integrated into an \fB[incr\ Tcl]\fR class
definition to implement methods, procs, and the "config" code
for public variables. Any body that starts with "\fB@\fR"
is treated as the symbolic name for a C procedure.
.PP
Symbolic names are established by registering procedures via
\fBItcl_RegisterC()\fR. This is usually done in the \fBTcl_AppInit()\fR
procedure, which is automatically called when the interpreter starts up.
In the following example, the procedure \fCMy_FooCmd()\fR is registered
with the symbolic name "foo". This procedure can be referenced in
the \fBbody\fR command as "\fC@foo\fR".
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
C procedures are implemented just like ordinary Tcl commands.
See the \fBCrtCommand\fR man page for details. Within the procedure,
class data members can be accessed like ordinary variables
using \fBTcl_SetVar()\fR, \fBTcl_GetVar()\fR, \fBTcl_TraceVar()\fR,
etc. Class methods and procs can be executed like ordinary commands
using \fBTcl_Eval()\fR. \fB[incr\ Tcl]\fR makes this possible by
automatically setting up the context before executing the C procedure.
.PP
This scheme provides a natural migration path for code development.
Classes can be developed quickly using Tcl code to implement the
bodies. An entire application can be built and tested. When
necessary, individual bodies can be implemented with C code to
improve performance.
.PP
See the Archetype class in \fB[incr\ Tk]\fR for an example of how this
C linking method is used.
.SH "SEE ALSO"
Tcl_CreateCommand, Tcl_CreateObjCommand
.SH KEYWORDS
class, object

59
pkgs/itcl4.2.0/doc/Stack.3 Normal file
View File

@@ -0,0 +1,59 @@
'\"
'\" 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.
'\"
.TH Itcl_InitStack 3 3.0 itcl "[incr\ Tcl] Library Procedures"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
Itcl_InitStack, Itcl_DeleteStack, Itcl_PushStack, Itcl_PopStack, Itcl_PeekStack, Itcl_GetStackValue, Itcl_GetStackSize \- Manipulate an Itcl stack object.
.SH SYNOPSIS
.nf
\fB#include <itcl.h>\fR
int
\fBItcl_InitStack\fR(\fIstack\fR)
int
\fBItcl_DeleteStack\fR(\fIstack\fR)
int
\fBItcl_PushStack\fR(\fIcdata, stack\fR)
ClientData
\fBItcl_PopStack\fR(\fIstack\fR)
ClientData
\fBItcl_PeekStack\fR(\fIstack\fR)
ClientData
\fBItcl_GetStackValue\fR(\fIstack, pos\fR)
int
\fBItcl_GetStackSize\fR(\fIstack\fR)
.fi
.SH ARGUMENTS
.AP Itcl_Stack *stack in
Stack info structure.
.AP int pos in
position in stack order from the top.
.AP ClientData clientData in
Arbitrary one-word value to save in the stack.
.BE
.SH DESCRIPTION
.PP
\fBItcl_InitStack\fR initializes a stack structure and \fBItcl_DeleteStack\fR
deletes it. \fBItcl_PushStack\fR pushes the \fIcdata\fR value onto the stack.
\fBItcl_PopStack\fR removes and returns the top most \fIcdata\fR value.
\fBItcl_PeekStack\fR returns the top most value, but does not remove it.
\fBItcl_GetStackValue\fR gets a value at some index within the stack. Index
"0" is the first value pushed onto the stack. \fBItcl_GetStackSize\fR
returns the count of entries on the stack.
.SH KEYWORDS
stack

122
pkgs/itcl4.2.0/doc/body.n Normal file
View File

@@ -0,0 +1,122 @@
'\"
'\" 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.
'\"
.TH body n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::body \- change the body for a class method/proc
.SH SYNOPSIS
\fBitcl::body \fIclassName\fB::\fIfunction args body\fR
.BE
.SH DESCRIPTION
.PP
The \fBbody\fR command is used outside of an \fB[incr\ Tcl]\fR
class definition to define or redefine the body of a class
method or proc. This facility allows a class definition
to have separate "interface" and "implementation" parts.
The "interface" part is a \fBclass\fR command with declarations
for methods, procs, instance variables and common variables.
The "implementation" part is a series of \fBbody\fR and
\fBconfigbody\fR commands. If the "implementation" part
is kept in a separate file, it can be sourced again and
again as bugs are fixed, to support interactive development.
When using the "tcl" mode in the \fBemacs\fR editor, the
"interface" and "implementation" parts can be kept in the
same file; as bugs are fixed, individual bodies can be
highlighted and sent to the test application.
.PP
The name "\fIclassName\fB::\fIfunction\fR"
identifies the method/proc being changed.
.PP
If an \fIargs\fR list was specified when the \fIfunction\fR was
defined in the class definition, the \fIargs\fR list for the
\fBbody\fR command must match in meaning. Variable names
can change, but the argument lists must have the same required
arguments and the same default values for optional arguments.
The special \fBargs\fR argument acts as a wildcard when included
in the \fIargs\fR list in the class definition; it will match
zero or more arguments of any type when the body is redefined.
.PP
If the \fIbody\fR string starts with "\fB@\fR", it is treated
as the symbolic name for a C procedure. The \fIargs\fR list
has little meaning for the C procedure, except to document
the expected usage. (The C procedure is not guaranteed to
use arguments in this manner.) If \fIbody\fR does not start
with "\fB@\fR", it is treated as a Tcl command script. When
the function is invoked, command line arguments are matched
against the \fIargs\fR list, and local variables are created
to represent each argument. This is the usual behavior for
a Tcl-style proc.
.PP
Symbolic names for C procedures are established by registering
procedures via \fBItcl_RegisterC()\fR. This is usually done
in the \fBTcl_AppInit()\fR procedure, which is automatically called
when the interpreter starts up. In the following example,
the procedure \fCMy_FooCmd()\fR is registered with the
symbolic name "foo". This procedure can be referenced in
the \fBbody\fR command as "\fC@foo\fR".
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
.SH EXAMPLE
In the following example, a "File" class is defined to represent
open files. The method bodies are included below the class
definition via the \fBbody\fR command. Note that the bodies
of the constructor/destructor must be included in the class
definition, but they can be redefined via the \fBbody\fR command
as well.
.CS
itcl::class File {
private variable fid ""
constructor {name access} {
set fid [open $name $access]
}
destructor {
close $fid
}
method get {}
method put {line}
method eof {}
}
itcl::body File::get {} {
return [gets $fid]
}
itcl::body File::put {line} {
puts $fid $line
}
itcl::body File::eof {} {
return [::eof $fid]
}
#
# See the File class in action:
#
File x /etc/passwd "r"
while {![x eof]} {
puts "=> [x get]"
}
itcl::delete object x
.CE
.SH KEYWORDS
class, object, procedure

542
pkgs/itcl4.2.0/doc/class.n Normal file
View File

@@ -0,0 +1,542 @@
'\"
'\" 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.
'\"
.TH class n "" itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::class \- create a class of objects
.SH SYNOPSIS
.nf
\fBitcl::class \fIclassName \fB{\fR
\fBinherit \fIbaseClass\fR ?\fIbaseClass\fR...?
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
\fBdestructor \fIbody\fR
\fBmethod \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBproc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBvariable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBcommon \fIvarName\fR ?\fIinit\fR?
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
\fBset \fIvarName\fR ?\fIvalue\fR?
\fBarray \fIoption\fR ?\fIarg arg ...\fR?
\fB}\fR
\fIclassName objName\fR ?\fIarg arg ...\fR?
\fIobjName method\fR ?\fIarg arg ...\fR?
\fIclassName::proc\fR ?\fIarg arg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The fundamental construct in \fB[incr\ Tcl]\fR is the class definition.
Each class acts as a template for actual objects that can be created.
The class itself is a namespace which contains things common to all
objects. Each object has its own unique bundle of data which contains
instances of the "variables" defined in the class definition. Each
object also has a built-in variable named "this", which contains the
name of the object. Classes can also have "common" data members that
are shared by all objects in a class.
.PP
Two types of functions can be included in the class definition.
"Methods" are functions which operate on a specific object, and
therefore have access to both "variables" and "common" data members.
"Procs" are ordinary procedures in the class namespace, and only
have access to "common" data members.
.PP
If the body of any method or proc starts with "\fB@\fR", it is treated
as the symbolic name for a C procedure. Otherwise, it is treated as
a Tcl code script. See below for details on registering and using
C procedures.
.PP
A class can only be defined once, although the bodies of class
methods and procs can be defined again and again for interactive
debugging. See the \fBbody\fR and \fBconfigbody\fR commands for
details.
.PP
Each namespace can have its own collection of objects and classes.
The list of classes available in the current context can be queried
using the "\fBitcl::find classes\fR" command, and the list of objects,
with the "\fBitcl::find objects\fR" command.
.PP
A class can be deleted using the "\fBdelete class\fR" command.
Individual objects can be deleted using the "\fBdelete object\fR"
command.
.SH "CLASS DEFINITIONS"
.TP
\fBclass \fIclassName definition\fR
.
Provides the definition for a class named \fIclassName\fR. If
the class \fIclassName\fR already exists, or if a command called
\fIclassName\fR exists in the current namespace context, this
command returns an error. If the class definition is successfully
parsed, \fIclassName\fR becomes a command in the current context,
handling the creation of objects for this class.
.PP
The class \fIdefinition\fR is evaluated as a series of Tcl
statements that define elements within the class. The following
class definition commands are recognized:
.RS
.TP
\fBinherit \fIbaseClass\fR ?\fIbaseClass\fR...?
.
Causes the current class to inherit characteristics from one or
more base classes. Classes must have been defined by a previous
\fBclass\fR command, or must be available to the auto-loading
facility (see "AUTO-LOADING" below). A single class definition
can contain no more than one \fBinherit\fR command.
.RS
.PP
The order of \fIbaseClass\fR names in the \fBinherit\fR list
affects the name resolution for class members. When the same
member name appears in two or more base classes, the base class
that appears first in the \fBinherit\fR list takes precedence.
For example, if classes "Foo" and "Bar" both contain the member
"x", and if another class has the "\fBinherit\fR" statement:
.PP
.CS
inherit Foo Bar
.CE
.PP
then the name "x" means "Foo::x". Other inherited members named
"x" must be referenced with their explicit name, like "Bar::x".
.RE
.TP
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
.
Declares the \fIargs\fR argument list and \fIbody\fR used for
the constructor, which is automatically invoked whenever an
object is created.
.RS
.PP
Before the \fIbody\fR is executed, the
optional \fIinit\fR statement is used to invoke any base class
constructors that require arguments. Variables in the \fIargs\fR
specification can be accessed in the \fIinit\fR code fragment,
and passed to base class constructors. After evaluating the
\fIinit\fR statement, any base class constructors that have
not been executed are invoked automatically without arguments.
This ensures that all base classes are fully constructed before
the constructor \fIbody\fR is executed. By default, this
scheme causes constructors to be invoked in order from least-
to most-specific. This is exactly the opposite of the order
that classes are reported by the \fBinfo heritage\fR command.
.PP
If construction is successful, the constructor always returns
the object name\-regardless of how the \fIbody\fR is defined\-and
the object name becomes a command in the current namespace context.
If construction fails, an error message is returned.
.RE
.TP
\fBdestructor \fIbody\fR
.
Declares the \fIbody\fR used for the destructor, which is automatically
invoked when an object is deleted. If the destructor is successful,
the object data is destroyed and the object name is removed as a command
from the interpreter. If destruction fails, an error message is returned
and the object remains.
.RS
.PP
When an object is destroyed, all destructors in its class hierarchy
are invoked in order from most- to least-specific. This is the
order that the classes are reported by the "\fBinfo heritage\fR"
command, and it is exactly the opposite of the default constructor
order.
.RE
.TP
\fBmethod \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a method called \fIname\fR. When the method \fIbody\fR is
executed, it will have automatic access to object-specific variables
and common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this method. The \fBbody\fR command can be used
to redefine the method body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another class method, a method can be invoked
like any other command\-simply by using its name. Outside of the
class context, the method name must be prefaced an object name,
which provides the context for the data that it manipulates.
Methods in a base class that are redefined in the current class,
or hidden by another base class, can be qualified using the
"\fIclassName\fR::\fImethod\fR" syntax.
.RE
.TP
\fBproc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a proc called \fIname\fR. A proc is an ordinary procedure
within the class namespace. Unlike a method, a proc is invoked
without referring to a specific object. When the proc \fIbody\fR is
executed, it will have automatic access only to common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this proc. The \fBbody\fR command can be used
to redefine the proc body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another class method or proc, a proc can be
invoked like any other command\-simply by using its name.
In any other namespace context, the proc is invoked using a
qualified name like "\fIclassName\fB::\fIproc\fR". Procs in
a base class that are redefined in the current class, or hidden
by another base class, can also be accessed via their qualified
name.
.RE
.TP
\fBvariable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
.
Defines an object-specific variable named \fIvarName\fR. All
object-specific variables are automatically available in class
methods. They need not be declared with anything like the
\fBglobal\fR command.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable when a new object is created.
Initialization forces the variable to be a simple scalar
value; uninitialized variables, on the other hand, can be set
within the constructor and used as arrays.
.PP
The optional \fIconfig\fR script is only allowed for public variables.
If specified, this code fragment is executed whenever a public
variable is modified by the built-in "configure" method. The
\fIconfig\fR script can also be specified outside of the class
definition using the \fBconfigbody\fR command.
.RE
.TP
\fBcommon \fIvarName\fR ?\fIinit\fR?
.
Declares a common variable named \fIvarName\fR. Common variables
reside in the class namespace and are shared by all objects belonging
to the class. They are just like global variables, except that
they need not be declared with the usual \fBglobal\fR command.
They are automatically visible in all class methods and procs.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable. Initialization forces the variable
to be a simple scalar value; uninitialized variables, on the other
hand, can be set with subsequent \fBset\fR and \fBarray\fR commands
and used as arrays.
.PP
Once a common data member has been defined, it can be set using
\fBset\fR and \fBarray\fR commands within the class definition.
This allows common data members to be initialized as arrays.
For example:
.PP
.CS
itcl::class Foo {
common boolean
set boolean(true) 1
set boolean(false) 0
}
.CE
.PP
Note that if common data members are initialized within the
constructor, they get initialized again and again whenever new
objects are created.
.RE
.TP
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
.
These commands are used to set the protection level for class
members that are created when \fIcommand\fR is evaluated.
The \fIcommand\fR is usually \fBmethod\fR, \fBproc\fR,
\fBvariable\fR or\fBcommon\fR, and the remaining \fIarg\fR's
complete the member definition. However, \fIcommand\fR can
also be a script containing many different member definitions,
and the protection level will apply to all of the members
that are created.
.RE
.SH "CLASS USAGE"
.PP
Once a class has been defined, the class name can be used as a
command to create new objects belonging to the class.
.TP
\fIclassName objName\fR ?\fIargs...\fR?
.
Creates a new object in class \fIclassName\fR with the name \fIobjName\fR.
Remaining arguments are passed to the constructor of the most-specific
class. This in turn passes arguments to base class constructors before
invoking its own body of commands. If construction is successful, a
command called \fIobjName\fR is created in the current namespace context,
and \fIobjName\fR is returned as the result of this operation.
If an error is encountered during construction, the destructors are
automatically invoked to free any resources that have been allocated,
the object is deleted, and an error is returned.
.RS
.PP
If \fIobjName\fR contains the string "\fB#auto\fR", that string is
replaced with an automatically generated name. Names have the
form \fIclassName<number>\fR, where the \fIclassName\fR part is
modified to start with a lowercase letter. In class "Toaster",
for example, the "\fB#auto\fR" specification would produce names
like toaster0, toaster1, etc. Note that "\fB#auto\fR" can be
also be buried within an object name:
.PP
.CS
fileselectiondialog .foo.bar.#auto -background red
.CE
.PP
This would generate an object named ".foo.bar.fileselectiondialog0".
.RE
.SH "OBJECT USAGE"
.PP
Once an object has been created, the object name can be used
as a command to invoke methods that operate on the object.
.TP
\fIobjName method\fR ?\fIargs...\fR?
.
Invokes a method named \fImethod\fR on an object named \fIobjName\fR.
Remaining arguments are passed to the argument list for the
method. The method name can be "constructor", "destructor",
any method name appearing in the class definition, or any of
the following built-in methods.
.SH "BUILT-IN METHODS"
.TP
\fIobjName \fBcget option\fR
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "cget" operation for Tk widgets.
The \fIoption\fR argument is a string of the form "\fB-\fIvarName\fR",
and this method returns the current value of the public variable
\fIvarName\fR.
.TP
\fIobjName \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR?
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "configure" operation for Tk widgets.
With no arguments, this method returns a list of lists describing
all of the public variables. Each list has three elements: the
variable name, its initial value and its current value.
.RS
.PP
If a single \fIoption\fR of the form "\fB-\fIvarName\fR" is specified,
then this method returns the information for that one variable.
.PP
Otherwise, the arguments are treated as \fIoption\fR/\fIvalue\fR
pairs assigning new values to public variables. Each variable
is assigned its new value, and if it has any "config" code associated
with it, it is executed in the context of the class where it was
defined. If the "config" code generates an error, the variable
is set back to its previous value, and the \fBconfigure\fR method
returns an error.
.RE
.TP
\fIobjName \fBisa \fIclassName\fR
.
Returns non-zero if the given \fIclassName\fR can be found in the
object's heritage, and zero otherwise.
.TP
\fIobjName \fBinfo \fIoption\fR ?\fIargs...\fR?
.
Returns information related to a particular object named
\fIobjName\fR, or to its class definition. The \fIoption\fR
parameter includes the following things, as well as the options
recognized by the usual Tcl "info" command:
.RS
.TP
\fIobjName \fBinfo class\fR
.
Returns the name of the most-specific class for object \fIobjName\fR.
.TP
\fIobjName \fBinfo inherit\fR
.
Returns the list of base classes as they were defined in the
"\fBinherit\fR" command, or an empty string if this class
has no base classes.
.TP
\fIobjName \fBinfo heritage\fR
.
Returns the current class name and the entire list of base classes
in the order that they are traversed for member lookup and object
destruction.
.TP
\fIobjName \fBinfo function\fR ?\fIcmdName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-args\fR? ?\fB-body\fR?
.
With no arguments, this command returns a list of all class methods
and procs. If \fIcmdName\fR is specified, it returns information
for a specific method or proc. If no flags are specified, this
command returns a list with the following elements: the protection
level, the type (method/proc), the qualified name, the argument list
and the body. Flags can be used to request specific elements from
this list.
.TP
\fIobjName \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR? ?\fB-scope\fR?
.
With no arguments, this command returns a list of all object-specific
variables and common data members. If \fIvarName\fR is specified, it
returns information for a specific data member.
Flags can be specified with \fIvarName\fR in an arbitrary order.
The result is a list of the specific information in exactly the
same order as the flags are specified.
If no flags are given, this command returns a list
as if the followings flags have been specified:
.IP
\fB-protection\fR \fB-type\fR \fB-name\fR \fB-init\fR \fB-value\fR ?\fB-config\fR?
The \fB-config\fR result is only present if \fIvarName\fR is a public
variable. It contains the code that is executed at initialization
of \fIvarName\fR. The \fB-scope\fR flag gives the namespace context
of \fIvarName\fR. Herewith the variable can be accessed from outside
the object like any other variable. It is similar to the result of
the \fBitcl::scope\fR command.
.RE
.SH "CHAINING METHODS/PROCS"
.PP
Sometimes a base class has a method or proc that is redefined with
the same name in a derived class. This is a way of making the
derived class handle the same operations as the base class, but
with its own specialized behavior. For example, suppose we have
a Toaster class that looks like this:
.PP
.CS
itcl::class Toaster {
variable crumbs 0
method toast {nslices} {
if {$crumbs > 50} {
error "== FIRE! FIRE! =="
}
set crumbs [expr {$crumbs+4*$nslices}]
}
method clean {} {
set crumbs 0
}
}
.CE
.PP
We might create another class like SmartToaster that redefines
the "toast" method. If we want to access the base class method,
we can qualify it with the base class name, to avoid ambiguity:
.PP
.CS
itcl::class SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [Toaster::toast $nslices]
}
}
.CE
.PP
Instead of hard-coding the base class name, we can use the
"chain" command like this:
.PP
.CS
itcl::class SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [chain $nslices]
}
}
.CE
.PP
The chain command searches through the class hierarchy for
a slightly more generic (base class) implementation of a method
or proc, and invokes it with the specified arguments. It starts
at the current class context and searches through base classes
in the order that they are reported by the "info heritage" command.
If another implementation is not found, this command does nothing
and returns the null string.
.SH "AUTO-LOADING"
.PP
Class definitions need not be loaded explicitly; they can be loaded as
needed by the usual Tcl auto-loading facility. Each directory containing
class definition files should have an accompanying "tclIndex" file.
Each line in this file identifies a Tcl procedure or \fB[incr\ Tcl]\fR
class definition and the file where the definition can be found.
.PP
For example, suppose a directory contains the definitions for classes
"Toaster" and "SmartToaster". Then the "tclIndex" file for this
directory would look like:
.PP
.CS
# Tcl autoload index file, version 2.0 for [incr Tcl]
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.
set auto_index(::Toaster) "source $dir/Toaster.itcl"
set auto_index(::SmartToaster) "source $dir/SmartToaster.itcl"
.CE
.PP
The \fBauto_mkindex\fR command is used to automatically
generate "tclIndex" files.
.PP
The auto-loader must be made aware of this directory by appending
the directory name to the "auto_path" variable. When this is in
place, classes will be auto-loaded as needed when used in an
application.
.SH "C PROCEDURES"
.PP
C procedures can be integrated into an \fB[incr\ Tcl]\fR class
definition to implement methods, procs, and the "config" code
for public variables. Any body that starts with "\fB@\fR"
is treated as the symbolic name for a C procedure.
.PP
Symbolic names are established by registering procedures via
\fBItcl_RegisterC()\fR. This is usually done in the \fBTcl_AppInit()\fR
procedure, which is automatically called when the interpreter starts up.
In the following example, the procedure \fCMy_FooCmd()\fR is registered
with the symbolic name "foo". This procedure can be referenced in
the \fBbody\fR command as "\fC@foo\fR".
.PP
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
.PP
C procedures are implemented just like ordinary Tcl commands.
See the \fBCrtCommand\fR man page for details. Within the procedure,
class data members can be accessed like ordinary variables
using \fBTcl_SetVar()\fR, \fBTcl_GetVar()\fR, \fBTcl_TraceVar()\fR,
etc. Class methods and procs can be executed like ordinary commands
using \fBTcl_Eval()\fR. \fB[incr\ Tcl]\fR makes this possible by
automatically setting up the context before executing the C procedure.
.PP
This scheme provides a natural migration path for code development.
Classes can be developed quickly using Tcl code to implement the
bodies. An entire application can be built and tested. When
necessary, individual bodies can be implemented with C code to
improve performance.
.SH KEYWORDS
class, object, object-oriented

94
pkgs/itcl4.2.0/doc/code.n Normal file
View File

@@ -0,0 +1,94 @@
'\"
'\" 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.
'\"
.TH code n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::code \- capture the namespace context for a code fragment
.SH SYNOPSIS
\fBitcl::code \fR?\fB-namespace \fIname\fR? \fIcommand \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
Creates a scoped value for the specified \fIcommand\fR and its
associated \fIarg\fR arguments. A scoped value is a list with three
elements: the "\fC@scope\fR" keyword, a namespace context,
and a value string. For example, the command
.CS
namespace foo {
code puts "Hello World!"
}
.CE
produces the scoped value:
.CS
@scope ::foo {puts {Hello World!}}
.CE
Note that the \fBcode\fR command captures the current namespace
context. If the \fB-namespace\fR flag is specified, then the
current context is ignored, and the \fIname\fR string is used
as the namespace context.
.PP
Extensions like Tk execute ordinary code fragments in the global
namespace. A scoped value captures a code fragment together with
its namespace context in a way that allows it to be executed
properly later. It is needed, for example, to wrap up code fragments
when a Tk widget is used within a namespace:
.CS
namespace foo {
private proc report {mesg} {
puts "click: $mesg"
}
button .b1 -text "Push Me" \
-command [code report "Hello World!"]
pack .b1
}
.CE
The code fragment associated with button \fC.b1\fR only makes
sense in the context of namespace "foo". Furthermore, the
"report" procedure is private, and can only be accessed within
that namespace. The \fBcode\fR command wraps up the code
fragment in a way that allows it to be executed properly
when the button is pressed.
.PP
Also, note that the \fBcode\fR command preserves the integrity
of arguments on the command line. This makes it a natural replacement
for the \fBlist\fR command, which is often used to format Tcl code
fragments. In other words, instead of using the \fBlist\fR command
like this:
.CS
after 1000 [list puts "Hello $name!"]
.CE
use the \fBcode\fR command like this:
.CS
after 1000 [code puts "Hello $name!"]
.CE
This not only formats the command correctly, but also captures
its namespace context.
.PP
Scoped commands can be invoked like ordinary code fragments, with
or without the \fBeval\fR command. For example, the following
statements work properly:
.CS
set cmd {@scope ::foo .b1}
$cmd configure -background red
set opts {-bg blue -fg white}
eval $cmd configure $opts
.CE
Note that scoped commands by-pass the usual protection mechanisms;
the command:
.CS
@scope ::foo {report {Hello World!}}
.CE
can be used to access the "foo::report" proc from any namespace
context, even though it is private.
.SH KEYWORDS
scope, callback, namespace, public, protected, private

127
pkgs/itcl4.2.0/doc/configbody.n Normal file
View File

@@ -0,0 +1,127 @@
'\"
'\" 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.
'\"
.TH configbody n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::configbody \- change the "config" code for a public variable
.SH SYNOPSIS
\fBitcl::configbody \fIclassName\fB::\fIvarName body\fR
.BE
.SH DESCRIPTION
.PP
The \fBconfigbody\fR command is used outside of an \fB[incr\ Tcl]\fR
class definition to define or redefine the configuration code
associated with a public variable. Public variables act like
configuration options for an object. They can be modified
outside the class scope using the built-in \fBconfigure\fR method.
Each variable can have a bit of "config" code associate with it
that is automatically executed when the variable is configured.
The \fBconfigbody\fR command can be used to define or redefine
this body of code.
.PP
Like the \fBbody\fR command, this facility allows a class definition
to have separate "interface" and "implementation" parts.
The "interface" part is a \fBclass\fR command with declarations
for methods, procs, instance variables and common variables.
The "implementation" part is a series of \fBbody\fR and
\fBconfigbody\fR commands. If the "implementation" part
is kept in a separate file, it can be sourced again and
again as bugs are fixed, to support interactive development.
When using the "tcl" mode in the \fBemacs\fR editor, the
"interface" and "implementation" parts can be kept in the
same file; as bugs are fixed, individual bodies can be
highlighted and sent to the test application.
.PP
The name "\fIclassName\fB::\fIvarName\fR"
identifies the public variable being updated.
If the \fIbody\fR string starts with "\fB@\fR", it is treated
as the symbolic name for a C procedure. Otherwise, it is
treated as a Tcl command script.
.PP
Symbolic names for C procedures are established by registering
procedures via \fBItcl_RegisterC()\fR. This is usually done
in the \fBTcl_AppInit()\fR procedure, which is automatically called
when the interpreter starts up. In the following example,
the procedure \fCMy_FooCmd()\fR is registered with the
symbolic name "foo". This procedure can be referenced in
the \fBconfigbody\fR command as "\fC@foo\fR".
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
.SH EXAMPLE
In the following example, a "File" class is defined to represent
open files. Whenever the "-name" option is configured, the
existing file is closed, and a new file is opened. Note that
the "config" code for a public variable is optional. The "-access"
option, for example, does not have it.
.CS
itcl::class File {
private variable fid ""
public variable name ""
public variable access "r"
constructor {args} {
eval configure $args
}
destructor {
if {$fid != ""} {
close $fid
}
}
method get {}
method put {line}
method eof {}
}
itcl::body File::get {} {
return [gets $fid]
}
itcl::body File::put {line} {
puts $fid $line
}
itcl::body File::eof {} {
return [::eof $fid]
}
itcl::configbody File::name {
if {$fid != ""} {
close $fid
}
set fid [open $name $access]
}
#
# See the File class in action:
#
File x
x configure -name /etc/passwd
while {![x eof]} {
puts "=> [x get]"
}
itcl::delete object x
.CE
.SH KEYWORDS
class, object, variable, configure

71
pkgs/itcl4.2.0/doc/delete.n Normal file
View File

@@ -0,0 +1,71 @@
'\"
'\" 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.
'\"
.TH delete n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::delete \- delete things in the interpreter
.SH SYNOPSIS
\fBitcl::delete \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBdelete\fR command is used to delete things in the interpreter.
It is implemented as an ensemble, so extensions can add their own
options and extend the behavior of this command. By default, the
\fBdelete\fR command handles the destruction of namespaces.
.PP
The \fIoption\fR argument determines what action is carried out
by the command. The legal \fIoptions\fR (which may be abbreviated)
are:
.TP
\fBdelete class \fIname\fR ?\fIname...\fR?
.
Deletes one or more \fB[incr\ Tcl]\fR classes called \fIname\fR.
This deletes all objects in the class, and all derived classes
as well.
.RS
.PP
If an error is encountered while destructing an object, it will
prevent the destruction of the class and any remaining objects.
To destroy the entire class without regard for errors, use the
"\fBdelete namespace\fR" command.
.RE
.TP
\fBdelete object \fIname\fR ?\fIname...\fR?
.
Deletes one or more \fB[incr\ Tcl]\fR objects called \fIname\fR.
An object is deleted by invoking all destructors in its class
hierarchy, in order from most- to least-specific. If all destructors
are successful, data associated with the object is deleted and
the \fIname\fR is removed as a command from the interpreter.
.RS
.PP
If the access command for an object resides in another namespace,
then its qualified name can be used:
.PP
.CS
itcl::delete object foo::bar::x
.CE
.PP
If an error is encountered while destructing an object, the
\fBdelete\fR command is aborted and the object remains alive.
To destroy an object without regard for errors, use the
"\fBrename\fR" command to destroy the object access command.
.RE
.TP
\fBdelete namespace \fIname\fR ?\fIname...\fR?
.
Deletes one or more namespaces called \fIname\fR. This deletes
all commands and variables in the namespace, and deletes all
child namespaces as well. When a namespace is deleted, it is
automatically removed from the import lists of all other namespaces.
.SH KEYWORDS
namespace, proc, variable, ensemble

178
pkgs/itcl4.2.0/doc/ensemble.n Normal file
View File

@@ -0,0 +1,178 @@
'\"
'\" 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.
'\"
.TH ensemble n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::ensemble \- create or modify a composite command
.SH SYNOPSIS
.nf
\fBitcl::ensemble \fIensName\fR ?\fIcommand arg arg...\fR?
.fi
or
.nf
\fBensemble \fIensName\fR {
\fBpart \fIpartName args body\fR
\fI...\fR
\fBensemble \fIpartName\fR {
\fBpart \fIsubPartName args body\fR
\fBpart \fIsubPartName args body\fR
\fI...\fR
}
}
.fi
.BE
.SH DESCRIPTION
.PP
The \fBensemble\fR command is used to create or modify a composite
command. See the section \fBWHAT IS AN ENSEMBLE?\fR below for a
brief overview of ensembles.
.PP
If the \fBensemble\fR command finds an existing ensemble called
\fIensName\fR, it updates that ensemble. Otherwise, it creates an
ensemble called \fIensName\fR. If the \fIensName\fR is a simple name
like "foo", then an ensemble command named "foo" is added to the
current namespace context. If a command named "foo" already exists
in that context, then it is deleted. If the \fIensName\fR contains
namespace qualifiers like "a::b::foo", then the namespace path is
resolved, and the ensemble command is added that namespace context.
Parent namespaces like "a" and "b" are created automatically, as needed.
.PP
If the \fIensName\fR contains spaces like "a::b::foo bar baz", then
additional words like "bar" and "baz" are treated as sub-ensembles.
Sub-ensembles are merely parts within an ensemble; they do not have
a Tcl command associated with them. An ensemble like "foo" can
have a sub-ensemble called "foo bar", which in turn can have a
sub-ensemble called "foo bar baz". In this case, the sub-ensemble
"foo bar" must be created before the sub-ensemble "foo bar baz"
that resides within it.
.PP
If there are any arguments following \fIensName\fR, then they are
treated as commands, and they are executed to update the ensemble.
The following commands are recognized in this context: \fBpart\fR
and \fBensemble\fR.
.PP
The \fBpart\fR command defines a new part for the ensemble.
Its syntax is identical to the usual \fBproc\fR command, but
it defines a part within an ensemble, instead of a Tcl command.
If a part called \fIpartName\fR already exists within the ensemble,
then the \fBpart\fR command returns an error.
.PP
The \fBensemble\fR command can be nested inside another \fBensemble\fR
command to define a sub-ensemble.
.SH "WHAT IS AN ENSEMBLE?"
.PP
The usual "info" command is a composite command--the command name
\fBinfo\fR must be followed by a sub-command like \fBbody\fR or \fBglobals\fR.
We will refer to a command like \fBinfo\fR as an \fIensemble\fR, and to
sub-commands like \fBbody\fR or \fBglobals\fR as its \fIparts\fR.
.PP
Ensembles can be nested. For example, the \fBinfo\fR command has
an ensemble \fBinfo namespace\fR within it. This ensemble has parts
like \fBinfo namespace all\fR and \fBinfo namespace children\fR.
.PP
With ensembles, composite commands can be created and extended
in an automatic way. Any package can find an existing ensemble
and add new parts to it. So extension writers can add their
own parts, for example, to the \fBinfo\fR command.
.PP
The ensemble facility manages all of the part names and keeps
track of unique abbreviations. Normally, you can abbreviate
\fBinfo complete\fR to \fBinfo comp\fR. But if an extension adds the
part \fBinfo complexity\fR, the minimum abbreviation for \fBinfo complete\fR
becomes \fBinfo complet\fR.
.PP
The ensemble facility not only automates the construction of
composite commands, but it automates the error handling as well.
If you invoke an ensemble command without specifying a part name,
you get an automatically generated error message that summarizes
the usage information. For example, when the \fBinfo\fR command
is invoked without any arguments, it produces the following error
message:
.PP
.CS
wrong # args: should be one of...
info args procname
info body procname
info cmdcount
info commands ?pattern?
info complete command
info context
info default procname arg varname
info exists varName
info globals ?pattern?
info level ?number?
info library
info locals ?pattern?
info namespace option ?arg arg ...?
info patchlevel
info procs ?pattern?
info protection ?-command? ?-variable? name
info script
info tclversion
info vars ?pattern?
info which ?-command? ?-variable? ?-namespace? name
.CE
.PP
You can also customize the way an ensemble responds to errors.
When an ensemble encounters an unspecified or ambiguous part
name, it looks for a part called \fB@error\fR. If it exists,
then it is used to handle the error. This part will receive all
of the arguments on the command line starting with the offending
part name. It can find another way of resolving the command,
or generate its own error message.
.SH EXAMPLE
.PP
We could use an ensemble to clean up the syntax of the various
"wait" commands in Tcl/Tk. Instead of using a series of
strange commands like this:
.PP
.CS
vwait x
tkwait visibility .top
tkwait window .
.CE
.PP
we could use commands with a uniform syntax, like this:
.PP
.CS
wait variable x
wait visibility .top
wait window .
.CE
.PP
The Tcl package could define the following ensemble:
.PP
.CS
itcl::ensemble wait part variable {name} {
uplevel vwait $name
}
.CE
.PP
The Tk package could add some options to this ensemble, with a
command like this:
.PP
.CS
itcl::ensemble wait {
part visibility {name} {
tkwait visibility $name
}
part window {name} {
tkwait window $name
}
}
.CE
.PP
Other extensions could add their own parts to the \fBwait\fR command
too.
.SH KEYWORDS
ensemble, part, info

77
pkgs/itcl4.2.0/doc/find.n Normal file
View File

@@ -0,0 +1,77 @@
'\"
'\" 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.
'\"
.TH find n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::find \- search for classes and objects
.SH SYNOPSIS
\fBitcl::find \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBfind\fR command is used to find classes and objects
that are available in the current interpreter. Classes and objects
are reported first in the active namespace, then in all other
namespaces in the interpreter.
.PP
The \fIoption\fR argument determines what action is carried out
by the command. The legal \fIoptions\fR (which may be abbreviated)
are:
.TP
\fBfind classes ?\fIpattern\fR?
.
Returns a list of [incr Tcl] classes. Classes in the current
namespace are listed first, followed by classes in all other
namespaces in the interpreter. If the optional \fIpattern\fR
is specified, then the reported names are compared using the rules
of the "\fBstring match\fR" command, and only matching names are
reported.
.RS
.PP
If a class resides in the current namespace context, this command
reports its simple name--without any qualifiers. However, if the
\fIpattern\fR contains \fB::\fR qualifiers, or if the class resides
in another context, this command reports its fully-qualified name.
Therefore, you can use the following command to obtain a list where
all names are fully-qualified:
.PP
.CS
itcl::find classes ::*
.CE
.RE
.TP
\fBfind objects ?\fIpattern\fR? ?\fB-class \fIclassName\fR? ?\fB-isa \fIclassName\fR?
.
Returns a list of [incr Tcl] objects. Objects in the current
namespace are listed first, followed by objects in all other
namespaces in the interpreter. If the optional \fIpattern\fR is
specified, then the reported names are compared using the rules
of the "\fBstring match\fR" command, and only matching names are
reported.
If the optional "\fB-class\fR" parameter is specified, this list is
restricted to objects whose most-specific class is \fIclassName\fR.
If the optional "\fB-isa\fR" parameter is specified, this list is
further restricted to objects having the given \fIclassName\fR
anywhere in their heritage.
.RS
.PP
If an object resides in the current namespace context, this command
reports its simple name--without any qualifiers. However, if the
\fIpattern\fR contains \fB::\fR qualifiers, or if the object resides
in another context, this command reports its fully-qualified name.
Therefore, you can use the following command to obtain a list where
all names are fully-qualified:
.PP
.CS
itcl::find objects ::*
.CE
.RE
.SH KEYWORDS
class, object, search, import

71
pkgs/itcl4.2.0/doc/is.n Normal file
View File

@@ -0,0 +1,71 @@
'\"
'\" 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.
'\"
.TH is n 3.3 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::is \- test argument to see if it is a class or an object
.SH SYNOPSIS
\fBitcl::is \fIoption\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBis\fR command is used to check if the argument given is
a class or an object; depending on the option given. If the argument
if a class or object, then 1 is returned. Otherwise, 0 is returned.
The \fBis\fR command also recognizes the commands wrapped in the
itcl \fBcode\fR command.
.PP
The \fIoption\fR argument determines what action is carried out
by the command. The legal \fIoptions\fR (which may be abbreviated)
are:
.TP
\fBis class \fIcommand\fR
.
Returns 1 if command is a class, and returns 0 otherwise.
.RS
.PP
The fully qualified name of the class needs to be given as the \fIcommand\fR
argument. So, if a class resides in a namespace, then the namespace needs to
be specified as well. So, if a class \fBC\fR resides in a namespace \fBN\fR, then
the command should be called like:
.PP
.CS
\fBis N::C\fR
or
\fBis ::N::C\fR
.CE
.RE
.TP
\fBis\fR object ?\fB-class \fIclassName\fR? \fIcommand\fR
.
Returns 1 if \fIcommand\fR is an object, and returns 0 otherwise.
.RS
.PP
If the optional "\fB-class\fR" parameter is specified, then the
\fIcommand\fR will be checked within the context of the class
given. Note that \fIclassName\fR has to exist. If not, then an
error will be given. So, if \fIclassName\fR is uncertain to be
a class, then the programmer will need to check it's existance
beforehand, or wrap it in a catch statement.
.PP
So, if \fBc\fR is an object in the class \fBC\fR, in namespace N then
these are the possibilities (all return 1):
.PP
.CS
set obj [N::C c]
itcl::is object N::c
itcl::is object c
itcl::is object $obj
itcl::is object [itcl::code c]
.CE
.RE
.SH KEYWORDS
class, object

145
pkgs/itcl4.2.0/doc/itcl.n Normal file
View File

@@ -0,0 +1,145 @@
'\"
'\" 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.
'\"
.TH itcl n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl \- object-oriented extensions to Tcl
.BE
.SH DESCRIPTION
.PP
\fB[incr\ Tcl]\fR provides object-oriented extensions to Tcl, much as
C++ provides object-oriented extensions to C. The emphasis of this
work, however, is not to create a whiz-bang object-oriented
programming environment. Rather, it is to support more structured
programming practices in Tcl without changing the flavor of the language.
More than anything else, \fB[incr\ Tcl]\fR provides a means of
encapsulating related procedures together with their shared data
in a namespace that is hidden from the outside world.
It encourages better programming by promoting the object-oriented
"library" mindset. It also allows for code re-use through inheritance.
.SH CLASSES
.PP
The fundamental construct in \fB[incr\ Tcl]\fR is the class definition.
Each class acts as a template for actual objects that can be created.
Each object has its own unique bundle of data, which contains instances
of the "variables" defined in the class. Special procedures called
"methods" are used to manipulate individual objects. Methods are just
like the operations that are used to manipulate Tk widgets. The
"\fBbutton\fR" widget, for example, has methods such as "flash" and
"invoke" that cause a particular button to blink and invoke its command.
.PP
Within the body of a method, the "variables" defined in the class
are automatically available. They need not be declared with anything
like the \fBglobal\fR command. Within another class method, a method
can be invoked like any other command\-simply by using its name.
From any other context, the method name must be prefaced by an object
name, which provides a context for the data that the method can access.
.PP
Each class has its own namespace containing things that are common
to all objects which belong to the class. For example, "common" data
members are shared by all objects in the class. They are global
variables that exist in the class namespace, but since they are
included in the class definition, they need not be declared using
the \fBglobal\fR command; they are automatically available to any
code executing in the class context. A class can also create
ordinary global variables, but these must be declared using the
\fBglobal\fR command each time they are used.
.PP
Classes can also have ordinary procedures declared as "procs".
Within another class method or proc, a proc can be invoked like
any other command\-simply by using its name. From any other context,
the procedure name should be qualified with the class namespace
like "\fIclassName\fB::\fIproc\fR". Class procs execute in the
class context, and therefore have automatic access to all "common"
data members. However, they cannot access object-specific "variables",
since they are invoked without reference to any specific object.
They are usually used to perform generic operations which affect
all objects belonging to the class.
.PP
Each of the elements in a class can be declared "public", "protected"
or "private". Public elements can be accessed by the class, by
derived classes (other classes that inherit this class), and by
external clients that use the class. Protected elements can be
accessed by the class, and by derived classes. Private elements
are only accessible in the class where they are defined.
.PP
The "public" elements within a class define its interface to the
external world. Public methods define the operations that can
be used to manipulate an object. Public variables are recognized
as configuration options by the "configure" and "cget" methods
that are built into each class. The public interface says
\fIwhat\fR an object will do but not \fIhow\fR it will do it.
Protected and private members, along with the bodies of class
methods and procs, provide the implementation details. Insulating
the application developer from these details leaves the class designer
free to change them at any time, without warning, and without affecting
programs that rely on the class. It is precisely this encapsulation
that makes object-oriented programs easier to understand and maintain.
.PP
The fact that \fB[incr\ Tcl]\fR objects look like Tk widgets is
no accident. \fB[incr\ Tcl]\fR was designed this way, to blend
naturally into a Tcl/Tk application. But \fB[incr\ Tcl]\fR
extends the Tk paradigm from being merely object-based to being
fully object-oriented. An object-oriented system supports
inheritance, allowing classes to share common behaviors by
inheriting them from an ancestor or base class. Having a base
class as a common abstraction allows a programmer to treat
related classes in a similar manner. For example, a toaster
and a blender perform different (specialized) functions, but
both share the abstraction of being appliances. By abstracting
common behaviors into a base class, code can be \fIshared\fR rather
than \fIcopied\fR. The resulting application is easier to
understand and maintain, and derived classes (e.g., specialized
appliances) can be added or removed more easily.
.PP
This description was merely a brief overview of object-oriented
programming and \fB[incr\ Tcl]\fR. A more tutorial introduction is
presented in the paper included with this distribution. See the
\fBclass\fR command for more details on creating and using classes.
.SH NAMESPACES
.PP
\fB[incr\ Tcl]\fR now includes a complete namespace facility.
A namespace is a collection of commands and global variables that
is kept apart from the usual global scope. This allows Tcl code
libraries to be packaged in a well-defined manner, and prevents
unwanted interactions with other libraries. A namespace can also
have child namespaces within it, so one library can contain its
own private copy of many other libraries. A namespace can also
be used to wrap up a group of related classes. The global scope
(named "\fC::\fR") is the root namespace for an interpreter; all
other namespaces are contained within it.
.PP
See the \fBnamespace\fR command for details on creating and
using namespaces.
.SH MEGA-WIDGETS
.PP
Mega-widgets are high-level widgets that are constructed using
Tk widgets as component parts, usually without any C code. A
fileselectionbox, for example, may have a few listboxes, some
entry widgets and some control buttons. These individual widgets
are put together in a way that makes them act like one big
widget.
.PP
\fB[incr\ Tk]\fR is a framework for building mega-widgets. It
uses \fB[incr\ Tcl]\fR to support the object paradigm, and adds
base classes which provide default widget behaviors. See the
\fBitk\fR man page for more details.
.PP
\fB[incr\ Widgets]\fR is a library of mega-widgets built using
\fB[incr\ Tk]\fR. It contains more than 30 different widget
classes that can be used right out of the box to build Tcl/Tk
applications. Each widget class has its own man page describing
the features available.
.SH KEYWORDS
class, object, object-oriented, namespace, mega-widget

46
pkgs/itcl4.2.0/doc/itclcomponent.n Normal file
View File

@@ -0,0 +1,46 @@
'\"
'\" Copyright (c) 2008 Arnulf Wiedemann
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH component n 4.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::component \- define components for extendedclass, widget or widgetadaptor
.PP
Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical.
.SH WARNING!
This is new functionality in [incr Tcl] where the API can still change!!
.SH SYNOPSIS
.nf
\fBpublic component \fIcomp\fR ?\fB-inherit\fR?
\fBprotected component \fIcomp\fR ?\fB-inherit\fR?
\fBprivate component \fIcomp\fR ?\fB-inherit\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBcomponent\fR command is used inside an \fB[incr\ Tcl]\fR
extendedclass/widget/widgetadaptor definition to define components.
.PP
Explicitly declares a component called comp, and automatically defines
the component's instance variable.
.PP
If the \fI-inherit\fR option is specified then all unknown methods
and options will be delegated to this component. The name -inherit
implies that instances of this new type inherit, in a sense,
the methods and options of the component. That is,
-inherit yes is equivalent to:
.PP
.CS
component mycomp
delegate option * to mycomp
delegate method * to mycomp
.CE
.SH KEYWORDS
component, widget, widgetadaptor, extendedclass

202
pkgs/itcl4.2.0/doc/itcldelegate.n Normal file
View File

@@ -0,0 +1,202 @@
'\"
'\" Copyright (c) 2008 Arnulf Wiedemann
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH delegation n 4.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::delegation \- delegate methods, procs or options to other objects
.PP
Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical.
.SH WARNING!
This is new functionality in [incr Tcl] where the API can still change!!
.SH SYNOPSIS
.nf
\fBdelegate method \fImethodName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR?
\fBdelegate method \fImethodName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR
\fBdelegate method \fI* ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fImethodName methodName ...\fR?
\fBdelegate proc \fIprocName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR?
\fBdelegate proc \fIprocName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR
\fBdelegate proc \fI*\fR ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fIprocName procName ...\fR?
\fBdelegate option \fIoptionSpec\fB to \fIcomponentName\fR
\fBdelegate option \fIoptionSpec\fB to \fIcomponentName\fR \fBas \fItargetname\fR?
\fBdelegate option \fI* \fBto \fIcomponentName\fR
\fBdelegate option \fI* \fBto \fIcomponentName\fR \fBexcept \fIoptionName optionname ...\fR
.fi
.BE
.SH DESCRIPTION
.PP
The \fBdelegate\fR command is used inside an \fB[incr\ Tcl]\fR
extendedclass/widget/widgetadaptor definition to delegate
methods/procs/options to other objects for handling.
.TP
\fBdelegate method \fImethodName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR?
.
This form of delegate method delegates method methodName to component
componentName. That is, when method methdoNameame is called on an instance of
this type, the method and its arguments will be passed to the named component's
command instead. That is, the following statement
.RS
.PP
.CS
delegate method wag to tail
.CE
.PP
is roughly equivalent to this explicitly defined method:
.PP
.CS
method wag {args} {
uplevel $tail wag $args
}
.CE
.PP
The optional \fBas\fR clause allows you to specify the delegated method
name and possibly add some arguments:
.PP
.CS
delegate method wagtail to tail as "wag briskly"
.CE
.PP
A method cannot be both locally defined and delegated.
.RE
.TP
\fBdelegate method \fImethodName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR
.
In this form of the delegate statement, the \fBusing\fR clause is used to
specify the precise form of the command to which method name name is delegated.
The \fBto\fR clause is optional, since the chosen command might not involve
any particular component.
.RS
.PP
The value of the using clause is a list that may contain any or all of the
following substitution codes; these codes are substituted with the described
value to build the delegated command prefix. Note that the following two
statements are equivalent:
.PP
.CS
delegate method wag to tail
delegate method wag to tail using "%c %m"
.CE
.PP
Each element of the list becomes a single element of the delegated command
--it is never reparsed as a string.
.PP
Substitutions:
.TP
\fB%%\fR
.
This is replaced with a single "%". Thus, to pass the string "%c" to the
command as an argument, you'd write "%%c".
.TP
\fB%c\fR
.
This is replaced with the named component's command.
.TP
\fB%j\fR
.
This is replaced by the method name; if the name consists of multiple tokens,
they are joined by underscores ("_").
.TP
\fB%m\fR
.
This is replaced with the final token of the method name; if the method name
has one token, this is identical to \fB%M\fR.
.TP
\fB%M\fR
.
This is replaced by the method name; if the name consists of multiple tokens,
they are joined by space characters.
.TP
\fB%n\fR
.
This is replaced with the name of the instance's private namespace.
.TP
\fB%s\fR
.
This is replaced with the name of the instance command.
.TP
\fB%t\fR
.
This is replaced with the fully qualified type name.
.TP
\fB%w\fR
.
This is replaced with the original name of the instance command; for Itcl
widgets and widget adaptors, it will be the Tk window name. It remains
constant, even if the instance command is renamed.
.RE
.TP
\fBdelegate method \fI*\fR ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fImethodName methodName ...\fR?
.
In this form all unknown method names are delegeted to the specified
component. The except clause can be used to specify a list of exceptions,
i.e., method names that will not be so delegated. The using clause
is defined as given above. In this form, the statement must
contain the to clause, the using clause, or both.
.RS
.PP
In fact, the "*" can be a list of two or more tokens whose last element
is "*", as in the following example:
.PP
.CS
delegate method {tail *} to tail
.CE
.PP
This implicitly defines the method tail whose subcommands will be
delegated to the tail component.
.PP
The definitions for \fBdelegate proc\fR ... are the same as for method,
the only difference being, that this is for procs.
.RE
.TP
\fBdelegate option \fInamespec\fB to \fIcomp\fR
.TP
\fBdelegate option namespec to comp as target\fR
.TP
\fBdelegate option * to \fIcomp\fR
.TP
\fBdelegate option * to \fIcomp \fBexcept \fIexceptions\fR
.
Defines a delegated option; the namespec is defined as for the option
statement. When the configure, configurelist, or cget instance method is
used to set or retrieve the option's value, the equivalent configure or
cget command will be applied to the component as though the option was
defined with the following \fB-configuremethod\fR and \fB-cgetmethod\fR:
.RS
.PP
.CS
method ConfigureMethod {option value} {
$comp configure $option $value
}
method CgetMethod {option} {
return [$comp cget $option]
}
.CE
.PP
Note that delegated options never appear in the \fBitcl_options\fR array.
If the as clause is specified, then the target option name is used in place
of name.
.RE
.TP
\fBdelegate \fIoption\fB *\fR ?\fBexcept\fI optionName optionName ...\fR?
.
This form delegates all unknown options to the specified component.
The except clause can be used to specify a list of exceptions,
i.e., option names that will not be so delegated.
.RS
.PP
\fBWarning:\fR options can only be delegated to a component if it supports the
\fBconfigure\fR and \fBcget\fR instance methods.
.PP
An option cannot be both locally defined and delegated. TBD: Continue from here.
.RE
.SH KEYWORDS
delegation, option, method, proc

547
pkgs/itcl4.2.0/doc/itclextendedclass.n Normal file
View File

@@ -0,0 +1,547 @@
'\"
'\" Copyright (c) 2008 Arnulf Wiedemann
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH extendedclass n "4.0" itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::extendedclass \- create a extendedclass of objects
.SH WARNING!
This is new functionality in [incr Tcl] where the API can still change!!
.SH SYNOPSIS
.nf
\fBitcl::extendedclass \fIextendedclassName\fR \fB{\fR
\fBinherit \fIbaseExtendedclass\fR ?\fIbaseExtendedclass\fR...?
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
\fBdestructor \fIbody\fR
\fBpublic method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprotected method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprivate method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBpublic proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprotected proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprivate proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBpublic variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBprotected variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBprivate variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBpublic common \fIvarName\fR ?\fIinit\fR?
\fBprotected common \fIvarName\fR ?\fIinit\fR?
\fBprivate common \fIvarName\fR ?\fIinit\fR?
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
\fB<delegation info>\fR see delegation page
\fB<option info>\fR see option page
\fBset \fIvarName\fR ?\fIvalue\fR?
\fBarray \fIoption\fR ?\fIarg arg ...\fR?
\fB}\fR
\fIextendedclassName objName\fR ?\fIarg arg ...\fR?
\fIobjName method\fR ?\fIarg arg ...\fR?
\fIextendedclassName::proc\fR ?\fIarg arg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The fundamental construct in \fB[incr\ Tcl]\fR is the extendedclass definition.
Each extendedclass acts as a template for actual objects that can be created.
The extendedclass itself is a namespace which contains things common to all
objects. Each object has its own unique bundle of data which contains
instances of the "variables" defined in the extendedclass definition. Each
object also has a built-in variable named "this", which contains the
name of the object. Extendedclasses can also have "common" data members that
are shared by all objects in a extendedclass.
.PP
Two types of functions can be included in the extendedclass definition.
"Methods" are functions which operate on a specific object, and
therefore have access to both "variables" and "common" data members.
"Procs" are ordinary procedures in the extendedclass namespace, and only
have access to "common" data members.
.PP
If the body of any method or proc starts with "\fB@\fR", it is treated
as the symbolic name for a C procedure. Otherwise, it is treated as
a Tcl code script. See below for details on registering and using
C procedures.
.PP
A extendedclass can only be defined once, although the bodies of extendedclass
methods and procs can be defined again and again for interactive
debugging. See the \fBbody\fR and \fBconfigbody\fR commands for
details.
.PP
Each namespace can have its own collection of objects and extendedclasses.
The list of extendedclasses available in the current context can be queried
using the "\fBitcl::find extendedclasses\fR" command, and the list of objects,
with the "\fBitcl::find objects\fR" command.
.PP
A extendedclass can be deleted using the "\fBdelete extendedclass\fR" command.
Individual objects can be deleted using the "\fBdelete object\fR"
command.
.SH "CLASS DEFINITIONS"
.TP
\fBextendedclass \fIextendedclassName definition\fR
.
Provides the definition for a extendedclass named \fIextendedclassName\fR. If
the extendedclass \fIextendedclassName\fR already exists, or if a command called
\fIextendedclassName\fR exists in the current namespace context, this
command returns an error. If the extendedclass definition is successfully
parsed, \fIextendedclassName\fR becomes a command in the current context,
handling the creation of objects for this extendedclass.
.PP
The extendedclass \fIdefinition\fR is evaluated as a series of Tcl
statements that define elements within the extendedclass. The following
extendedclass definition commands are recognized:
.RS
.TP
\fBinherit \fIbaseExtendedclass\fR ?\fIbaseExtendedclass\fR...?
.
Causes the current extendedclass to inherit characteristics from one or
more base extendedclasses. Extendedclasses must have been defined by a previous
\fBextendedclass\fR command, or must be available to the auto-loading
facility (see "AUTO-LOADING" below). A single extendedclass definition
can contain no more than one \fBinherit\fR command.
.RS
.PP
The order of \fIbaseExtendedclass\fR names in the \fBinherit\fR list
affects the name resolution for extendedclass members. When the same
member name appears in two or more base extendedclasses, the base extendedclass
that appears first in the \fBinherit\fR list takes precedence.
For example, if extendedclasses "Foo" and "Bar" both contain the member
"x", and if another extendedclass has the "\fBinherit\fR" statement:
.PP
.CS
inherit Foo Bar
.CE
.PP
then the name "x" means "Foo::x". Other inherited members named
"x" must be referenced with their explicit name, like "Bar::x".
.RE
.TP
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
.
Declares the \fIargs\fR argument list and \fIbody\fR used for
the constructor, which is automatically invoked whenever an
object is created.
.RS
.PP
Before the \fIbody\fR is executed, the
optional \fIinit\fR statement is used to invoke any base extendedclass
constructors that require arguments. Variables in the \fIargs\fR
specification can be accessed in the \fIinit\fR code fragment,
and passed to base extendedclass constructors. After evaluating the
\fIinit\fR statement, any base extendedclass constructors that have
not been executed are invoked automatically without arguments.
This ensures that all base extendedclasses are fully constructed before
the constructor \fIbody\fR is executed. By default, this
scheme causes constructors to be invoked in order from least-
to most-specific. This is exactly the opposite of the order
that extendedclasses are reported by the \fBinfo heritage\fR command.
.PP
If construction is successful, the constructor always returns
the object name\-regardless of how the \fIbody\fR is defined\-and
the object name becomes a command in the current namespace context.
If construction fails, an error message is returned.
.RE
.TP
\fBdestructor \fIbody\fR
.
Declares the \fIbody\fR used for the destructor, which is automatically
invoked when an object is deleted. If the destructor is successful,
the object data is destroyed and the object name is removed as a command
from the interpreter. If destruction fails, an error message is returned
and the object remains.
.PP
When an object is destroyed, all destructors in its extendedclass hierarchy
are invoked in order from most- to least-specific. This is the
order that the extendedclasses are reported by the "\fBinfo heritage\fR"
command, and it is exactly the opposite of the default constructor
order.
.RE
.TP
\fBmethod \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a method called \fIname\fR. When the method \fIbody\fR is
executed, it will have automatic access to object-specific variables
and common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this method. The \fBbody\fR command can be used
to redefine the method body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another extendedclass method, a method can be invoked
like any other command\-simply by using its name. Outside of the
extendedclass context, the method name must be prefaced an object name,
which provides the context for the data that it manipulates.
Methods in a base extendedclass that are redefined in the current extendedclass,
or hidden by another base extendedclass, can be qualified using the
"\fIextendedclassName\fR::\fImethod\fR" syntax.
.RE
.TP
\fBproc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a proc called \fIname\fR. A proc is an ordinary procedure
within the extendedclass namespace. Unlike a method, a proc is invoked
without referring to a specific object. When the proc \fIbody\fR is
executed, it will have automatic access only to common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this proc. The \fBbody\fR command can be used
to redefine the proc body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another extendedclass method or proc, a proc can be
invoked like any other command\-simply by using its name.
In any other namespace context, the proc is invoked using a
qualified name like "\fIextendedclassName\fB::\fIproc\fR". Procs in
a base extendedclass that are redefined in the current extendedclass, or hidden
by another base extendedclass, can also be accessed via their qualified
name.
.RE
.TP
\fBvariable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
.
Defines an object-specific variable named \fIvarName\fR. All
object-specific variables are automatically available in extendedclass
methods. They need not be declared with anything like the
\fBglobal\fR command.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable when a new object is created.
Initialization forces the variable to be a simple scalar
value; uninitialized variables, on the other hand, can be set
within the constructor and used as arrays.
.PP
The optional \fIconfig\fR script is only allowed for public variables.
If specified, this code fragment is executed whenever a public
variable is modified by the built-in "configure" method. The
\fIconfig\fR script can also be specified outside of the extendedclass
definition using the \fBconfigbody\fR command.
.RE
.TP
\fBcommon \fIvarName\fR ?\fIinit\fR?
.
Declares a common variable named \fIvarName\fR. Common variables
reside in the extendedclass namespace and are shared by all objects belonging
to the extendedclass. They are just like global variables, except that
they need not be declared with the usual \fBglobal\fR command.
They are automatically visible in all extendedclass methods and procs.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable. Initialization forces the variable
to be a simple scalar value; uninitialized variables, on the other
hand, can be set with subsequent \fBset\fR and \fBarray\fR commands
and used as arrays.
.PP
Once a common data member has been defined, it can be set using
\fBset\fR and \fBarray\fR commands within the extendedclass definition.
This allows common data members to be initialized as arrays.
For example:
.PP
.CS
itcl::extendedclass Foo {
common boolean
set boolean(true) 1
set boolean(false) 0
}
.CE
.PP
Note that if common data members are initialized within the
constructor, they get initialized again and again whenever new
objects are created.
.RE
.TP
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
.
These commands are used to set the protection level for extendedclass
members that are created when \fIcommand\fR is evaluated.
The \fIcommand\fR is usually \fBmethod\fR, \fBproc\fR,
\fBvariable\fR or\fBcommon\fR, and the remaining \fIarg\fR's
complete the member definition. However, \fIcommand\fR can
also be a script containing many different member definitions,
and the protection level will apply to all of the members
that are created.
.SH "CLASS USAGE"
.PP
Once a extendedclass has been defined, the extendedclass name can be used as a
command to create new objects belonging to the extendedclass.
.TP
\fIextendedclassName objName\fR ?\fIargs...\fR?
.
Creates a new object in extendedclass \fIextendedclassName\fR with the name \fIobjName\fR.
Remaining arguments are passed to the constructor of the most-specific
extendedclass. This in turn passes arguments to base extendedclass constructors before
invoking its own body of commands. If construction is successful, a
command called \fIobjName\fR is created in the current namespace context,
and \fIobjName\fR is returned as the result of this operation.
If an error is encountered during construction, the destructors are
automatically invoked to free any resources that have been allocated,
the object is deleted, and an error is returned.
.RS
.PP
If \fIobjName\fR contains the string "\fB#auto\fR", that string is
replaced with an automatically generated name. Names have the
form \fIextendedclassName<number>\fR, where the \fIextendedclassName\fR part is
modified to start with a lowercase letter. In extendedclass "Toaster",
for example, the "\fB#auto\fR" specification would produce names
like toaster0, toaster1, etc. Note that "\fB#auto\fR" can be
also be buried within an object name:
.PP
.CS
fileselectiondialog .foo.bar.#auto -background red
.CE
.PP
This would generate an object named ".foo.bar.fileselectiondialog0".
.RE
.SH "OBJECT USAGE"
.PP
Once an object has been created, the object name can be used
as a command to invoke methods that operate on the object.
.TP
\fIobjName method\fR ?\fIargs...\fR?
.
Invokes a method named \fImethod\fR on an object named \fIobjName\fR.
Remaining arguments are passed to the argument list for the
method. The method name can be "constructor", "destructor",
any method name appearing in the extendedclass definition, or any of
the following built-in methods.
.SH "BUILT-IN METHODS"
.TP
\fIobjName\fR \fBcget option\fR
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "cget" operation for Tk widgets.
The \fIoption\fR argument is a string of the form "\fB-\fIvarName\fR",
and this method returns the current value of the public variable
\fIvarName\fR.
.TP
\fIobjName\fR \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR?
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "configure" operation for Tk widgets.
With no arguments, this method returns a list of lists describing
all of the public variables. Each list has three elements: the
variable name, its initial value and its current value.
.RS
.PP
If a single \fIoption\fR of the form "\fB-\fIvarName\fR" is specified,
then this method returns the information for that one variable.
.PP
Otherwise, the arguments are treated as \fIoption\fR/\fIvalue\fR
pairs assigning new values to public variables. Each variable
is assigned its new value, and if it has any "config" code associated
with it, it is executed in the context of the extendedclass where it was
defined. If the "config" code generates an error, the variable
is set back to its previous value, and the \fBconfigure\fR method
returns an error.
.RE
.TP
\fIobjName\fR \fBisa \fIextendedclassName\fR
.
Returns non-zero if the given \fIextendedclassName\fR can be found in the
object's heritage, and zero otherwise.
.TP
\fIobjName\fR \fBinfo \fIoption\fR ?\fIargs...\fR?
.
Returns information related to a particular object named
\fIobjName\fR, or to its extendedclass definition. The \fIoption\fR
parameter includes the following things, as well as the options
recognized by the usual Tcl "info" command:
.RS
.TP
\fIobjName\fR \fBinfo extendedclass\fR
.
Returns the name of the most-specific extendedclass for object \fIobjName\fR.
.TP
\fIobjName\fR \fBinfo inherit\fR
.
Returns the list of base extendedclasses as they were defined in the
"\fBinherit\fR" command, or an empty string if this extendedclass
has no base extendedclasses.
.TP
\fIobjName\fR \fBinfo heritage\fR
.
Returns the current extendedclass name and the entire list of base extendedclasses
in the order that they are traversed for member lookup and object
destruction.
.TP
\fIobjName\fR \fBinfo function\fR ?\fIcmdName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-args\fR? ?\fB-body\fR?
.
With no arguments, this command returns a list of all extendedclass methods
and procs. If \fIcmdName\fR is specified, it returns information
for a specific method or proc. If no flags are specified, this
command returns a list with the following elements: the protection
level, the type (method/proc), the qualified name, the argument list
and the body. Flags can be used to request specific elements from
this list.
.TP
\fIobjName\fR \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR?
.
With no arguments, this command returns a list of all object-specific
variables and common data members. If \fIvarName\fR is specified, it
returns information for a specific data member. If no flags are
specified, this command returns a list with the following elements: the
protection level, the type (variable/common), the qualified name, the
initial value, and the current value. If \fIvarName\fR is a public
variable, the "config" code is included on this list. Flags can be
used to request specific elements from this list.
.RE
.SH "CHAINING METHODS/PROCS"
.PP
Sometimes a base extendedclass has a method or proc that is redefined with
the same name in a derived extendedclass. This is a way of making the
derived extendedclass handle the same operations as the base extendedclass, but
with its own specialized behavior. For example, suppose we have
a Toaster extendedclass that looks like this:
.PP
.CS
itcl::extendedclass Toaster {
variable crumbs 0
method toast {nslices} {
if {$crumbs > 50} {
error "== FIRE! FIRE! =="
}
set crumbs [expr {$crumbs+4*$nslices}]
}
method clean {} {
set crumbs 0
}
}
.CE
.PP
We might create another extendedclass like SmartToaster that redefines
the "toast" method. If we want to access the base extendedclass method,
we can qualify it with the base extendedclass name, to avoid ambiguity:
.PP
.CS
itcl::extendedclass SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [Toaster::toast $nslices]
}
}
.CE
.PP
Instead of hard-coding the base extendedclass name, we can use the
"chain" command like this:
.PP
.CS
itcl::extendedclass SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [chain $nslices]
}
}
.CE
.PP
The chain command searches through the extendedclass hierarchy for
a slightly more generic (base extendedclass) implementation of a method
or proc, and invokes it with the specified arguments. It starts
at the current extendedclass context and searches through base extendedclasses
in the order that they are reported by the "info heritage" command.
If another implementation is not found, this command does nothing
and returns the null string.
.SH "AUTO-LOADING"
.PP
Extendedclass definitions need not be loaded explicitly; they can be loaded as
needed by the usual Tcl auto-loading facility. Each directory containing
extendedclass definition files should have an accompanying "tclIndex" file.
Each line in this file identifies a Tcl procedure or \fB[incr\ Tcl]\fR
extendedclass definition and the file where the definition can be found.
.PP
For example, suppose a directory contains the definitions for extendedclasses
"Toaster" and "SmartToaster". Then the "tclIndex" file for this
directory would look like:
.PP
.CS
# Tcl autoload index file, version 2.0 for [incr Tcl]
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.
set auto_index(::Toaster) "source $dir/Toaster.itcl"
set auto_index(::SmartToaster) "source $dir/SmartToaster.itcl"
.CE
.PP
The \fBauto_mkindex\fR command is used to automatically
generate "tclIndex" files.
.PP
The auto-loader must be made aware of this directory by appending
the directory name to the "auto_path" variable. When this is in
place, extendedclasses will be auto-loaded as needed when used in an
application.
.SH "C PROCEDURES"
.PP
C procedures can be integrated into an \fB[incr\ Tcl]\fR extendedclass
definition to implement methods, procs, and the "config" code
for public variables. Any body that starts with "\fB@\fR"
is treated as the symbolic name for a C procedure.
.PP
Symbolic names are established by registering procedures via
\fBItcl_RegisterC()\fR. This is usually done in the \fBTcl_AppInit()\fR
procedure, which is automatically called when the interpreter starts up.
In the following example, the procedure \fCMy_FooCmd()\fR is registered
with the symbolic name "foo". This procedure can be referenced in
the \fBbody\fR command as "\fC@foo\fR".
.PP
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
.PP
C procedures are implemented just like ordinary Tcl commands.
See the \fBCrtCommand\fR man page for details. Within the procedure,
extendedclass data members can be accessed like ordinary variables
using \fBTcl_SetVar()\fR, \fBTcl_GetVar()\fR, \fBTcl_TraceVar()\fR,
etc. Extendedclass methods and procs can be executed like ordinary commands
using \fBTcl_Eval()\fR. \fB[incr\ Tcl]\fR makes this possible by
automatically setting up the context before executing the C procedure.
.PP
This scheme provides a natural migration path for code development.
Extendedclasses can be developed quickly using Tcl code to implement the
bodies. An entire application can be built and tested. When
necessary, individual bodies can be implemented with C code to
improve performance.
.SH KEYWORDS
extendedclass, object, object-oriented

160
pkgs/itcl4.2.0/doc/itcloption.n Normal file
View File

@@ -0,0 +1,160 @@
'\"
'\" Copyright (c) 2008 Arnulf Wiedemann
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH option n 4.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::option \- define options for extendedclass, widget or widgetadaptor
.PP
Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical.
.SH WARNING!
This is new functionality in [incr Tcl] where the API can still change!!
.SH SYNOPSIS
.nf
\fBoption \fIoptionSpec\fR ?\fIdefaultValue\fR?
\fBoption \fIoptionSpec\fR ?\fIoptions\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBoption\fR command is used inside an \fB[incr\ Tcl]\fR
extendedclass/widget/widgetadaptor definition to define options.
.PP
In the first form defines an option for instances of this type, and optionally
gives it an initial value. The initial value defaults to the empty string if
no defaultValue is specified.
.PP
An option defined in this way is said to be locally defined.
The optionSpec is a list defining the option's name, resource name, and class
name, e.g.:
.PP
.CS
option {-font font Font} {Courier 12}
.CE
.PP
The option name must begin with a hyphen, and must not contain any upper case
letters. The resource name and class name are optional; if not specified,
the resource name defaults to the option name, minus the hyphen, and the class
name defaults to the resource name with the first letter capitalized. Thus, the
following statement is equivalent to the previous example:
.PP
.CS
option -font {Courier 12}
.CE
.PP
See The Tk Option Database for more information about resource and class names.
.PP
Options are normally set and retrieved using the standard instance methods
configure and cget; within instance code (method bodies, etc.), option values
are available through the options array:
.PP
.CS
set myfont $itcl_options(-font)
.CE
.PP
In the second form you can define option handlers (e.g., -configuremethod),
then it should probably use configure and cget to access its options to avoid
subtle errors.
.PP
The option statement may include the following options:
.TP
\fB-default\fI defvalue\fR
.
Defines the option's default value; the option's default value will be ""
otherwise.
.TP
\fB-readonly\fR
.
The option is handled read-only -- it can only be set using configure at
creation time, i.e., in the type's constructor.
.TP
\fB-cgetmethod\fI methodName\fR
.
Every locally-defined option may define a -cgetmethod; it is called when the
option's value is retrieved using the cget method. Whatever the method's body
returns will be the return value of the call to cget.
.RS
.PP
The named method must take one argument, the option name. For example, this
code is equivalent to (though slower than) Itcl's default handling of cget:
.PP
.CS
option -font -cgetmethod GetOption
method GetOption {option} {
return $itcl_options($option)
}
.CE
.PP
Note that it's possible for any number of options to share a -cgetmethod.
.RE
.TP
\fB-cgetmethodvar\fI varName\fR
.
That is very similar to -cgetmethod, the only difference is, one can define
a variable, where to find the cgetmethod during runtime.
.TP
\fB-configuremethod\fI methodName\fR
.
Every locally-defined option may define a -configuremethod; it is called
when the option's value is set using the configure or configurelist
methods. It is the named method's responsibility to save the option's
value; in other words, the value will not be saved to the itcl_options()
array unless the method saves it there.
.RS
.PP
The named method must take two arguments, the option name and its new value.
For example, this code is equivalent to (though slower than) Itcl's default
handling of configure:
.PP
.CS
option -font -configuremethod SetOption
method SetOption {option value} {
set itcl_options($option) $value
}
.CE
.PP
Note that it's possible for any number of options to share a single -configuremethod.
.RE
.TP
\fB-configuremethodvar\fI varName\fR
.
That is very similar to -configuremethod, the only difference is, one can define
a variable, where to find the configuremethod during runtime.
.TP
\fB-validatemethod\fI methodName\fR
.
Every locally-defined option may define a -validatemethod; it is called when
the option's value is set using the configure or configurelist methods, just
before the -configuremethod (if any). It is the named method's responsibility
to validate the option's new value, and to throw an error if the value is
invalid.
.RS
.PP
The named method must take two arguments, the option name and its new value.
For example, this code verifies that -flag's value is a valid Boolean value:
.PP
.CS
option -font -validatemethod CheckBoolean
method CheckBoolean {option value} {
if {![string is boolean -strict $value]} {
error "option $option must have a boolean value."
}
}
.CE
.PP
Note that it's possible for any number of options to share a single -validatemethod.
.RE
.TP
\fB-validatemethodvar\fI varName\fR
.
That is very similar to -validatemethod, the only difference is, one can define
a variable, where to find the validatemethod during runtime.
.SH KEYWORDS
option, widget, widgetadaptor, extendedclass

106
pkgs/itcl4.2.0/doc/itclvars.n Normal file
View File

@@ -0,0 +1,106 @@
'\"
'\" 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.
'\"
.TH itclvars n 3.0 itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itclvars \- variables used by [incr\ Tcl]
.BE
.SH DESCRIPTION
.PP
The following global variables are created and managed automatically
by the \fB[incr\ Tcl]\fR library. Except where noted below, these
variables should normally be treated as read-only by application-specific
code and by users.
.TP
\fBitcl::library\fR
.
When an interpreter is created, \fB[incr\ Tcl]\fR initializes this variable
to hold the name of a directory containing the system library of
\fB[incr\ Tcl]\fR scripts. The initial value of \fBitcl::library\fR
is set from the ITCL_LIBRARY environment variable if it exists,
or from a compiled-in value otherwise.
.TP
\fBitcl::patchLevel\fR
.
When an interpreter is created, \fB[incr\ Tcl]\fR initializes this
variable to hold the current patch level for \fB[incr\ Tcl]\fR.
For example, the value "\fB2.0p1\fR" indicates \fB[incr\ Tcl]\fR
version 2.0 with the first set of patches applied.
.TP
\fBitcl::purist\fR
.
When an interpreter is created containing Tcl/Tk and the
\fB[incr\ Tcl]\fR namespace facility, this variable controls
a "backward-compatibility" mode for widget access.
.RS
.PP
In vanilla Tcl/Tk, there is a single pool of commands, so the
access command for a widget is the same as the window name.
When a widget is created within a namespace, however, its access
command is installed in that namespace, and should be accessed
outside of the namespace using a qualified name. For example,
.PP
.CS
namespace foo {
namespace bar {
button .b -text "Testing"
}
}
foo::bar::.b configure -background red
pack .b
.CE
.PP
Note that the window name "\fC.b\fR" is still used in conjunction
with commands like \fBpack\fR and \fBdestroy\fR. However, the
access command for the widget (i.e., name that appears as the
\fIfirst\fR argument on a command line) must be more specific.
.PP
The "\fBwinfo command\fR" command can be used to query the
fully-qualified access command for any widget, so one can write:
.PP
.CS
[winfo command .b] configure -background red
.CE
.PP
and this is good practice when writing library procedures. Also,
in conjunction with the \fBbind\fR command, the "%q" field can be
used in place of "%W" as the access command:
.PP
.CS
bind Button <Key-Return> {%q flash; %q invoke}
.CE
.PP
While this behavior makes sense from the standpoint of encapsulation,
it causes problems with existing Tcl/Tk applications. Many existing
applications are written with bindings that use "%W". Many
library procedures assume that the window name is the access
command.
.PP
The \fBitcl::purist\fR variable controls a backward-compatibility
mode. By default, this variable is "0", and the window name
can be used as an access command in any context. Whenever the
\fBunknown\fR procedure stumbles across a widget name, it simply
uses "\fBwinfo command\fR" to determine the appropriate command
name. If this variable is set to "1", this backward-compatibility
mode is disabled. This gives better encapsulation, but using the
window name as the access command may lead to "invalid command"
errors.
.RE
.TP
\fBitcl::version\fR
.
When an interpreter is created, \fB[incr\ Tcl]\fR initializes this
variable to hold the version number of the form \fIx.y\fR.
Changes to \fIx\fR represent major changes with probable
incompatibilities and changes to \fIy\fR represent small enhancements
and bug fixes that retain backward compatibility.
.SH KEYWORDS
itcl, variables

549
pkgs/itcl4.2.0/doc/itclwidget.n Normal file
View File

@@ -0,0 +1,549 @@
'\"
'\" Copyright (c) 2008 Arnulf Wiedemann
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH widget n "4.0" itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::widget \- create a widget class of objects
.SH WARNING!
This is new functionality in [incr Tcl] where the API can still change!!
.SH SYNOPSIS
.nf
\fBitcl::widget \fIwidgetName\fR \fB{\fR
\fBinherit \fIbaseWidget\fR ?\fIbaseWidget\fR...?
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
\fBdestructor \fIbody\fR
\fBpublic method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprotected method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprivate method \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBpublic proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprotected proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBprivate proc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
\fBpublic variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBprotected variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBprivate variable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
\fBpublic common \fIvarName\fR ?\fIinit\fR?
\fBprotected common \fIvarName\fR ?\fIinit\fR?
\fBprivate common \fIvarName\fR ?\fIinit\fR?
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
\fB<delegation info>\fR see delegation page
\fB<option info>\fR see option page
\fBset \fIvarName\fR ?\fIvalue\fR?
\fBarray \fIoption\fR ?\fIarg arg ...\fR?
\fB}\fR
\fIwidgetName objName\fR ?\fIarg arg ...\fR?
\fIobjName method\fR ?\fIarg arg ...\fR?
\fIwidgetName::proc\fR ?\fIarg arg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
One of the fundamental constructs in \fB[incr\ Tcl]\fR is the widget definition.
A widget is like a class with some additional features.
Each widget acts as a template for actual objects that can be created.
The widget itself is a namespace which contains things common to all
objects. Each object has its own unique bundle of data which contains
instances of the "variables" defined in the widget definition. Each
object also has a built-in variable named "this", which contains the
name of the object. Widgets can also have "common" data members that
are shared by all objects in a widget.
.PP
Two types of functions can be included in the widget definition.
"Methods" are functions which operate on a specific object, and
therefore have access to both "variables" and "common" data members.
"Procs" are ordinary procedures in the widget namespace, and only
have access to "common" data members.
.PP
If the body of any method or proc starts with "\fB@\fR", it is treated
as the symbolic name for a C procedure. Otherwise, it is treated as
a Tcl code script. See below for details on registering and using
C procedures.
.PP
A widget can only be defined once, although the bodies of widget
methods and procs can be defined again and again for interactive
debugging. See the \fBbody\fR and \fBconfigbody\fR commands for
details.
.PP
Each namespace can have its own collection of objects and widgets.
The list of widgets available in the current context can be queried
using the "\fBitcl::find widgets\fR" command, and the list of objects,
with the "\fBitcl::find objects\fR" command.
.PP
A widget can be deleted using the "\fBdelete widget\fR" command.
Individual objects can be deleted using the "\fBdelete object\fR"
command.
.SH "WIDGET DEFINITIONS"
.TP
\fBwidget \fIwidgetName definition\fR
.
Provides the definition for a widget named \fIwidgetName\fR. If
the widget \fIwidgetName\fR already exists, or if a command called
\fIwidgetName\fR exists in the current namespace context, this
command returns an error. If the widget definition is successfully
parsed, \fIwidgetName\fR becomes a command in the current context,
handling the creation of objects for this widget.
.PP
The widget \fIdefinition\fR is evaluated as a series of Tcl
statements that define elements within the widget. The following
widget definition commands are recognized:
.RS
.TP
\fBinherit \fIbaseWidget\fR ?\fIbaseWidget\fR...?
.
Causes the current widget to inherit characteristics from one or
more base widgets. Widgets must have been defined by a previous
\fBwidget\fR command, or must be available to the auto-loading
facility (see "AUTO-LOADING" below). A single widget definition
can contain no more than one \fBinherit\fR command.
.RS
.PP
The order of \fIbaseWidget\fR names in the \fBinherit\fR list
affects the name resolution for widget members. When the same
member name appears in two or more base widgets, the base widget
that appears first in the \fBinherit\fR list takes precedence.
For example, if widgets "Foo" and "Bar" both contain the member
"x", and if another widget has the "\fBinherit\fR" statement:
.PP
.CS
inherit Foo Bar
.CE
.PP
then the name "x" means "Foo::x". Other inherited members named
"x" must be referenced with their explicit name, like "Bar::x".
.RE
.TP
\fBconstructor \fIargs\fR ?\fIinit\fR? \fIbody\fR
.
Declares the \fIargs\fR argument list and \fIbody\fR used for
the constructor, which is automatically invoked whenever an
object is created.
.RS
.PP
Before the \fIbody\fR is executed, the
optional \fIinit\fR statement is used to invoke any base widget
constructors that require arguments. Variables in the \fIargs\fR
specification can be accessed in the \fIinit\fR code fragment,
and passed to base widget constructors. After evaluating the
\fIinit\fR statement, any base widget constructors that have
not been executed are invoked automatically without arguments.
This ensures that all base widgets are fully constructed before
the constructor \fIbody\fR is executed. By default, this
scheme causes constructors to be invoked in order from least-
to most-specific. This is exactly the opposite of the order
that widgets are reported by the \fBinfo heritage\fR command.
.PP
If construction is successful, the constructor always returns
the object name\-regardless of how the \fIbody\fR is defined\-and
the object name becomes a command in the current namespace context.
If construction fails, an error message is returned.
.RE
.TP
\fBdestructor \fIbody\fR
.
Declares the \fIbody\fR used for the destructor, which is automatically
invoked when an object is deleted. If the destructor is successful,
the object data is destroyed and the object name is removed as a command
from the interpreter. If destruction fails, an error message is returned
and the object remains.
.RS
.PP
When an object is destroyed, all destructors in its widget hierarchy
are invoked in order from most- to least-specific. This is the
order that the widgets are reported by the "\fBinfo heritage\fR"
command, and it is exactly the opposite of the default constructor
order.
.RE
.TP
\fBmethod \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a method called \fIname\fR. When the method \fIbody\fR is
executed, it will have automatic access to object-specific variables
and common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this method. The \fBbody\fR command can be used
to redefine the method body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another widget method, a method can be invoked
like any other command\-simply by using its name. Outside of the
widget context, the method name must be prefaced an object name,
which provides the context for the data that it manipulates.
Methods in a base widget that are redefined in the current widget,
or hidden by another base widget, can be qualified using the
"\fIwidgetName\fR::\fImethod\fR" syntax.
.RE
.TP
\fBproc \fIname\fR ?\fIargs\fR? ?\fIbody\fR?
.
Declares a proc called \fIname\fR. A proc is an ordinary procedure
within the widget namespace. Unlike a method, a proc is invoked
without referring to a specific object. When the proc \fIbody\fR is
executed, it will have automatic access only to common data members.
.RS
.PP
If the \fIargs\fR list is specified, it establishes the usage
information for this proc. The \fBbody\fR command can be used
to redefine the proc body, but the \fIargs\fR list must match
this specification.
.PP
Within the body of another widget method or proc, a proc can be
invoked like any other command\-simply by using its name.
In any other namespace context, the proc is invoked using a
qualified name like "\fIwidgetName\fB::\fIproc\fR". Procs in
a base widget that are redefined in the current widget, or hidden
by another base widget, can also be accessed via their qualified
name.
.RE
.TP
\fBvariable \fIvarName\fR ?\fIinit\fR? ?\fIconfig\fR?
.
Defines an object-specific variable named \fIvarName\fR. All
object-specific variables are automatically available in widget
methods. They need not be declared with anything like the
\fBglobal\fR command.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable when a new object is created.
Initialization forces the variable to be a simple scalar
value; uninitialized variables, on the other hand, can be set
within the constructor and used as arrays.
.PP
The optional \fIconfig\fR script is only allowed for public variables.
If specified, this code fragment is executed whenever a public
variable is modified by the built-in "configure" method. The
\fIconfig\fR script can also be specified outside of the widget
definition using the \fBconfigbody\fR command.
.RE
.TP
\fBcommon \fIvarName\fR ?\fIinit\fR?
.
Declares a common variable named \fIvarName\fR. Common variables
reside in the widget namespace and are shared by all objects belonging
to the widget. They are just like global variables, except that
they need not be declared with the usual \fBglobal\fR command.
They are automatically visible in all widget methods and procs.
.RS
.PP
If the optional \fIinit\fR string is specified, it is used as the
initial value of the variable. Initialization forces the variable
to be a simple scalar value; uninitialized variables, on the other
hand, can be set with subsequent \fBset\fR and \fBarray\fR commands
and used as arrays.
.PP
Once a common data member has been defined, it can be set using
\fBset\fR and \fBarray\fR commands within the widget definition.
This allows common data members to be initialized as arrays.
For example:
.PP
.CS
itcl::widget Foo {
protected common boolean
set boolean(true) 1
set boolean(false) 0
}
.CE
.PP
Note that if common data members are initialized within the
constructor, they get initialized again and again whenever new
objects are created.
.RE
.TP
\fBpublic \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprotected \fIcommand\fR ?\fIarg arg ...\fR?
.TP
\fBprivate \fIcommand\fR ?\fIarg arg ...\fR?
.
These commands are used to set the protection level for widget
members that are created when \fIcommand\fR is evaluated.
The \fIcommand\fR is usually \fBmethod\fR, \fBproc\fR,
\fBvariable\fR or\fBcommon\fR, and the remaining \fIarg\fR's
complete the member definition. However, \fIcommand\fR can
also be a script containing many different member definitions,
and the protection level will apply to all of the members
that are created.
.RE
.SH "WIDGET USAGE"
.PP
Once a widget has been defined, the widget name can be used as a
command to create new objects belonging to the widget.
.TP
\fIwidgetName objName\fR ?\fIargs...\fR?
.
Creates a new object in widget \fIwidgetName\fR with the name \fIobjName\fR.
Remaining arguments are passed to the constructor of the most-specific
widget. This in turn passes arguments to base widget constructors before
invoking its own body of commands. If construction is successful, a
command called \fIobjName\fR is created in the current namespace context,
and \fIobjName\fR is returned as the result of this operation.
If an error is encountered during construction, the destructors are
automatically invoked to free any resources that have been allocated,
the object is deleted, and an error is returned.
.RS
.PP
If \fIobjName\fR contains the string "\fB#auto\fR", that string is
replaced with an automatically generated name. Names have the
form \fIwidgetName<number>\fR, where the \fIwidgetName\fR part is
modified to start with a lowercase letter. In widget "Toaster",
for example, the "\fB#auto\fR" specification would produce names
like toaster0, toaster1, etc. Note that "\fB#auto\fR" can be
also be buried within an object name:
.PP
.CS
fileselectiondialog .foo.bar.#auto -background red
.CE
.PP
This would generate an object named ".foo.bar.fileselectiondialog0".
.RE
.SH "OBJECT USAGE"
.PP
Once an object has been created, the object name can be used
as a command to invoke methods that operate on the object.
.TP
\fIobjName method\fR ?\fIargs...\fR?
.
Invokes a method named \fImethod\fR on an object named \fIobjName\fR.
Remaining arguments are passed to the argument list for the
method. The method name can be "constructor", "destructor",
any method name appearing in the widget definition, or any of
the following built-in methods.
.SH "BUILT-IN METHODS"
.TP
\fIobjName\fR \fBcget option\fR
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "cget" operation for Tk widgets.
The \fIoption\fR argument is a string of the form "\fB-\fIvarName\fR",
and this method returns the current value of the public variable
\fIvarName\fR.
.TP
\fIobjName\fR \fBconfigure\fR ?\fIoption\fR? ?\fIvalue option value ...\fR?
.
Provides access to public variables as configuration options. This
mimics the behavior of the usual "configure" operation for Tk widgets.
With no arguments, this method returns a list of lists describing
all of the public variables. Each list has three elements: the
variable name, its initial value and its current value.
.RS
.PP
If a single \fIoption\fR of the form "\fB-\fIvarName\fR" is specified,
then this method returns the information for that one variable.
.PP
Otherwise, the arguments are treated as \fIoption\fR/\fIvalue\fR
pairs assigning new values to public variables. Each variable
is assigned its new value, and if it has any "config" code associated
with it, it is executed in the context of the widget where it was
defined. If the "config" code generates an error, the variable
is set back to its previous value, and the \fBconfigure\fR method
returns an error.
.RE
.TP
\fIobjName\fR \fBisa \fIwidgetName\fR
.
Returns non-zero if the given \fIwidgetName\fR can be found in the
object's heritage, and zero otherwise.
.TP
\fIobjName\fR \fBinfo \fIoption\fR ?\fIargs...\fR?
.
Returns information related to a particular object named
\fIobjName\fR, or to its widget definition. The \fIoption\fR
parameter includes the following things, as well as the options
recognized by the usual Tcl "info" command:
.RS
.TP
\fIobjName\fR \fBinfo widget\fR
.
Returns the name of the most-specific widget for object \fIobjName\fR.
.TP
\fIobjName\fR \fBinfo inherit\fR
.
Returns the list of base widgets as they were defined in the
"\fBinherit\fR" command, or an empty string if this widget
has no base widgets.
.TP
\fIobjName\fR \fBinfo heritage\fR
.
Returns the current widget name and the entire list of base widgets
in the order that they are traversed for member lookup and object
destruction.
.TP
\fIobjName\fR \fBinfo function\fR ?\fIcmdName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-args\fR? ?\fB-body\fR?
.
With no arguments, this command returns a list of all widgets methods
and procs. If \fIcmdName\fR is specified, it returns information
for a specific method or proc. If no flags are specified, this
command returns a list with the following elements: the protection
level, the type (method/proc), the qualified name, the argument list
and the body. Flags can be used to request specific elements from
this list.
.TP
\fIobjName\fR \fBinfo variable\fR ?\fIvarName\fR? ?\fB-protection\fR? ?\fB-type\fR? ?\fB-name\fR? ?\fB-init\fR? ?\fB-value\fR? ?\fB-config\fR?
.
With no arguments, this command returns a list of all object-specific
variables and common data members. If \fIvarName\fR is specified, it
returns information for a specific data member. If no flags are
specified, this command returns a list with the following elements: the
protection level, the type (variable/common), the qualified name, the
initial value, and the current value. If \fIvarName\fR is a public
variable, the "config" code is included on this list. Flags can be
used to request specific elements from this list.
.RE
.SH "CHAINING METHODS/PROCS"
.PP
Sometimes a base widget has a method or proc that is redefined with
the same name in a derived widget. This is a way of making the
derived widget handle the same operations as the base widget, but
with its own specialized behavior. For example, suppose we have
a Toaster widget that looks like this:
.PP
.CS
itcl::widget Toaster {
variable crumbs 0
method toast {nslices} {
if {$crumbs > 50} {
error "== FIRE! FIRE! =="
}
set crumbs [expr {$crumbs+4*$nslices}]
}
method clean {} {
set crumbs 0
}
}
.CE
.PP
We might create another widget like SmartToaster that redefines
the "toast" method. If we want to access the base widget method,
we can qualify it with the base widget name, to avoid ambiguity:
.PP
.CS
itcl::widget SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [Toaster::toast $nslices]
}
}
.CE
.PP
Instead of hard-coding the base widget name, we can use the
"chain" command like this:
.PP
.CS
itcl::widget SmartToaster {
inherit Toaster
method toast {nslices} {
if {$crumbs > 40} {
clean
}
return [chain $nslices]
}
}
.CE
.PP
The chain command searches through the widget hierarchy for
a slightly more generic (base widget) implementation of a method
or proc, and invokes it with the specified arguments. It starts
at the current widget context and searches through base widgets
in the order that they are reported by the "info heritage" command.
If another implementation is not found, this command does nothing
and returns the null string.
.SH AUTO-LOADING
.PP
Widget definitions need not be loaded explicitly; they can be loaded as
needed by the usual Tcl auto-loading facility. Each directory containing
widget definition files should have an accompanying "tclIndex" file.
Each line in this file identifies a Tcl procedure or \fB[incr\ Tcl]\fR
widget definition and the file where the definition can be found.
.PP
For example, suppose a directory contains the definitions for widgets
"Toaster" and "SmartToaster". Then the "tclIndex" file for this
directory would look like:
.PP
.CS
# Tcl autoload index file, version 2.0 for [incr Tcl]
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.
set auto_index(::Toaster) "source $dir/Toaster.itcl"
set auto_index(::SmartToaster) "source $dir/SmartToaster.itcl"
.CE
.PP
The \fBauto_mkindex\fR command is used to automatically
generate "tclIndex" files.
.PP
The auto-loader must be made aware of this directory by appending
the directory name to the "auto_path" variable. When this is in
place, widgets will be auto-loaded as needed when used in an
application.
.SH C PROCEDURES
.PP
C procedures can be integrated into an \fB[incr\ Tcl]\fR widget
definition to implement methods, procs, and the "config" code
for public variables. Any body that starts with "\fB@\fR"
is treated as the symbolic name for a C procedure.
.PP
Symbolic names are established by registering procedures via
\fBItcl_RegisterC()\fR. This is usually done in the \fBTcl_AppInit()\fR
procedure, which is automatically called when the interpreter starts up.
In the following example, the procedure \fCMy_FooCmd()\fR is registered
with the symbolic name "foo". This procedure can be referenced in
the \fBbody\fR command as "\fC@foo\fR".
.PP
.CS
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
if (Itcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (Itcl_RegisterC(interp, "foo", My_FooCmd) != TCL_OK) {
return TCL_ERROR;
}
}
.CE
.PP
C procedures are implemented just like ordinary Tcl commands.
See the \fBCrtCommand\fR man page for details. Within the procedure,
widget data members can be accessed like ordinary variables
using \fBTcl_SetVar()\fR, \fBTcl_GetVar()\fR, \fBTcl_TraceVar()\fR,
etc. Widget methods and procs can be executed like ordinary commands
using \fBTcl_Eval()\fR. \fB[incr\ Tcl]\fR makes this possible by
automatically setting up the context before executing the C procedure.
.PP
This scheme provides a natural migration path for code development.
Widgets can be developed quickly using Tcl code to implement the
bodies. An entire application can be built and tested. When
necessary, individual bodies can be implemented with C code to
improve performance.
.SH KEYWORDS
widget, object, object-oriented

27
pkgs/itcl4.2.0/doc/license.terms Normal file
View File

@@ -0,0 +1,27 @@
------------------------------------------------------------------------
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> [incr Tcl] <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
AUTHOR: Michael J. McLennan
Bell Labs Innovations for Lucent Technologies
mmclennan@lucent.com
http://www.tcltk.com/itcl
========================================================================
Copyright (c) 1993-1996 Lucent Technologies
========================================================================
Permission to use, copy, modify, and distribute this software and its
documentation for any purpose and without fee is hereby granted,
provided that the above copyright notice appear in all copies and that
both that the copyright notice and warranty disclaimer appear in
supporting documentation, and that the names of Lucent Technologies
any of their entities not be used in advertising or publicity
pertaining to distribution of the software without specific, written
prior permission.
Lucent Technologies disclaims all warranties with regard to this
software, including all implied warranties of merchantability and
fitness. In no event shall Lucent be liable for any special, indirect
or consequential damages or any damages whatsoever resulting from loss
of use, data or profits, whether in an action of contract, negligence
or other tortuous action, arising out of or in connection with the use
or performance of this software.
========================================================================

75
pkgs/itcl4.2.0/doc/local.n Normal file
View File

@@ -0,0 +1,75 @@
'\"
'\" 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.
'\"
.TH local n "" itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::local \- create an object local to a procedure
.SH SYNOPSIS
\fBitcl::local \fIclassName objName\fR ?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBlocal\fR command creates an \fB[incr\ Tcl]\fR object that
is local to the current call frame. When the call frame goes away,
the object is automatically deleted. This command is useful for
creating objects that are local to a procedure.
.PP
As a side effect, this command creates a variable named
"\fBitcl-local-\fIxxx\fR", where \fIxxx\fR is the name of
the object that is created. This variable detects when the
call frame is destroyed and automatically deletes the
associated object.
.SH EXAMPLE
.PP
In the following example, a simple "counter" object is used
within the procedure "test". The counter is created as a
local object, so it is automatically deleted each time the
procedure exits. The \fBputs\fR statements included in the
constructor/destructor show the object coming and going
as the procedure is called.
.PP
.CS
itcl::class counter {
private variable count 0
constructor {} {
puts "created: $this"
}
destructor {
puts "deleted: $this"
}
method bump {{by 1}} {
incr count $by
}
method get {} {
return $count
}
}
proc test {val} {
local counter x
for {set i 0} {$i < $val} {incr i} {
x bump
}
return [x get]
}
set result [test 5]
puts "test: $result"
set result [test 10]
puts "test: $result"
puts "objects: [itcl::find objects *]"
.CE
.SH KEYWORDS
class, object, procedure

267
pkgs/itcl4.2.0/doc/man.macros Normal file
View File

@@ -0,0 +1,267 @@
.\" The -*- nroff -*- definitions below are for supplemental macros used
.\" in Tcl/Tk manual entries.
.\"
.\" .AP type name in/out ?indent?
.\" Start paragraph describing an argument to a library procedure.
.\" type is type of argument (int, etc.), in/out is either "in", "out",
.\" or "in/out" to describe whether procedure reads or modifies arg,
.\" and indent is equivalent to second arg of .IP (shouldn't ever be
.\" needed; use .AS below instead)
.\"
.\" .AS ?type? ?name?
.\" Give maximum sizes of arguments for setting tab stops. Type and
.\" name are examples of largest possible arguments that will be passed
.\" to .AP later. If args are omitted, default tab stops are used.
.\"
.\" .BS
.\" Start box enclosure. From here until next .BE, everything will be
.\" enclosed in one large box.
.\"
.\" .BE
.\" End of box enclosure.
.\"
.\" .CS
.\" Begin code excerpt.
.\"
.\" .CE
.\" End code excerpt.
.\"
.\" .VS ?version? ?br?
.\" Begin vertical sidebar, for use in marking newly-changed parts
.\" of man pages. The first argument is ignored and used for recording
.\" the version when the .VS was added, so that the sidebars can be
.\" found and removed when they reach a certain age. If another argument
.\" is present, then a line break is forced before starting the sidebar.
.\"
.\" .VE
.\" End of vertical sidebar.
.\"
.\" .DS
.\" Begin an indented unfilled display.
.\"
.\" .DE
.\" End of indented unfilled display.
.\"
.\" .SO ?manpage?
.\" Start of list of standard options for a Tk widget. The manpage
.\" argument defines where to look up the standard options; if
.\" omitted, defaults to "options". The options follow on successive
.\" lines, in three columns separated by tabs.
.\"
.\" .SE
.\" End of list of standard options for a Tk widget.
.\"
.\" .OP cmdName dbName dbClass
.\" Start of description of a specific option. cmdName gives the
.\" option's name as specified in the class command, dbName gives
.\" the option's name in the option database, and dbClass gives
.\" the option's class in the option database.
.\"
.\" .UL arg1 arg2
.\" Print arg1 underlined, then print arg2 normally.
.\"
.\" .QW arg1 ?arg2?
.\" Print arg1 in quotes, then arg2 normally (for trailing punctuation).
.\"
.\" .PQ arg1 ?arg2?
.\" Print an open parenthesis, arg1 in quotes, then arg2 normally
.\" (for trailing punctuation) and then a closing parenthesis.
.\"
.\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
.\" # Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
. ie !"\\$2"" .TP \\n()Cu
. el .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1 \\fI\\$2\\fP (\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1 \\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
.\" # define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
.\" # BS - start boxed text
.\" # ^y = starting y location
.\" # ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
.\" # BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\" Draw four-sided box normally, but don't draw top of
.\" box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
.\" # VS - start vertical sidebar
.\" # ^Y = starting y location
.\" # ^v = 1 (for troff; for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
.\" # VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
.\" # Special macro to handle page bottom: finish off current
.\" # box/sidebar if in box/sidebar mode, then invoked standard
.\" # page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\" Draw three-sided box if this is the box's first page,
.\" draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
.\" # DS - begin display
.de DS
.RS
.nf
.sp
..
.\" # DE - end display
.de DE
.fi
.RE
.sp
..
.\" # SO - start of list of standard options
.de SO
'ie '\\$1'' .ds So \\fBoptions\\fR
'el .ds So \\fB\\$1\\fR
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 5.5c 11c
.ft B
..
.\" # SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\*(So manual entry for details on the standard options.
..
.\" # OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name: \\fB\\$1\\fR
Database Name: \\fB\\$2\\fR
Database Class: \\fB\\$3\\fR
.fi
.IP
..
.\" # CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
.\" # CE - end code excerpt
.de CE
.fi
.RE
..
.\" # UL - underline word
.de UL
\\$1\l'|0\(ul'\\$2
..
.\" # QW - apply quotation marks to word
.de QW
.ie '\\*(lq'"' ``\\$1''\\$2
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\$2
..
.\" # PQ - apply parens and quotation marks to word
.de PQ
.ie '\\*(lq'"' (``\\$1''\\$2)\\$3
.\"" fix emacs highlighting
.el (\\*(lq\\$1\\*(rq\\$2)\\$3
..
.\" # QR - quoted range
.de QR
.ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3
.\"" fix emacs highlighting
.el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3
..
.\" # MT - "empty" string
.de MT
.QW ""
..

69
pkgs/itcl4.2.0/doc/scope.n Normal file
View File

@@ -0,0 +1,69 @@
'\"
'\" 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.
'\"
.TH scope n "" itcl "[incr\ Tcl]"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
itcl::scope \- capture the namespace context for a variable
.SH SYNOPSIS
\fBitcl::scope \fIname\fR
.BE
.SH DESCRIPTION
.PP
Creates a scoped value for the specified \fIname\fR, which must
be a variable name. If the \fIname\fR is an instance variable,
then the scope command returns a name which will resolve in any
context as an instance variable belonging to \fIobject\fR.
The precise format of this name is an internal detail to Itcl.
Use of such a scoped value makes it possible to use
instance variables in conjunction with widgets. For example, if you
have an object with a private variable \fCx\fR, and you can use
\fCx\fR in conjunction with the \fC-textvariable\fR option of an
entry widget. Before itcl3.0, only common variables could be used
in this manner.
.PP
If the \fIname\fR is not an instance variable, then it must be
a common variable or a global variable. In that case, the scope
command returns the fully qualified name of the variable, e.g.,
\fC::foo::bar::x\fR.
.PP
If the \fIname\fR is not recognized as a variable, the scope
command returns an error.
.PP
Ordinary variable names refer to variables in the global namespace.
A scoped value captures a variable name together with its namespace
context in a way that allows it to be referenced properly later.
It is needed, for example, to wrap up variable names when a Tk
widget is used within a namespace:
.CS
namespace foo {
private variable mode 1
radiobutton .rb1 -text "Mode #1" \
-variable [scope mode] -value 1
pack .rb1
radiobutton .rb2 -text "Mode #2" \
-variable [scope mode] -value 2
pack .rb2
}
.CE
Radiobuttons \fC.rb1\fR and \fC.rb2\fR interact via the variable
"mode" contained in the namespace "foo". The \fBscope\fR command
guarantees this by returning the fully qualified variable name
\fC::foo::mode\fR.
.PP
You should never attempt to craft your own scoped variable names,
even if you believe you've flawlessly reverse-engineered the encoding.
Instead, you should always use the scope command to generate the
variable name dynamically. Then, you can pass that name to a widget
or to any other bit of code in your program.
.SH KEYWORDS
code, namespace, variable

627
pkgs/itcl4.2.0/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.0/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 0
#define ITCL_VERSION "4.2"
#define ITCL_PATCH_LEVEL "4.2.0"
/*
* 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 */

389
pkgs/itcl4.2.0/generic/itcl2TclOO.c Normal file
View File

@@ -0,0 +1,389 @@
/*
* 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 *interp,
int result)
{
Command *cmdPtr = (Command *)data[0];
Proc *procPtr = (Proc *)data[1];
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 *interp,
int result)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
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;
result = TclOOInvokeObject(interp, oPtr, clsPtr, PUBLIC_METHOD,
objc, objv);
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 *clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
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.0/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);

597
pkgs/itcl4.2.0/generic/itclBase.c Normal file
View File

@@ -0,0 +1,597 @@
/*
* 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 *interp, /* current interpreter */
int objc, /* number of arguments */
Tcl_Obj *const objv[]) /* argument objects */
{
ItclObjectInfo *infoPtr;
infoPtr = (ItclObjectInfo *)clientData;
if (infoPtr->currIoPtr != NULL) {
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);
}

3831
pkgs/itcl4.2.0/generic/itclBuiltin.c Normal file
View File

File diff suppressed because it is too large Load Diff

2579
pkgs/itcl4.2.0/generic/itclClass.c Normal file
View File

File diff suppressed because it is too large Load Diff

2174
pkgs/itcl4.2.0/generic/itclCmd.c Normal file
View File

File diff suppressed because it is too large Load Diff

211
pkgs/itcl4.2.0/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 */

2234
pkgs/itcl4.2.0/generic/itclEnsemble.c Normal file
View File

File diff suppressed because it is too large Load Diff

1486
pkgs/itcl4.2.0/generic/itclHelpers.c Normal file
View File

File diff suppressed because it is too large Load Diff

5374
pkgs/itcl4.2.0/generic/itclInfo.c Normal file
View File

File diff suppressed because it is too large Load Diff

830
pkgs/itcl4.2.0/generic/itclInt.h Normal file
View File

@@ -0,0 +1,830 @@
/*
* 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
/*
* 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)
#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.0/generic/itclIntDecls.h Normal file
View File

File diff suppressed because it is too large Load Diff

326
pkgs/itcl4.2.0/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_Interp *interp) /* intepreter 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);
}

2715
pkgs/itcl4.2.0/generic/itclMethod.c Normal file
View File

File diff suppressed because it is too large Load Diff

246
pkgs/itcl4.2.0/generic/itclMigrate2TclCore.c Normal file
View File

@@ -0,0 +1,246 @@
/*
* ------------------------------------------------------------------------
* 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;
#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;
#endif
return TCL_OK;
}
Tcl_Var
Tcl_NewNamespaceVar(
Tcl_Interp *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.0/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);

3731
pkgs/itcl4.2.0/generic/itclObject.c Normal file
View File

File diff suppressed because it is too large Load Diff

4293
pkgs/itcl4.2.0/generic/itclParse.c Normal file
View File

File diff suppressed because it is too large Load Diff

692
pkgs/itcl4.2.0/generic/itclResolve.c Normal file
View File

@@ -0,0 +1,692 @@
/*
* ------------------------------------------------------------------------
* 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;
/*
* 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.0/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.0/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.0/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(
ClientData 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(
ClientData 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(
ClientData cdata) /* not used */
{
/* do nothing */
}

143
pkgs/itcl4.2.0/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,
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.0/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.0/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.0/generic/itclUtil.c Normal file
View File

File diff suppressed because it is too large Load Diff

67
pkgs/itcl4.2.0/itclConfig.sh.in Normal file
View File

@@ -0,0 +1,67 @@
# itclConfig.sh --
#
# This shell script (for sh) is generated automatically by Itcl's
# configure script. It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Itcl extensions so that they don't have to figure this all
# out for themselves. This file does not duplicate information
# already provided by tclConfig.sh, so you may need to use that
# file in addition to this one.
#
# The information in this file is specific to a single platform.
# Itcl's version number.
itcl_VERSION='@PACKAGE_VERSION@'
ITCL_VERSION='@PACKAGE_VERSION@'
# The name of the Itcl library (may be either a .a file or a shared library):
itcl_LIB_FILE=@PKG_LIB_FILE@
ITCL_LIB_FILE=@PKG_LIB_FILE@
# String to pass to linker to pick up the Itcl library from its
# build directory.
itcl_BUILD_LIB_SPEC='@itcl_BUILD_LIB_SPEC@'
ITCL_BUILD_LIB_SPEC='@itcl_BUILD_LIB_SPEC@'
# String to pass to linker to pick up the Itcl library from its
# installed directory.
itcl_LIB_SPEC='@itcl_LIB_SPEC@'
ITCL_LIB_SPEC='@itcl_LIB_SPEC@'
# The name of the Itcl stub library (a .a file):
itcl_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@
ITCL_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@
# String to pass to linker to pick up the Itcl stub library from its
# build directory.
itcl_BUILD_STUB_LIB_SPEC='@itcl_BUILD_STUB_LIB_SPEC@'
ITCL_BUILD_STUB_LIB_SPEC='@itcl_BUILD_STUB_LIB_SPEC@'
# String to pass to linker to pick up the Itcl stub library from its
# installed directory.
itcl_STUB_LIB_SPEC='@itcl_STUB_LIB_SPEC@'
ITCL_STUB_LIB_SPEC='@itcl_STUB_LIB_SPEC@'
# String to pass to linker to pick up the Itcl stub library from its
# build directory.
itcl_BUILD_STUB_LIB_PATH='@itcl_BUILD_STUB_LIB_PATH@'
ITCL_BUILD_STUB_LIB_PATH='@itcl_BUILD_STUB_LIB_PATH@'
# String to pass to linker to pick up the Itcl stub library from its
# installed directory.
itcl_STUB_LIB_PATH='@itcl_STUB_LIB_PATH@'
ITCL_STUB_LIB_PATH='@itcl_STUB_LIB_PATH@'
# Location of the top-level source directories from which [incr Tcl]
# was built. This is the directory that contains generic, unix, etc.
# If [incr Tcl] was compiled in a different place than the directory
# containing the source files, this points to the location of the sources,
# not the location where [incr Tcl] was compiled.
itcl_SRC_DIR='@itcl_SRC_DIR@'
ITCL_SRC_DIR='@itcl_SRC_DIR@'
# String to pass to the compiler so that an extension can
# find installed Itcl headers.
itcl_INCLUDE_SPEC='@itcl_INCLUDE_SPEC@'
ITCL_INCLUDE_SPEC='@itcl_INCLUDE_SPEC@'

151
pkgs/itcl4.2.0/library/itcl.tcl Normal file
View File

@@ -0,0 +1,151 @@
#
# itcl.tcl
# ----------------------------------------------------------------------
# Invoked automatically upon startup to customize the interpreter
# for [incr Tcl].
# ----------------------------------------------------------------------
# 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.
proc ::itcl::delete_helper { name args } {
::itcl::delete object $name
}
# ----------------------------------------------------------------------
# USAGE: local <className> <objName> ?<arg> <arg>...?
#
# Creates a new object called <objName> in class <className>, passing
# the remaining <arg>'s to the constructor. Unlike the usual
# [incr Tcl] objects, however, an object created by this procedure
# will be automatically deleted when the local call frame is destroyed.
# This command is useful for creating objects that should only remain
# alive until a procedure exits.
# ----------------------------------------------------------------------
proc ::itcl::local {class name args} {
set ptr [uplevel [list $class $name] $args]
uplevel [list set itcl-local-$ptr $ptr]
set cmd [uplevel namespace which -command $ptr]
uplevel [list trace variable itcl-local-$ptr u \
"::itcl::delete_helper $cmd"]
return $ptr
}
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
# Define Itcl commands that will be recognized by the auto_mkindex
# parser in Tcl...
#
#
# USAGE: itcl::class name body
# Adds an entry for the given class declaration.
#
foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} {
auto_mkindex_parser::command $__cmd {name body} {
variable index
variable scriptFile
append index "set [list auto_index([fullname $name])]"
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
variable parser
variable contextStack
set contextStack [linsert $contextStack 0 $name]
$parser eval $body
set contextStack [lrange $contextStack 1 end]
}
}
#
# USAGE: itcl::body name arglist body
# Adds an entry for the given method/proc body.
#
foreach __cmd {itcl::body body} {
auto_mkindex_parser::command $__cmd {name arglist body} {
variable index
variable scriptFile
append index "set [list auto_index([fullname $name])]"
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
}
#
# USAGE: itcl::configbody name arglist body
# Adds an entry for the given method/proc body.
#
foreach __cmd {itcl::configbody configbody} {
auto_mkindex_parser::command $__cmd {name body} {
variable index
variable scriptFile
append index "set [list auto_index([fullname $name])]"
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
}
#
# USAGE: ensemble name ?body?
# Adds an entry to the auto index list for the given ensemble name.
#
foreach __cmd {itcl::ensemble ensemble} {
auto_mkindex_parser::command $__cmd {name {body ""}} {
variable index
variable scriptFile
append index "set [list auto_index([fullname $name])]"
append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n"
}
}
#
# USAGE: public arg ?arg arg...?
# protected arg ?arg arg...?
# private arg ?arg arg...?
#
# Evaluates the arguments as commands, so we can recognize proc
# declarations within classes.
#
foreach __cmd {public protected private} {
auto_mkindex_parser::command $__cmd {args} {
variable parser
$parser eval $args
}
}
# SF bug #246 unset variable __cmd to avoid problems in user programs!!
unset __cmd
# ----------------------------------------------------------------------
# auto_import
# ----------------------------------------------------------------------
# This procedure overrides the usual "auto_import" function in the
# Tcl library. It is invoked during "namespace import" to make see
# if the imported commands reside in an autoloaded library. If so,
# stubs are created to represent the commands. Executing a stub
# later on causes the real implementation to be autoloaded.
#
# Arguments -
# pattern The pattern of commands being imported (like "foo::*")
# a canonical namespace as returned by [namespace current]
proc auto_import {pattern} {
global auto_index
set ns [uplevel namespace current]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
if {"" == [info commands $name]} {
::itcl::import::stub create $name
}
}
}
}

562
pkgs/itcl4.2.0/library/itclHullCmds.tcl Normal file
View File

@@ -0,0 +1,562 @@
#
# itclHullCmds.tcl
# ----------------------------------------------------------------------
# Invoked automatically upon startup to customize the interpreter
# for [incr Tcl] when one of setupcomponent or createhull is called.
# ----------------------------------------------------------------------
# AUTHOR: Arnulf P. Wiedemann
#
# ----------------------------------------------------------------------
# Copyright (c) 2008 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 require Tk 8.6
namespace eval ::itcl::internal::commands {
# ======================= widgetDeleted ===========================
proc widgetDeleted {oldName newName op} {
# The widget is beeing deleted, so we have to delete the object
# which had the widget as itcl_hull too!
# We have to get the real name from for example
# ::itcl::internal::widgets::hull1.lw
# we need only .lw here
#puts stderr "widgetDeleted!$oldName!$newName!$op!"
set cmdName [namespace tail $oldName]
set flds [split $cmdName {.}]
set cmdName .[join [lrange $flds 1 end] {.}]
#puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!"
rename $cmdName {}
}
}
namespace eval ::itcl::builtin {
# ======================= createhull ===========================
# the hull widget is a tk widget which is the (mega) widget handled behind the itcl
# extendedclass/itcl widget.
# It is created be renaming the itcl class object to a temporary name <itcl object name>_
# creating the widget with the
# appropriate options and the installing that as the "hull" widget (the container)
# All the options in args and the options delegated to component itcl_hull are used
# Then a unique name (hull_widget_name) in the itcl namespace is created for widget:
# ::itcl::internal::widgets::hull<unique number><namespace tail path>
# and widget is renamed to that name
# Finally the <itcl object name>_ is renamed to the original <itcl object name> again
# Component itcl_hull is created if not existent
# itcl_hull is set to the hull_widget_name and the <itcl object name>
# is returned to the caller
# ==============================================================
proc createhull {widget_type path args} {
variable hullCount
upvar this this
upvar win win
#puts stderr "il-1![::info level -1]!$this!"
#puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!"
#puts stderr "ns1![uplevel 1 namespace current]!"
#puts stderr "ns2![uplevel 2 namespace current]!"
#puts stderr "ns3![uplevel 3 namespace current]!"
#puts stderr "level-1![::info level -1]!"
#puts stderr "level-2![::info level -2]!"
# set my_this [namespace tail $this]
set my_this $this
set tmp $my_this
#puts stderr "II![::info command $this]![::info command $tmp]!"
#puts stderr "rename1!rename $my_this ${tmp}_!"
rename ::$my_this ${tmp}_
set options [list]
foreach {option_name value} $args {
switch -glob -- $option_name {
-class {
lappend options $option_name [namespace tail $value]
}
-* {
lappend options $option_name $value
}
default {
return -code error "bad option name\"$option_name\" options must start with a \"-\""
}
}
}
set my_win [namespace tail $path]
set cmd [list $widget_type $my_win]
#puts stderr "my_win!$my_win!cmd!$cmd!$path!"
if {[llength $options] > 0} {
lappend cmd {*}$options
}
set widget [uplevel 1 $cmd]
#puts stderr "widget!$widget!"
trace add command $widget delete ::itcl::internal::commands::widgetDeleted
set opts [uplevel 1 info delegated options]
foreach entry $opts {
foreach {optName compName} $entry break
if {$compName eq "itcl_hull"} {
set optInfos [uplevel 1 info delegated option $optName]
set realOptName [lindex $optInfos 4]
# strip off the "-" at the beginning
set myOptName [string range $realOptName 1 end]
set my_opt_val [option get $my_win $myOptName *]
if {$my_opt_val ne ""} {
$my_win configure -$myOptName $my_opt_val
}
}
}
set idx 1
while {1} {
set widgetName ::itcl::internal::widgets::hull${idx}$my_win
#puts stderr "widgetName!$widgetName!"
if {[string length [::info command $widgetName]] == 0} {
break
}
incr idx
}
#puts stderr "rename2!rename $widget $widgetName!"
set dorename 0
rename $widget $widgetName
#puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!"
rename ${tmp}_ ::$tmp
set exists [uplevel 1 ::info exists itcl_hull]
if {!$exists} {
# that does not yet work, beacause of problems with resolving
::itcl::addcomponent $my_this itcl_hull
}
upvar itcl_hull itcl_hull
::itcl::setcomponent $my_this itcl_hull $widgetName
#puts stderr "IC![::info command $my_win]!"
set exists [uplevel 1 ::info exists itcl_interior]
if {!$exists} {
# that does not yet work, beacause of problems with resolving
::itcl::addcomponent $this itcl_interior
}
upvar itcl_interior itcl_interior
set itcl_interior $my_win
#puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!"
return $my_win
}
# ======================= addToItclOptions ===========================
proc addToItclOptions {my_class my_win myOptions argsDict} {
upvar win win
upvar itcl_hull itcl_hull
set opt_lst [list configure]
foreach opt [lsort $myOptions] {
#puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!"
set isClass [::itcl::is class $my_class]
set found 0
if {$isClass} {
if {[catch {
set resource [namespace eval $my_class info option $opt -resource]
set class [namespace eval $my_class info option $opt -class]
set default_val [uplevel 2 info option $opt -default]
set found 1
} msg]} {
# puts stderr "MSG!$opt!$my_class!$msg!"
}
} else {
set tmp_win [uplevel #0 $my_class .___xx]
set my_info [$tmp_win configure $opt]
set resource [lindex $my_info 1]
set class [lindex $my_info 2]
set default_val [lindex $my_info 3]
uplevel #0 destroy $tmp_win
set found 1
}
if {$found} {
if {[catch {
set val [uplevel #0 ::option get $win $resource $class]
} msg]} {
set val ""
}
if {[::dict exists $argsDict $opt]} {
# we have an explicitly set option
set val [::dict get $argsDict $opt]
} else {
if {[string length $val] == 0} {
set val $default_val
}
}
set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val
set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
# uplevel 1 [list set itcl_options($opt) [list $val]]
if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} {
#puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!"
}
}
}
}
# ======================= setupcomponent ===========================
proc setupcomponent {comp using widget_type path args} {
upvar this this
upvar win win
upvar itcl_hull itcl_hull
#puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!"
#puts stderr "CONT![uplevel 1 info context]!"
#puts stderr "ns1![uplevel 1 namespace current]!"
#puts stderr "ns2![uplevel 2 namespace current]!"
#puts stderr "ns3![uplevel 3 namespace current]!"
set my_comp_object [lindex [uplevel 1 info context] 1]
if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} {
set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)]
} else {
set ::itcl::internal::component_objects($path) $my_comp_object
}
set options [list]
foreach {option_name value} $args {
switch -glob -- $option_name {
-* {
lappend options $option_name $value
}
default {
return -code error "bad option name\"$option_name\" options must start with a \"-\""
}
}
}
if {[llength $args]} {
set argsDict [dict create {*}$args]
} else {
set argsDict [dict create]
}
set cmd [list $widget_type $path]
if {[llength $options] > 0} {
lappend cmd {*}$options
}
#puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!"
#puts stderr "cmd1!$cmd!"
# set my_comp [uplevel 3 $cmd]
set my_comp [uplevel #0 $cmd]
#puts stderr 111![::info command $path]!
::itcl::setcomponent $this $comp $my_comp
set opts [uplevel 1 info delegated options]
foreach entry $opts {
foreach {optName compName} $entry break
if {$compName eq $my_comp} {
set optInfos [uplevel 1 info delegated option $optName]
set realOptName [lindex $optInfos 4]
# strip off the "-" at the beginning
set myOptName [string range $realOptName 1 end]
set my_opt_val [option get $my_win $myOptName *]
if {$my_opt_val ne ""} {
$my_comp configure -$myOptName $my_opt_val
}
}
}
set my_class $widget_type
set my_parent_class [uplevel 1 namespace current]
if {[catch {
set myOptions [namespace eval $my_class {info classoptions}]
} msg]} {
set myOptions [list]
}
foreach entry [$path configure] {
foreach {opt dummy1 dummy2 dummy3} $entry break
lappend myOptions $opt
}
#puts stderr "OPTS!$myOptions!"
addToItclOptions $widget_type $my_comp_object $myOptions $argsDict
#puts stderr END!$path![::info command $path]!
}
proc itcl_initoptions {args} {
puts stderr "ITCL_INITOPT!$args!"
}
# ======================= initoptions ===========================
proc initoptions {args} {
upvar win win
upvar itcl_hull itcl_hull
upvar itcl_option_components itcl_option_components
#puts stderr "INITOPT!!$win!"
if {[llength $args]} {
set argsDict [dict create {*}$args]
} else {
set argsDict [dict create]
}
set my_class [uplevel 1 namespace current]
set myOptions [namespace eval $my_class {info classoptions}]
if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} {
set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
# set myOptions [lsort -unique [namespace eval $my_class {info options}]]
foreach comp [uplevel 1 info components] {
if {[dict exists $class_info_dict $comp -keptoptions]} {
foreach my_opt [dict get $class_info_dict $comp -keptoptions] {
if {[lsearch $myOptions $my_opt] < 0} {
#puts stderr "KEOPT!$my_opt!"
lappend myOptions $my_opt
}
}
}
}
} else {
set class_info_dict [list]
}
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
set opt_lst [list configure]
set my_win $win
foreach opt [lsort $myOptions] {
set found 0
if {[catch {
set resource [uplevel 1 info option $opt -resource]
set class [uplevel 1 info option $opt -class]
set default_val [uplevel 1 info option $opt -default]
set found 1
} msg]} {
# puts stderr "MSG!$opt!$msg!"
}
#puts stderr "OPT!$opt!$found!"
if {$found} {
if {[catch {
set val [uplevel #0 ::option get $my_win $resource $class]
} msg]} {
set val ""
}
if {[::dict exists $argsDict $opt]} {
# we have an explicitly set option
set val [::dict get $argsDict $opt]
} else {
if {[string length $val] == 0} {
set val $default_val
}
}
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
# uplevel 1 [list set itcl_options($opt) [list $val]]
if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} {
puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
}
}
foreach comp [dict keys $class_info_dict] {
#puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!"
if {[dict exists $class_info_dict $comp -keptoptions]} {
if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} {
if {$found == 0} {
# we use the option value of the first component for setting
# the option, as the components are traversed in the dict
# depending on the ordering of the component creation!!
set my_info [uplevel 1 \[set $comp\] configure $opt]
set resource [lindex $my_info 1]
set class [lindex $my_info 2]
set default_val [lindex $my_info 3]
set found 2
set val [uplevel #0 ::option get $my_win $resource $class]
if {[::dict exists $argsDict $opt]} {
# we have an explicitly set option
set val [::dict get $argsDict $opt]
} else {
if {[string length $val] == 0} {
set val $default_val
}
}
#puts stderr "OPT2!$opt!$val!"
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val]
# uplevel 1 [list set itcl_options($opt) [list $val]]
}
if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} {
puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!"
}
if {![uplevel 1 info exists itcl_option_components($opt)]} {
set itcl_option_components($opt) [list]
}
if {[lsearch [set itcl_option_components($opt)] $comp] < 0} {
if {![catch {
set optval [uplevel 1 [list set itcl_options($opt)]]
} msg3]} {
uplevel 1 \[set $comp\] configure $opt $optval
}
lappend itcl_option_components($opt) $comp
}
}
}
}
}
# uplevel 1 $opt_lst
}
# ======================= setoptions ===========================
proc setoptions {args} {
#puts stderr "setOPT!!$args!"
if {[llength $args]} {
set argsDict [dict create {*}$args]
} else {
set argsDict [dict create]
}
set my_class [uplevel 1 namespace current]
set myOptions [namespace eval $my_class {info options}]
#puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!"
set opt_lst [list configure]
foreach opt [lsort $myOptions] {
set found 0
if {[catch {
set resource [uplevel 1 info option $opt -resource]
set class [uplevel 1 info option $opt -class]
set default_val [uplevel 1 info option $opt -default]
set found 1
} msg]} {
# puts stderr "MSG!$opt!$msg!"
}
#puts stderr "OPT!$opt!$found!"
if {$found} {
set val ""
if {[::dict exists $argsDict $opt]} {
# we have an explicitly set option
set val [::dict get $argsDict $opt]
} else {
if {[string length $val] == 0} {
set val $default_val
}
}
set myObj [uplevel 1 set this]
#puts stderr "myObj!$myObj!"
set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val
set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val]
#puts stderr "OPT1!$opt!$val!"
uplevel 1 [list set itcl_options($opt) [list $val]]
# if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} {
#puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!"
# }
}
}
# uplevel 1 $opt_lst
}
# ========================= keepcomponentoption ======================
# Invoked by Tcl during evaluating constructor whenever
# the "keepcomponentoption" command is invoked to list the options
# to be kept when an ::itcl::extendedclass component has been setup
# for an object.
#
# It checks, for all arguments, if the opt is an option of that class
# and of that component. If that is the case it adds the component name
# to the list of components for that option.
# The variable is the object variable: itcl_option_components($opt)
#
# Handles the following syntax:
#
# keepcomponentoption <componentName> <optionName> ?<optionName> ...?
#
# ======================================================================
proc keepcomponentoption {args} {
upvar win win
upvar itcl_hull itcl_hull
set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?"
#puts stderr "KEEP!$args![uplevel 1 namespace current]!"
if {[llength $args] < 2} {
puts stderr $usage
return -code error
}
set my_hull [uplevel 1 set itcl_hull]
set my_class [uplevel 1 namespace current]
set comp [lindex $args 0]
set args [lrange $args 1 end]
set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class]
if {![dict exists $class_info_dict $comp]} {
puts stderr "keepcomponentoption cannot find component \"$comp\""
return -code error
}
set class_comp_dict [dict get $class_info_dict $comp]
if {![dict exists $class_comp_dict -keptoptions]} {
dict set class_comp_dict -keptoptions [list]
}
foreach opt $args {
#puts stderr "KEEP!$opt!"
if {[string range $opt 0 0] ne "-"} {
puts stderr "keepcomponentoption: option must begin with a \"-\"!"
return -code error
}
if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} {
dict lappend class_comp_dict -keptoptions $opt
}
}
if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} {
set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])
} else {
set comp_object "unknown_comp_obj_$comp!"
}
dict set class_info_dict $comp $class_comp_dict
dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict
puts stderr "CLDI!$class_comp_dict!"
addToItclOptions $my_class $comp_object $args [list]
}
proc ignorecomponentoption {args} {
puts stderr "IGNORE_COMPONENT_OPTION!$args!"
}
proc renamecomponentoption {args} {
puts stderr "rename_COMPONENT_OPTION!$args!"
}
proc addoptioncomponent {args} {
puts stderr "ADD_OPTION_COMPONENT!$args!"
}
proc ignoreoptioncomponent {args} {
puts stderr "IGNORE_OPTION_COMPONENT!$args!"
}
proc renameoptioncomponent {args} {
puts stderr "RENAME_OPTION_COMPONENT!$args!"
}
proc getEclassOptions {args} {
upvar win win
#puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!"
#parray ::itcl::internal::variables::${win}::itcl_options
set result [list]
foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] {
if {[catch {
foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
} msg]} {
}
}
return $result
}
proc eclassConfigure {args} {
upvar win win
#puts stderr "+++ eclassConfigure!$args!"
if {[llength $args] > 1} {
foreach {opt val} $args break
if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
set ::itcl::internal::variables::${win}::itcl_options($opt) $val
return
}
} else {
foreach {opt} $args break
if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} {
#puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!"
foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break
return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]]
}
}
return -code error
}
}

447
pkgs/itcl4.2.0/library/itclWidget.tcl Normal file
View File

@@ -0,0 +1,447 @@
#
# itclWidget.tcl
# ----------------------------------------------------------------------
# Invoked automatically upon startup to customize the interpreter
# for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called.
# ----------------------------------------------------------------------
# AUTHOR: Arnulf P. Wiedemann
#
# ----------------------------------------------------------------------
# Copyright (c) 2008 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 require Tk 8.6
# package require itclwidget [set ::itcl::version]
namespace eval ::itcl {
proc widget {name args} {
set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args]
# we handle create by owerselfs !! allow classunknown to handle that
oo::objdefine $result unexport create
return $result
}
proc widgetadaptor {name args} {
set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args]
# we handle create by owerselfs !! allow classunknown to handle that
oo::objdefine $result unexport create
return $result
}
} ; # end ::itcl
namespace eval ::itcl::internal::commands {
proc initWidgetOptions {varNsName widgetName className} {
set myDict [set ::itcl::internal::dicts::classOptions]
if {$myDict eq ""} {
return
}
if {![dict exists $myDict $className]} {
return
}
set myDict [dict get $myDict $className]
foreach option [dict keys $myDict] {
set infos [dict get $myDict $option]
set resource [dict get $infos -resource]
set class [dict get $infos -class]
set value [::option get $widgetName $resource $class]
if {$value eq ""} {
if {[dict exists $infos -default]} {
set defaultValue [dict get $infos -default]
uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue
}
} else {
uplevel 1 set ${varNsName}::itcl_options($option) $value
}
}
}
proc initWidgetDelegatedOptions {varNsName widgetName className args} {
set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
if {$myDict eq ""} {
return
}
if {![dict exists $myDict $className]} {
return
}
set myDict [dict get $myDict $className]
foreach option [dict keys $myDict] {
set infos [dict get $myDict $option]
if {![dict exists $infos -resource]} {
# this is the case when delegating "*"
continue
}
if {![dict exists $infos -component]} {
# nothing to do
continue
}
# check if not in the command line options
# these have higher priority
set myOption $option
if {[dict exists $infos -as]} {
set myOption [dict get $infos -as]
}
set noOptionSet 0
foreach {optName optVal} $args {
if {$optName eq $myOption} {
set noOptionSet 1
break
}
}
if {$noOptionSet} {
continue
}
set resource [dict get $infos -resource]
set class [dict get $infos -class]
set component [dict get $infos -component]
set value [::option get $widgetName $resource $class]
if {$component ne ""} {
if {$value ne ""} {
set compVar [namespace eval ${varNsName}${className} "set $component"]
if {$compVar ne ""} {
uplevel 1 $compVar configure $myOption $value
}
}
}
}
}
proc widgetinitobjectoptions {varNsName widgetName className} {
#puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!"
}
proc deletehull {newName oldName what} {
if {$what eq "delete"} {
set name [namespace tail $newName]
regsub {hull[0-9]+} $name {} name
rename $name {}
}
if {$what eq "rename"} {
set name [namespace tail $newName]
regsub {hull[0-9]+} $name {} name
rename $name {}
}
}
proc hullandoptionsinstall {objectName className widgetClass hulltype args} {
if {$hulltype eq ""} {
set hulltype frame
}
set idx 0
set found 0
foreach {optName optValue} $args {
if {$optName eq "-class"} {
set found 1
set widgetClass $optValue
break
}
incr idx
}
if {$found} {
set args [lreplace $args $idx [expr {$idx + 1}]]
}
if {$widgetClass eq ""} {
set widgetClass $className
set widgetClass [string totitle $widgetClass]
}
set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args"
uplevel 2 $cmd
}
} ; # end ::itcl::internal::commands
namespace eval ::itcl::builtin {
proc installhull {args} {
set cmdPath ::itcl::internal::commands
set className [uplevel 1 info class]
set replace 0
switch -- [llength $args] {
0 {
return -code error\
"wrong # args: should be \"[lindex [info level 0] 0]\
name|using <widgetType> ?arg ...?\""
}
1 {
set widgetName [lindex $args 0]
set varNsName $::itcl::internal::varNsName($widgetName)
}
default {
upvar win win
set widgetName $win
set varNsName $::itcl::internal::varNsName($widgetName)
set widgetType [lindex $args 1]
incr replace
if {[llength $args] > 3 && [lindex $args 2] eq "-class"} {
set classNam [lindex $args 3]
incr replace 2
} else {
set classNam [string totitle $widgetType]
}
uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam]
uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className]
}
}
# initialize the itcl_hull variable
set i 0
set nam ::itcl::internal::widgets::hull
while {1} {
incr i
set hullNam ${nam}${i}$widgetName
if {[::info command $hullNam] eq ""} {
break
}
}
uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName]
uplevel 1 [list ::rename $widgetName $hullNam]
uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull]
catch {${cmdPath}::checksetitclhull [list] 0}
namespace eval ${varNsName}${className} "set itcl_hull $hullNam"
catch {${cmdPath}::checksetitclhull [list] 2}
uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className]
}
proc installcomponent {args} {
upvar win win
set className [uplevel 1 info class]
set myType [${className}::info types [namespace tail $className]]
set isType 0
if {$myType ne ""} {
set isType 1
}
set numArgs [llength $args]
set usage "usage: installcomponent <componentName> using <widgetType> <widgetPath> ?-option value ...?"
if {$numArgs < 4} {
error $usage
}
foreach {componentName using widgetType widgetPath} $args break
set opts [lrange $args 4 end]
if {$using ne "using"} {
error $usage
}
if {!$isType} {
set hullExists [uplevel 1 ::info exists itcl_hull]
if {!$hullExists} {
error "cannot install \"$componentName\" before \"itcl_hull\" exists"
}
set hullVal [uplevel 1 set itcl_hull]
if {$hullVal eq ""} {
error "cannot install \"$componentName\" before \"itcl_hull\" exists"
}
}
# check for delegated option and ask the option database for the values
# first check for number of delegated options
set numOpts 0
set starOption 0
set myDict [set ::itcl::internal::dicts::classDelegatedOptions]
if {[dict exists $myDict $className]} {
set myDict [dict get $myDict $className]
foreach option [dict keys $myDict] {
if {$option eq "*"} {
set starOption 1
}
incr numOpts
}
}
set myOptionDict [set ::itcl::internal::dicts::classOptions]
if {[dict exists $myOptionDict $className]} {
set myOptionDict [dict get $myOptionDict $className]
}
set cmd [list $widgetPath configure]
set cmd1 "set $componentName \[$widgetType $widgetPath\]"
uplevel 1 $cmd1
if {$starOption} {
upvar $componentName compName
set cmd1 [list $compName configure]
set configInfos [uplevel 1 $cmd1]
foreach entry $configInfos {
if {[llength $entry] > 2} {
foreach {optName resource class defaultValue} $entry break
set val ""
catch {
set val [::option get $win $resource $class]
}
if {$val ne ""} {
set addOpt 1
if {[dict exists $myDict $$optName]} {
set addOpt 0
} else {
set starDict [dict get $myDict "*"]
if {[dict exists $starDict -except]} {
set exceptions [dict get $starDict -except]
if {[lsearch $exceptions $optName] >= 0} {
set addOpt 0
}
}
if {[dict exists $myOptionDict $optName]} {
set addOpt 0
}
}
if {$addOpt} {
lappend cmd $optName $val
}
}
}
}
} else {
foreach optName [dict keys $myDict] {
set optInfos [dict get $myDict $optName]
set resource [dict get $optInfos -resource]
set class [namespace tail $className]
set class [string totitle $class]
set val ""
catch {
set val [::option get $win $resource $class]
}
if {$val ne ""} {
if {[dict exists $optInfos -as] } {
set optName [dict get $optInfos -as]
}
lappend cmd $optName $val
}
}
}
lappend cmd {*}$opts
uplevel 1 $cmd
}
} ; # end ::itcl::builtin
set ::itcl::internal::dicts::hullTypes [list \
frame \
toplevel \
labelframe \
ttk:frame \
ttk:toplevel \
ttk:labelframe \
]
namespace eval ::itcl::builtin::Info {
proc hulltypes {args} {
namespace upvar ::itcl::internal::dicts hullTypes hullTypes
set numArgs [llength $args]
if {$numArgs > 1} {
error "wrong # args should be: info hulltypes ?<pattern>?"
}
set pattern ""
if {$numArgs > 0} {
set pattern [lindex $args 0]
}
if {$pattern ne ""} {
return [lsearch -all -inline -glob $hullTypes $pattern]
}
return $hullTypes
}
proc widgetclasses {args} {
set numArgs [llength $args]
if {$numArgs > 1} {
error "wrong # args should be: info widgetclasses ?<pattern>?"
}
set pattern ""
if {$numArgs > 0} {
set pattern [lindex $args 0]
}
set myDict [set ::itcl::internal::dicts::classes]
if {![dict exists $myDict widget]} {
return [list]
}
set myDict [dict get $myDict widget]
set result [list]
if {$pattern ne ""} {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
set value [dict get $myInfo -widget]
if {[string match $pattern $value]} {
lappend result $value
}
}
} else {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
lappend result [dict get $myInfo -widget]
}
}
return $result
}
proc widgets {args} {
set numArgs [llength $args]
if {$numArgs > 1} {
error "wrong # args should be: info widgets ?<pattern>?"
}
set pattern ""
if {$numArgs > 0} {
set pattern [lindex $args 0]
}
set myDict [set ::itcl::internal::dicts::classes]
if {![dict exists $myDict widget]} {
return [list]
}
set myDict [dict get $myDict widget]
set result [list]
if {$pattern ne ""} {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
set value [dict get $myInfo -name]
if {[string match $pattern $value]} {
lappend result $value
}
}
} else {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
lappend result [dict get $myInfo -name]
}
}
return $result
}
proc widgetadaptors {args} {
set numArgs [llength $args]
if {$numArgs > 1} {
error "wrong # args should be: info widgetadaptors ?<pattern>?"
}
set pattern ""
if {$numArgs > 0} {
set pattern [lindex $args 0]
}
set myDict [set ::itcl::internal::dicts::classes]
if {![dict exists $myDict widgetadaptor]} {
return [list]
}
set myDict [dict get $myDict widgetadaptor]
set result [list]
if {$pattern ne ""} {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
set value [dict get $myInfo -name]
if {[string match $pattern $value]} {
lappend result $value
}
}
} else {
foreach key [dict keys $myDict] {
set myInfo [dict get $myDict $key]
lappend result [dict get $myInfo -name]
}
}
return $result
}
} ; # end ::itcl::builtin::Info

26
pkgs/itcl4.2.0/library/test_Itcl_CreateObject.tcl Normal file
View File

@@ -0,0 +1,26 @@
# this is a program for testing the stubs interface ItclCreateObject.
# it uses itclTestRegisterC.c with the call C function functionality,
# so it also tests that feature.
# you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE
# for makeing that work.
package require itcl
::itcl::class ::c1 {
public method c0 {args} @cArgFunc
public method m1 { args } { puts "Hello Tcl $args" }
}
set obj1 [::c1 #auto ]
$obj1 m1 World
# C method cargFunc implements a call to Itcl_CreateObject!
#
# args for method c0 of class ::c1
# arg1 does not matter
# arg2 is the class name
# arg3 is the full class name (full path name)
# arg4 is the object name of the created Itcl object
set obj2 [$obj1 c0 ::itcl::parser::handleClass ::c1 ::c1 ::c1::c11]
# test, if it is working!
$obj2 m1 Folks

46
pkgs/itcl4.2.0/license.terms Normal file
View File

@@ -0,0 +1,46 @@
This is a mostly rewritten version of [incr Tcl], which is copyrighted
by Arnulf P. Wiedemann (c) Copyright 2008. It is derived from a version
written by Lucent Technologies, Inc., and other parties see that copyright
below.
The rewritten version is copyrighted with BSD license or Public Domain at
your choice.
The original version of this software is copyrighted by Lucent Technologies,
Inc., and other parties. The following terms apply to all files associated
with the software unless explicitly disclaimed in individual files.
The authors hereby grant permission to use, copy, modify, distribute,
and license this software and its documentation for any purpose, provided
that existing copyright notices are retained in all copies and that this
notice is included verbatim in any distributions. No written agreement,
license, or royalty fee is required for any of the authorized uses.
Modifications to this software may be copyrighted by their authors
and need not follow the licensing terms described here, provided that
the new terms are clearly indicated on the first page of each file where
they apply.
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
MODIFICATIONS.
GOVERNMENT USE: If you are acquiring this software on behalf of the
U.S. government, the Government shall have only "Restricted Rights"
in the software and related documentation as defined in the Federal
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
are acquiring the software on behalf of the Department of Defense, the
software shall be classified as "Commercial Computer Software" and the
Government shall have only "Restricted Rights" as defined in Clause
252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
authors grant the U.S. Government and others acting in its behalf
permission to use and distribute the software in accordance with the
terms specified in this license.

21
pkgs/itcl4.2.0/pkgIndex.tcl.in Normal file
View File

@@ -0,0 +1,21 @@
# Tcl package index file, version 1.0
#
# Do NOT try this command
#
# if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
#
# as a way to accept working with all of Tcl 8.6, Tcl 8.X, X>6, and
# Tcl Y, for Y > 8.
# Itcl is a binary package, added to an interp with [load].
# There is no libitcl.so that will [load] into both Tcl 8 and Tcl 9.
# The indexed libitcl.so was built to [load] into one or the other.
# Thus the pkgIndex.tcl should only accept the version of Tcl for which
# the indexed @PKG_LIB_FILE@ was built.
#
# More work replacing the literal "8.6" below with the proper value substituted
# by configure is the right way forward.
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl]
package ifneeded Itcl @PACKAGE_VERSION@ [list load [file join $dir "@PKG_LIB_FILE@"] itcl]

33
pkgs/itcl4.2.0/releasenotes.txt Normal file
View File

@@ -0,0 +1,33 @@
This is the release 4.1.2 of Itcl.
It is intended to be script compatible with Itcl 4.0.* and Itcl 3.4.* .
It very likely presents the same public C interface as Itcl 4.0.* .
It includes incompatible changes to internal structs when compared
with Itcl 4.0.* . Unfortunately, the extension Itk 4.0.* intrudes
in those internals and will notice and break in the presence of Itcl 4.1.* .
When you upgrade to Itcl 4.1 , you must also upgrade to Itk 4.1 . It
is possible you will find other extensions and applications repeating Itk's
error.
Notes of past releases follow below
-----------------------------------
The difference to 4.0.*: in this release there are only bug fixes from SF and the fossil bug tracker for itcl.
This is the first stable release of Itcl 4.0.
It is a new major release of Itcl.
The difference to 4.0b7: Tighter control on the set of exported functions.
The difference to 4.0b6: Updated TEA system and related build system changes.
The difference to 4.0b5: in this release there are only bug fixes from SF
tracker and updates for using Tcl 8.6 version from fossil repo trunk
The difference to 4.0b4: in this release there are only bug fixes from SF
tracker and updates to TEA 3.9.
The difference to 4.0b3: in this release there are only bug fixes from SF
tracker and some fixes to run on OSX and Windows platform.
There is no known incompatibility.

26
pkgs/itcl4.2.0/tclconfig/README.txt Normal file
View File

@@ -0,0 +1,26 @@
These files comprise the basic building blocks for a Tcl Extension
Architecture (TEA) extension. For more information on TEA see:
http://www.tcl.tk/doc/tea/
This package is part of the Tcl project at SourceForge, and latest
sources should be available there:
http://tcl.sourceforge.net/
This package is a freely available open source package. You can do
virtually anything you like with it, such as modifying it, redistributing
it, and selling it either in whole or in part.
CONTENTS
========
The following is a short description of the files you will find in
the sample extension.
README.txt This file
install-sh Program used for copying binaries and script files
to their install locations.
tcl.m4 Collection of Tcl autoconf macros. Included by a package's
aclocal.m4 to define TEA_* macros.

528
pkgs/itcl4.2.0/tclconfig/install-sh Normal file
View File

@@ -0,0 +1,528 @@
#!/bin/sh
# install - install a program, script, or datafile
scriptversion=2011-04-20.01; # UTC
# This originates from X11R5 (mit/util/scripts/install.sh), which was
# later released in X11R6 (xc/config/util/install.sh) with the
# following copyright and license.
#
# Copyright (C) 1994 X Consortium
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
# Except as contained in this notice, the name of the X Consortium shall not
# be used in advertising or otherwise to promote the sale, use or other deal-
# ings in this Software without prior written authorization from the X Consor-
# tium.
#
#
# FSF changes to this file are in the public domain.
#
# Calling this script install-sh is preferred over install.sh, to prevent
# `make' implicit rules from creating a file called install from it
# when there is no Makefile.
#
# This script is compatible with the BSD install script, but was written
# from scratch.
nl='
'
IFS=" "" $nl"
# set DOITPROG to echo to test this script
# Don't use :- since 4.3BSD and earlier shells don't like it.
doit=${DOITPROG-}
if test -z "$doit"; then
doit_exec=exec
else
doit_exec=$doit
fi
# Put in absolute file names if you don't have them in your path;
# or use environment vars.
chgrpprog=${CHGRPPROG-chgrp}
chmodprog=${CHMODPROG-chmod}
chownprog=${CHOWNPROG-chown}
cmpprog=${CMPPROG-cmp}
cpprog=${CPPROG-cp}
mkdirprog=${MKDIRPROG-mkdir}
mvprog=${MVPROG-mv}
rmprog=${RMPROG-rm}
stripprog=${STRIPPROG-strip}
posix_glob='?'
initialize_posix_glob='
test "$posix_glob" != "?" || {
if (set -f) 2>/dev/null; then
posix_glob=
else
posix_glob=:
fi
}
'
posix_mkdir=
# Desired mode of installed file.
mode=0755
chgrpcmd=
chmodcmd=$chmodprog
chowncmd=
mvcmd=$mvprog
rmcmd="$rmprog -f"
stripcmd=
src=
dst=
dir_arg=
dst_arg=
copy_on_change=false
no_target_directory=
usage="\
Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
or: $0 [OPTION]... SRCFILES... DIRECTORY
or: $0 [OPTION]... -t DIRECTORY SRCFILES...
or: $0 [OPTION]... -d DIRECTORIES...
In the 1st form, copy SRCFILE to DSTFILE.
In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
In the 4th, create DIRECTORIES.
Options:
--help display this help and exit.
--version display version info and exit.
-c (ignored)
-C install only if different (preserve the last data modification time)
-d create directories instead of installing files.
-g GROUP $chgrpprog installed files to GROUP.
-m MODE $chmodprog installed files to MODE.
-o USER $chownprog installed files to USER.
-s $stripprog installed files.
-S $stripprog installed files.
-t DIRECTORY install into DIRECTORY.
-T report an error if DSTFILE is a directory.
Environment variables override the default commands:
CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG
RMPROG STRIPPROG
"
while test $# -ne 0; do
case $1 in
-c) ;;
-C) copy_on_change=true;;
-d) dir_arg=true;;
-g) chgrpcmd="$chgrpprog $2"
shift;;
--help) echo "$usage"; exit $?;;
-m) mode=$2
case $mode in
*' '* | *' '* | *'
'* | *'*'* | *'?'* | *'['*)
echo "$0: invalid mode: $mode" >&2
exit 1;;
esac
shift;;
-o) chowncmd="$chownprog $2"
shift;;
-s) stripcmd=$stripprog;;
-S) stripcmd="$stripprog $2"
shift;;
-t) dst_arg=$2
shift;;
-T) no_target_directory=true;;
--version) echo "$0 $scriptversion"; exit $?;;
--) shift
break;;
-*) echo "$0: invalid option: $1" >&2
exit 1;;
*) break;;
esac
shift
done
if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then
# When -d is used, all remaining arguments are directories to create.
# When -t is used, the destination is already specified.
# Otherwise, the last argument is the destination. Remove it from $@.
for arg
do
if test -n "$dst_arg"; then
# $@ is not empty: it contains at least $arg.
set fnord "$@" "$dst_arg"
shift # fnord
fi
shift # arg
dst_arg=$arg
done
fi
if test $# -eq 0; then
if test -z "$dir_arg"; then
echo "$0: no input file specified." >&2
exit 1
fi
# It's OK to call `install-sh -d' without argument.
# This can happen when creating conditional directories.
exit 0
fi
if test -z "$dir_arg"; then
do_exit='(exit $ret); exit $ret'
trap "ret=129; $do_exit" 1
trap "ret=130; $do_exit" 2
trap "ret=141; $do_exit" 13
trap "ret=143; $do_exit" 15
# Set umask so as not to create temps with too-generous modes.
# However, 'strip' requires both read and write access to temps.
case $mode in
# Optimize common cases.
*644) cp_umask=133;;
*755) cp_umask=22;;
*[0-7])
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw='% 200'
fi
cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
*)
if test -z "$stripcmd"; then
u_plus_rw=
else
u_plus_rw=,u+rw
fi
cp_umask=$mode$u_plus_rw;;
esac
fi
for src
do
# Protect names starting with `-'.
case $src in
-*) src=./$src;;
esac
if test -n "$dir_arg"; then
dst=$src
dstdir=$dst
test -d "$dstdir"
dstdir_status=$?
else
# Waiting for this to be detected by the "$cpprog $src $dsttmp" command
# might cause directories to be created, which would be especially bad
# if $src (and thus $dsttmp) contains '*'.
if test ! -f "$src" && test ! -d "$src"; then
echo "$0: $src does not exist." >&2
exit 1
fi
if test -z "$dst_arg"; then
echo "$0: no destination specified." >&2
exit 1
fi
dst=$dst_arg
# Protect names starting with `-'.
case $dst in
-*) dst=./$dst;;
esac
# If destination is a directory, append the input filename; won't work
# if double slashes aren't ignored.
if test -d "$dst"; then
if test -n "$no_target_directory"; then
echo "$0: $dst_arg: Is a directory" >&2
exit 1
fi
dstdir=$dst
dst=$dstdir/`basename "$src"`
dstdir_status=0
else
# Prefer dirname, but fall back on a substitute if dirname fails.
dstdir=`
(dirname "$dst") 2>/dev/null ||
expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
X"$dst" : 'X\(//\)[^/]' \| \
X"$dst" : 'X\(//\)$' \| \
X"$dst" : 'X\(/\)' \| . 2>/dev/null ||
echo X"$dst" |
sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
s//\1/
q
}
/^X\(\/\/\)[^/].*/{
s//\1/
q
}
/^X\(\/\/\)$/{
s//\1/
q
}
/^X\(\/\).*/{
s//\1/
q
}
s/.*/./; q'
`
test -d "$dstdir"
dstdir_status=$?
fi
fi
obsolete_mkdir_used=false
if test $dstdir_status != 0; then
case $posix_mkdir in
'')
# Create intermediate dirs using mode 755 as modified by the umask.
# This is like FreeBSD 'install' as of 1997-10-28.
umask=`umask`
case $stripcmd.$umask in
# Optimize common cases.
*[2367][2367]) mkdir_umask=$umask;;
.*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;
*[0-7])
mkdir_umask=`expr $umask + 22 \
- $umask % 100 % 40 + $umask % 20 \
- $umask % 10 % 4 + $umask % 2
`;;
*) mkdir_umask=$umask,go-w;;
esac
# With -d, create the new directory with the user-specified mode.
# Otherwise, rely on $mkdir_umask.
if test -n "$dir_arg"; then
mkdir_mode=-m$mode
else
mkdir_mode=
fi
posix_mkdir=false
case $umask in
*[123567][0-7][0-7])
# POSIX mkdir -p sets u+wx bits regardless of umask, which
# is incompatible with FreeBSD 'install' when (umask & 300) != 0.
;;
*)
tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0
if (umask $mkdir_umask &&
exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1
then
if test -z "$dir_arg" || {
# Check for POSIX incompatibilities with -m.
# HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
# other-writeable bit of parent directory when it shouldn't.
# FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
ls_ld_tmpdir=`ls -ld "$tmpdir"`
case $ls_ld_tmpdir in
d????-?r-*) different_mode=700;;
d????-?--*) different_mode=755;;
*) false;;
esac &&
$mkdirprog -m$different_mode -p -- "$tmpdir" && {
ls_ld_tmpdir_1=`ls -ld "$tmpdir"`
test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
}
}
then posix_mkdir=:
fi
rmdir "$tmpdir/d" "$tmpdir"
else
# Remove any dirs left behind by ancient mkdir implementations.
rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null
fi
trap '' 0;;
esac;;
esac
if
$posix_mkdir && (
umask $mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
)
then :
else
# The umask is ridiculous, or mkdir does not conform to POSIX,
# or it failed possibly due to a race condition. Create the
# directory the slow way, step by step, checking for races as we go.
case $dstdir in
/*) prefix='/';;
-*) prefix='./';;
*) prefix='';;
esac
eval "$initialize_posix_glob"
oIFS=$IFS
IFS=/
$posix_glob set -f
set fnord $dstdir
shift
$posix_glob set +f
IFS=$oIFS
prefixes=
for d
do
test -z "$d" && continue
prefix=$prefix$d
if test -d "$prefix"; then
prefixes=
else
if $posix_mkdir; then
(umask=$mkdir_umask &&
$doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
# Don't fail if two instances are running concurrently.
test -d "$prefix" || exit 1
else
case $prefix in
*\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
*) qprefix=$prefix;;
esac
prefixes="$prefixes '$qprefix'"
fi
fi
prefix=$prefix/
done
if test -n "$prefixes"; then
# Don't fail if two instances are running concurrently.
(umask $mkdir_umask &&
eval "\$doit_exec \$mkdirprog $prefixes") ||
test -d "$dstdir" || exit 1
obsolete_mkdir_used=true
fi
fi
fi
if test -n "$dir_arg"; then
{ test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
{ test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
else
# Make a couple of temp file names in the proper directory.
dsttmp=$dstdir/_inst.$$_
rmtmp=$dstdir/_rm.$$_
# Trap to clean up those temp files at exit.
trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
# Copy the file name to the temp name.
(umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") &&
# and set any options; do chmod last to preserve setuid bits.
#
# If any of these fail, we abort the whole thing. If we want to
# ignore errors from any of these, just make sure not to ignore
# errors from the above "$doit $cpprog $src $dsttmp" command.
#
{ test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } &&
{ test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } &&
{ test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } &&
{ test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
# If -C, don't bother to copy if it wouldn't change the file.
if $copy_on_change &&
old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` &&
new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` &&
eval "$initialize_posix_glob" &&
$posix_glob set -f &&
set X $old && old=:$2:$4:$5:$6 &&
set X $new && new=:$2:$4:$5:$6 &&
$posix_glob set +f &&
test "$old" = "$new" &&
$cmpprog "$dst" "$dsttmp" >/dev/null 2>&1
then
rm -f "$dsttmp"
else
# Rename the file to the real destination.
$doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null ||
# The rename failed, perhaps because mv can't rename something else
# to itself, or perhaps because mv is so ancient that it does not
# support -f.
{
# Now remove or move aside any old file at destination location.
# We try this two ways since rm can't unlink itself on some
# systems and the destination file might be busy for other
# reasons. In this case, the final cleanup might fail but the new
# file should still install successfully.
{
test ! -f "$dst" ||
$doit $rmcmd -f "$dst" 2>/dev/null ||
{ $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null &&
{ $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }
} ||
{ echo "$0: cannot unlink or rename $dst" >&2
(exit 1); exit 1
}
} &&
# Now rename the file to the real destination.
$doit $mvcmd "$dsttmp" "$dst"
}
fi || exit 1
trap '' 0
fi
done
# Local variables:
# eval: (add-hook 'write-file-hooks 'time-stamp)
# time-stamp-start: "scriptversion="
# time-stamp-format: "%:y-%02m-%02d.%02H"
# time-stamp-time-zone: "UTC"
# time-stamp-end: "; # UTC"
# End:

4033
pkgs/itcl4.2.0/tclconfig/tcl.m4 Normal file
View File

File diff suppressed because it is too large Load Diff

31
pkgs/itcl4.2.0/tests/all.tcl Normal file
View File

@@ -0,0 +1,31 @@
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests. Execute it by invoking "source all.test" when running tcltest
# in this directory.
#
# Copyright (c) 1998-2000 by Ajuba Solutions
# All rights reserved.
if {"-testdir" ni $argv} {
lappend argv -testdir [file dir [info script]]
}
if {[namespace which -command memory] ne "" && "-loadfile" ni $argv} {
puts "Tests running in sub-interpreters of leaktest circuit"
# -loadfile overwrites -load, so save it for helper in ::env(TESTFLAGS):
if {![info exists ::env(TESTFLAGS)] && [llength $argv]} {
set ::env(TESTFLAGS) $argv
}
lappend argv -loadfile [file join [file dirname [info script]] helpers.tcl]
}
package prefer latest
package require Tcl 8.6-
package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::runAllTests
return

597
pkgs/itcl4.2.0/tests/basic.test Normal file
View File

@@ -0,0 +1,597 @@
#
# Basic tests for class definition and method/proc access
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
test basic-1.0 {empty string as class name should fail but not crash
} -body {
list [catch {itcl::class "" {}} err] $err
} -result {1 {invalid class name ""}}
# ----------------------------------------------------------------------
# Simple class definition
# ----------------------------------------------------------------------
variable setup {
itcl::class Counter {
constructor {args} {
incr num
eval configure $args
}
destructor {
if {![info exists num]} {
lappend ::tcltest::itcl_basic_errors "unexpected: common deleted before destructor got called"
}
incr num -1
}
method ++ {} {
return [incr val $by]
}
proc num {} {
return $num
}
public variable by 1
protected variable val 0
private common num 0
}
}
variable cleanup {
itcl::delete class Counter
}
variable setup2 $setup
append setup2 {
set x [Counter x]
}
variable cleanup2 $cleanup
append cleanup2 {
unset x
}
variable setup3 $setup
append setup3 {
Counter -foo
}
variable setup4 $setup
append setup4 {
Counter c
}
proc check_itcl_basic_errors {} {
if {[info exists ::tcltest::itcl_basic_errors] && [llength $::tcltest::itcl_basic_errors]} {
error "following errors occurs during tests:\n [join $::tcltest::itcl_basic_errors "\n "]"
}
}
test basic-1.1 {define a simple class
} -setup $setup -body {
} -cleanup $cleanup -result {}
test basic-1.2 {class is now defined
} -setup $setup -body {
itcl::find classes Counter
} -cleanup $cleanup -result Counter
test basic-1.3 {access command exists with class name
} -setup $setup -body {
namespace which -command Counter
} -cleanup $cleanup -result ::Counter
test basic-1.4 {create a simple object
} -setup $setup2 -body {
return $x
} -cleanup $cleanup2 -result x
test basic-1.5a {object names cannot be duplicated
} -setup $setup2 -body {
list [catch "Counter x" msg] $msg
} -cleanup $cleanup2 -result {1 {command "x" already exists in namespace "::"}}
test basic-1.5b {built-in commands cannot be clobbered
} -setup $setup -body {
list [catch "Counter info" msg] $msg
} -cleanup $cleanup -result {1 {command "info" already exists in namespace "::"}}
test basic-1.6 {objects have an access command
} -setup $setup2 -body {
namespace which -command x
} -cleanup $cleanup2 -result ::x
test basic-1.7a {objects are added to the master list
} -setup $setup2 -body {
itcl::find objects x
} -cleanup $cleanup2 -result x
test basic-1.7b {objects are added to the master list
} -setup $setup2 -body {
itcl::find objects -class Counter x
} -cleanup $cleanup2 -result x
test basic-1.8 {objects can be deleted
} -setup $setup2 -body {
list [itcl::delete object x] [namespace which -command x]
} -cleanup $cleanup2 -result {{} {}}
test basic-1.9 {objects can be recreated with the same name
} -setup $setup2 -body {
itcl::delete object x
Counter x
} -cleanup $cleanup2 -result x
test basic-1.10 {objects can be destroyed by deleting their access command
} -setup $setup2 -body {
rename ::x {}
itcl::find objects x
} -cleanup $cleanup2 -result {}
test basic-1.11 {find command supports object names starting with -
} -setup $setup3 -body {
itcl::find objects -class Counter -foo
} -cleanup $cleanup -result -foo
test basic-1.12 {is command with class argument
} -setup $setup -body {
itcl::is class Counter
} -cleanup $cleanup -result 1
test basic-1.13 {is command with class argument (global namespace)
} -setup $setup -body {
itcl::is class ::Counter
} -cleanup $cleanup -result 1
test basic-1.14 {is command with class argument (wrapped in code command)
} -setup $setup -body {
itcl::is class [itcl::code Counter]
} -cleanup $cleanup -result 1
test basic-1.15 {is command with class argument (class does not exist)
} -body {
itcl::is class Count
} -result 0
test basic-1.16 {is command with object argument
} -setup $setup3 -body {
itcl::is object -foo
} -cleanup $cleanup -result 1
test basic-1.17 {is command with object argument (object does not exist)
} -body {
itcl::is object xxx
} -result 0
test basic-1.18 {is command with object argument (with code command)
} -setup $setup3 -body {
itcl::is object [itcl::code -- -foo]
} -cleanup $cleanup -result 1
test basic-1.19 {classes can be unicode
} -body {
itcl::class \u6210bcd { method foo args { return "bar" } }
\u6210bcd #auto
} -result "\u6210bcd0"
test basic-1.20 {
classes can be unicode
} -body {
\u6210bcd0 foo
} -cleanup {
::itcl::delete class \u6210bcd
} -result {bar}
# ----------------------------------------------------------------------
# #auto names
# ----------------------------------------------------------------------
test basic-2.1 {create an object with an automatic name
} -setup $setup -body {
Counter #auto
} -cleanup $cleanup -result {counter0}
test basic-2.2 {bury "#auto" within object name
} -setup $setup -body {
Counter x#autoy
} -cleanup $cleanup -result {xcounter0y}
test basic-2.3 {bury "#auto" within object name
} -setup $setup -body {
Counter a#aut#autob
} -cleanup $cleanup -result {a#autcounter0b}
test basic-2.4 {"#auto" is smart enough to skip names that are taken
} -setup $setup -body {
Counter counter3
Counter #auto
} -cleanup $cleanup -result {counter0}
test basic-2.5 {"#auto" with :: at front of name
} -body {
itcl::class AutoCheck {}
set result [AutoCheck ::#auto]
rename AutoCheck {}
set result
} -result {::autoCheck0}
test basic-2.6 {"#auto" with :: at front of name inside method
} -body {
itcl::class AutoCheck {
proc new {} {
return [AutoCheck ::#auto]
}
}
set result [AutoCheck::new]
rename AutoCheck {}
set result
} -result {::autoCheck0}
test basic-2.7 {"#auto" with :: at front of name inside method inside namespace
} -body {
namespace eval AutoCheckNs {}
itcl::class AutoCheckNs::AutoCheck {
proc new {} {
return [AutoCheckNs::AutoCheck ::#auto]
}
}
set result [AutoCheckNs::AutoCheck::new]
namespace delete AutoCheckNs
set result
} -cleanup {
namespace delete ::itcl::internal::variables::AutoCheckNs
} -result {::autoCheck0}
test basic-3.1 {object access command works
} -setup $setup4 -body {
list [c ++] [c ++] [c ++]
} -cleanup $cleanup -result {1 2 3}
test basic-3.2 {errors produce usage info
} -setup $setup4 -body {
list [catch "c xyzzy" msg] $msg
} -cleanup $cleanup -result {1 {bad option "xyzzy": should be one of...
c ++
c cget -option
c configure ?-option? ?value -option value...?
c isa className}}
test basic-3.3 {built-in configure can query public variables
} -setup $setup4 -body {
c configure
} -cleanup $cleanup -result {{-by 1 1}}
test basic-3.4 {built-in configure can query one public variable
} -setup $setup4 -body {
c configure -by
} -cleanup $cleanup -result {-by 1 1}
test basic-3.5 {built-in configure can set public variable
} -setup $setup4 -body {
list [c configure -by 2] [c cget -by]
} -cleanup $cleanup -result {{} 2}
test basic-3.6 {configure actually changes public variable
} -setup $setup4 -body {
list [c ++] [c ++]
} -cleanup $cleanup -result {1 2}
test basic-3.7 {class procs can be accessed
} -setup $setup -body {
Counter::num
} -cleanup $cleanup -result 0
test basic-3.8 {obsolete syntax is no longer allowed
} -setup $setup -body {
list [catch "Counter :: num" msg] $msg
} -cleanup $cleanup -result {1 {syntax "class :: proc" is an anachronism
[incr Tcl] no longer supports this syntax.
Instead, remove the spaces from your procedure invocations:
Counter::num ?args?}}
# ----------------------------------------------------------------------
# Classes can be destroyed and redefined
# ----------------------------------------------------------------------
test basic-4.1 {classes can be destroyed
} -setup $setup -body {
list [itcl::delete class Counter] \
[itcl::find classes Counter] \
[namespace children :: Counter] \
[namespace which -command Counter]
} -result {{} {} {} {}}
test basic-4.2 {classes can be redefined
} -body {
itcl::class Counter {
method ++ {} {
return [incr val $by]
}
public variable by 1
protected variable val 0
}
} -result {}
test basic-4.3 {the redefined class is actually different
} -body {
list [catch "Counter::num" msg] $msg
} -result {1 {invalid command name "Counter::num"}}
test basic-4.4 {objects can be created from the new class
} -body {
list [Counter #auto] [Counter #auto]
} -result {counter0 counter1}
test basic-4.5 {namespaces for #auto are prepended to the command name
} -body {
namespace eval someNS1 {}
namespace eval someNS2 {}
list [Counter someNS1::#auto] [Counter someNS2::#auto]
} -cleanup {
::itcl::delete object someNS1::counter2 someNS2::counter3
} -result "[list someNS1::counter2 someNS2::counter3]"
test basic-4.6 {when a class is destroyed, its objects are deleted
} -body {
list [lsort [itcl::find objects counter*]] \
[itcl::delete class Counter] \
[lsort [itcl::find objects counter*]]
} -result {{counter0 counter1} {} {}}
check_itcl_basic_errors
test basic-4.7 {clean-up of internal facilities
} -setup $setup4 -body {
# check callbacks are called if class gets removed using all possible ways:
# objects are properly destroyed,
# callback removing the namespace for the common private and protected variables
# (in ITCL_VARIABLES_NAMESPACE) is called, etc
set ::tcltest::itcl_basic_errors {}
set ivns ::itcl::internal::variables[namespace which Counter]
set result {}
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
eval $cleanup
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
eval $setup4
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
rename Counter {}
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
eval $setup4
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
namespace delete Counter
lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}]
lappend result {*}$::tcltest::itcl_basic_errors
} -cleanup {
unset -nocomplain ivns ::tcltest::itcl_basic_errors
} -result [lrepeat 3 1 1 0 0]
# ----------------------------------------------------------------------
# Namespace variables
# ----------------------------------------------------------------------
test basic-5.1 {define a simple class with variables in the namespace
} -body {
itcl::class test_globals {
common g1 "global1"
proc getval {name} {
variable $name
return [set [namespace tail $name]]
}
proc setval {name val} {
variable $name
return [set [namespace tail $name] $val]
}
method do {args} {
return [eval $args]
}
}
namespace eval test_globals {
variable g2 "global2"
}
} -result {}
test basic-5.2 {create an object for the tests
} -body {
test_globals #auto
} -result {test_globals0}
test basic-5.3 {common variables live in the namespace
} -body {
lsort [info vars ::test_globals::*]
} -result {::test_globals::g1 ::test_globals::g2}
test basic-5.4 {common variables can be referenced transparently
} -body {
list [catch {test_globals0 do set g1} msg] $msg
} -result {0 global1}
test basic-5.5 {namespace variables require a declaration
} -body {
list [catch {test_globals0 do set g2} msg] $msg
} -result {1 {can't read "g2": no such variable}}
test basic-5.6a {variable accesses variables within namespace
} -body {
list [catch {test_globals::getval g1} msg] $msg
} -result {0 global1}
test basic-5.6b {variable accesses variables within namespace
} -body {
list [catch {test_globals::getval g2} msg] $msg
} -result {0 global2}
test basic-5.7 {variable command will not find vars in other namespaces
} -body {
set ::test_global_0 "g0"
list [catch {test_globals::getval test_global_0} msg] $msg \
[catch {test_globals::getval ::test_global_0} msg] $msg \
} -result {1 {can't read "test_global_0": no such variable} 0 g0}
test basic-5.8 {to create globals in a namespace, use the full path
} -body {
test_globals::setval ::test_global_1 g1
namespace eval :: {lsort [info globals test_global_*]}
} -result {test_global_0 test_global_1}
test basic-5.9 {variable names can have ":" in them
} -body {
test_globals::setval ::test:global:2 g2
namespace eval :: {info globals test:global:2}
} -result {test:global:2}
if {[namespace which [namespace current]::test_globals] ne {}} {
::itcl::delete class test_globals
}
# ----------------------------------------------------------------------
# Array variables
# ----------------------------------------------------------------------
test basic-6.1 {set up a class definition with array variables
} -body {
proc test_arrays_get {name} {
upvar $name x
set rlist {}
foreach index [lsort [array names x]] {
lappend rlist [list $index $x($index)]
}
return $rlist
}
itcl::class test_arrays {
variable nums
common undefined
common colors
set colors(red) #ff0000
set colors(green) #00ff00
set colors(blue) #0000ff
constructor {} {
set nums(one) 1
set nums(two) 2
set nums(three) 3
set undefined(a) A
set undefined(b) B
}
method do {args} {
return [eval $args]
}
}
test_arrays #auto
} -result {test_arrays0}
test basic-6.2 {test array access for instance variables
} -body {
lsort [test_arrays0 do array get nums]
} -result {1 2 3 one three two}
test basic-6.3 {test array access for commons
} -body {
lsort [test_arrays0 do array get colors]
} -result [list #0000ff #00ff00 #ff0000 blue green red]
test basic-6.4 {test array access for instance variables via "upvar"
} -body {
test_arrays0 do test_arrays_get nums
} -result {{one 1} {three 3} {two 2}}
test basic-6.5 {test array access for commons via "upvar"
} -body {
test_arrays0 do test_arrays_get colors
} -result {{blue #0000ff} {green #00ff00} {red #ff0000}}
test basic-6.6a {test array access for commons defined in constructor
} -body {
lsort [test_arrays0 do array get undefined]
} -result {A B a b}
test basic-6.6b {test array access for commons defined in constructor
} -body {
test_arrays0 do test_arrays_get undefined
} -result {{a A} {b B}}
test basic-6.6c {test array access for commons defined in constructor
} -body {
list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)]
} -result {A B}
test basic-6.7 {common variables can be unset
} -body {
test_arrays0 do unset undefined
test_arrays0 do array names undefined
} -result {}
test basic-6.8 {common variables can be redefined
} -body {
test_arrays0 do set undefined "scalar"
} -result {scalar}
proc testVarResolver {{access private} {init 0}} {
eval [string map [list \$access $access \$init $init] {
itcl::class A {
$access common cv "A::cv"
public proc cv {} {set cv}
}
itcl::class B {
inherit A
public common res {}
lappend res [info exists cv]
if {$init} {
$access common cv ""
} else {
$access common cv
}
lappend res [info exists cv]
lappend cv "B::cv-add"
public proc cv {} {set cv}
}
lappend B::res [A::cv] [B::cv]
set B::res
}]
}
test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
# private uninitialized var:
testVarResolver private 0
} -result {0 0 A::cv B::cv-add} -cleanup {
itcl::delete class B A
}
test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
# public uninitialized var:
testVarResolver public 0
} -result {1 0 A::cv B::cv-add} -cleanup {
itcl::delete class B A
}
test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body {
# private initialized var:
testVarResolver private 1
} -result {0 1 A::cv B::cv-add} -cleanup {
itcl::delete class B A
}
test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body {
# public initialized var:
testVarResolver public 1
} -result {1 1 A::cv B::cv-add} -cleanup {
itcl::delete class B A
}
if {[namespace which test_arrays] ne {}} {
::itcl::delete class test_arrays
}
check_itcl_basic_errors
rename check_itcl_basic_errors {}
::tcltest::cleanupTests
return

259
pkgs/itcl4.2.0/tests/body.test Normal file
View File

@@ -0,0 +1,259 @@
#
# Tests for "body" and "configbody" commands
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Test "body" command
# ----------------------------------------------------------------------
test body-1.1 {define a class with missing bodies and arg lists} {
itcl::class test_body {
constructor {args} {}
destructor {}
method any
method zero {}
method one {x}
method two {x y}
method defvals {x {y 0} {z 1}}
method varargs {x args}
method override {mesg} {
return "override: $mesg"
}
}
} ""
test body-1.2 {cannot use methods without a body} {
test_body #auto
list [catch "test_body0 any" msg] $msg
} {1 {member function "::test_body::any" is not defined and cannot be autoloaded}}
test body-1.3 {check syntax of "body" command} {
list [catch "itcl::body test_body::any" msg] $msg
} {1 {wrong # args: should be "itcl::body class::func arglist body"}}
test body-1.4 {make sure members are found correctly} {
list [catch "itcl::body test_body::xyzzyxyzzyxyzzy {} {}" msg] $msg
} {1 {function "xyzzyxyzzyxyzzy" is not defined in class "::test_body"}}
test body-1.5a {members without an argument list can have any args} {
itcl::body test_body::any {} {return "any"}
list [catch "test_body0 any" msg] $msg
} {0 any}
test body-1.5b {members without an argument list can have any args} {
itcl::body test_body::any {x} {return "any: $x"}
list [catch "test_body0 any 1" msg] $msg
} {0 {any: 1}}
test body-1.5c {members without an argument list can have any args} {
itcl::body test_body::any {x {y 2}} {return "any: $x $y"}
list [catch "test_body0 any 1" msg] $msg
} {0 {any: 1 2}}
test body-1.6a {an empty argument list must stay empty} {
list [catch {itcl::body test_body::zero {x y} {return "zero: $x $y"}} msg] $msg
} {1 {argument list changed for function "::test_body::zero": should be ""}}
test body-1.6b {an empty argument list must stay empty} {
list [catch {itcl::body test_body::zero {} {return "zero"}} msg] $msg
} {0 {}}
test body-1.7a {preserve argument list: fixed arguments} {
list [catch {itcl::body test_body::one {x y} {return "one: $x $y"}} msg] $msg
} {1 {argument list changed for function "::test_body::one": should be "x"}}
test body-1.7b {preserve argument list: fixed arguments} {
list [catch {itcl::body test_body::one {a} {return "one: $a"}} msg] $msg
} {0 {}}
test body-1.7c {preserve argument list: fixed arguments} {
list [catch "test_body0 one 1.0" msg] $msg
} {0 {one: 1.0}}
test body-1.8a {preserve argument list: fixed arguments} {
list [catch {itcl::body test_body::two {x} {return "two: $x"}} msg] $msg
} {1 {argument list changed for function "::test_body::two": should be "x y"}}
test body-1.8b {preserve argument list: fixed arguments} {
list [catch {itcl::body test_body::two {a b} {return "two: $a $b"}} msg] $msg
} {0 {}}
test body-1.8c {preserve argument list: fixed arguments} {
list [catch "test_body0 two 2.0 3.0" msg] $msg
} {0 {two: 2.0 3.0}}
test body-1.9a {preserve argument list: default arguments} {
list [catch {itcl::body test_body::defvals {x} {}} msg] $msg
} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}}
test body-1.9b {preserve argument list: default arguments} {
list [catch {itcl::body test_body::defvals {a {b 0} {c 2}} {}} msg] $msg
} {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}}
test body-1.9c {preserve argument list: default arguments} {
list [catch {itcl::body test_body::defvals {a {b 0} {c 1}} {}} msg] $msg
} {0 {}}
test body-1.10a {preserve argument list: variable arguments} {
list [catch {itcl::body test_body::varargs {} {}} msg] $msg
} {1 {argument list changed for function "::test_body::varargs": should be "x args"}}
test body-1.10b {preserve argument list: variable arguments} {
list [catch {itcl::body test_body::varargs {a} {}} msg] $msg
} {0 {}}
test body-1.10c {preserve argument list: variable arguments} {
list [catch {itcl::body test_body::varargs {a b c} {}} msg] $msg
} {0 {}}
test body-1.11 {redefined body really does change} {
list [test_body0 override "test #1"] \
[itcl::body test_body::override {text} {return "new: $text"}] \
[test_body0 override "test #2"]
} {{override: test #1} {} {new: test #2}}
# ----------------------------------------------------------------------
# Test "body" command with inheritance
# ----------------------------------------------------------------------
test body-2.1 {inherit from a class with missing bodies} {
itcl::class test_ibody {
inherit test_body
method zero {}
}
test_ibody #auto
} {test_ibody0}
test body-2.2 {redefine a method in a derived class} {
itcl::body test_ibody::zero {} {return "ibody zero"}
list [test_ibody0 info function zero] \
[test_ibody0 info function test_body::zero]
} {{public method ::test_ibody::zero {} {return "ibody zero"}} {public method ::test_body::zero {} {return "zero"}}}
test body-2.3 {try to redefine a method that was not declared} {
list [catch {itcl::body test_ibody::one {x} {return "new"}} msg] $msg
} {1 {function "one" is not defined in class "::test_ibody"}}
::itcl::delete class test_body
# ----------------------------------------------------------------------
# Test "configbody" command
# ----------------------------------------------------------------------
test body-3.1 {define a class with public variables} {
itcl::class test_cbody {
private variable priv
protected variable prot
public variable option {} {
lappend messages "option: $option"
}
public variable nocode {}
public common messages
}
} ""
test body-3.2 {check syntax of "configbody" command} {
list [catch "itcl::configbody test_cbody::option" msg] $msg
} {1 {wrong # args: should be "itcl::configbody class::option body"}}
test body-3.3 {make sure that members are found correctly} {
list [catch "itcl::configbody test_cbody::xyzzy {}" msg] $msg
} {1 {option "xyzzy" is not defined in class "::test_cbody"}}
test body-3.4 {private variables have no config code} {
list [catch "itcl::configbody test_cbody::priv {bogus}" msg] $msg
} {1 {option "::test_cbody::priv" is not a public configuration option}}
test body-3.5 {protected variables have no config code} {
list [catch "itcl::configbody test_cbody::prot {bogus}" msg] $msg
} {1 {option "::test_cbody::prot" is not a public configuration option}}
test body-3.6 {can use public variables without a body} {
test_cbody #auto
list [catch "test_cbody0 configure -nocode 1" msg] $msg
} {0 {}}
test body-3.7 {redefined body really does change} {
list [test_cbody0 configure -option "hello"] \
[itcl::configbody test_cbody::option {lappend messages "new: $option"}] \
[test_cbody0 configure -option "goodbye"] \
[set test_cbody::messages] \
} {{} {} {} {{option: hello} {new: goodbye}}}
# ----------------------------------------------------------------------
# Test "configbody" command with inheritance
# ----------------------------------------------------------------------
test body-4.1 {inherit from a class with missing config bodies} {
itcl::class test_icbody {
inherit test_cbody
public variable option "icbody"
}
test_icbody #auto
} {test_icbody0}
test body-4.2 {redefine a body in a derived class} {
itcl::configbody test_icbody::option {lappend messages "test_icbody: $option"}
list [test_icbody0 info variable option] \
[test_icbody0 info variable test_cbody::option]
} {{public variable ::test_icbody::option icbody {lappend messages "test_icbody: $option"} icbody} {public variable ::test_cbody::option {} {lappend messages "new: $option"} {}}}
test body-4.3 {try to redefine a body for a variable that was not declared} {
list [catch {itcl::configbody test_icbody::nocode {return "new"}} msg] $msg
} {1 {option "nocode" is not defined in class "::test_icbody"}}
test body-5.1 {redefine constructors} -setup {
unset -nocomplain answer
itcl::class B {constructor {} {lappend ::answer B}}
itcl::class D {inherit B; constructor {} {lappend ::answer A}}
} -body {
D d1
itcl::body D::constructor {} {lappend ::answer D}
D d2
set ::answer
} -cleanup {
itcl::delete class B
unset -nocomplain answer
} -result {B A B D}
test body-6.1 {redefine class proc body} -setup {
unset -nocomplain ::answer
itcl::class C {
proc cheshire {} {
lappend ::answer x
itcl::body ::C::cheshire {} {}
}
constructor {args} {cheshire}
}
} -body {
itcl::delete object [C #auto]
itcl::delete object [C #auto]
itcl::delete object [C #auto]
set ::answer
} -cleanup {
itcl::delete class C
unset -nocomplain ::answer
} -result x
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class test_cbody
::tcltest::cleanupTests
return

166
pkgs/itcl4.2.0/tests/chain.test Normal file
View File

@@ -0,0 +1,166 @@
#
# Tests for chaining methods and procs
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Chaining methods and procs
# ----------------------------------------------------------------------
test chain-1.1 {define simple classes with inheritance} {
itcl::class test_chain_a {
constructor {args} {
#
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "a::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "a::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "a::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_b {
constructor {args} {
#
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "b::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "b::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "b::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_c {
inherit test_chain_a test_chain_b
constructor {args} {
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "c::constructor $args"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "c::tell $mesg"
chain $mesg
}
}
itcl::class test_chain_d {
inherit test_chain_c
constructor {args} {
eval chain $args
} {
global ::test_chain_status
lappend test_chain_status "d::constructor $args"
}
method show {mesg} {
chain $mesg
global ::test_chain_status
lappend test_chain_status "d::show $mesg"
}
proc tell {mesg} {
global ::test_chain_status
lappend test_chain_status "d::tell $mesg"
chain $mesg
}
}
} ""
test chain-1.2 {create a test object} {
set test_chain_status ""
set testobj [test_chain_d #auto 1 2 3]
set test_chain_status
} {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}}
test chain-1.3 {invoke a chained method} {
set test_chain_status ""
$testobj show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there} {d::show hello there}}
test chain-1.4 {invoke a chained method with a specific name} {
set test_chain_status ""
$testobj test_chain_d::show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there} {d::show hello there}}
test chain-1.5 {chained methods can cross multiple-inheritance branches} {
set test_chain_status ""
$testobj test_chain_a::show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there}}
test chain-1.6 {invoke a chained proc} {
set test_chain_status ""
test_chain_d::tell "testing 1 2 3"
set test_chain_status
} {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}}
test chain-1.7 {invoke a chained proc} {
set test_chain_status ""
test_chain_c::tell "testing 1 2 3"
set test_chain_status
} {{c::tell testing 1 2 3} {a::tell testing 1 2 3}}
test chain-2.1 {create a test object in a base class} {
set test_chain_status ""
set testobj [test_chain_c #auto 4 5 6]
set test_chain_status
} {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}}
test chain-2.2 {invoke a chained method} {
set test_chain_status ""
$testobj show "hello there"
set test_chain_status
} {{b::show hello there} {a::show hello there}}
test chain-3.0 {invoke "chain" outside of a class} {
list [catch {itcl::builtin::chain 1 2 3} err] $err
} {1 {cannot chain functions outside of a class context}}
test chain-4.0 {[35a5baca67]} -setup {
unset -nocomplain ::answer
itcl::class B {method act args {lappend ::answer B}}
itcl::class D {inherit B; method act args {lappend ::answer D; chain}}
} -body {
[D d] act Now!
set ::answer
} -cleanup {
itcl::delete class B
unset -nocomplain ::answer
} -result {D B}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a
::tcltest::cleanupTests
return

214
pkgs/itcl4.2.0/tests/delete.test Normal file
View File

@@ -0,0 +1,214 @@
#
# Tests for deleting classes and objects
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Deleting classes and objects
# ----------------------------------------------------------------------
test delete-1.1 {define a simple classes with inheritance} {
itcl::class test_delete_base {
variable num 0
method show {} {
return $num
}
}
} ""
test delete-1.2 {create some base class objects} {
for {set i 0} {$i < 5} {incr i} {
test_delete_base #auto
}
lsort [itcl::find objects -class test_delete_base]
} {test_delete_base0 test_delete_base1 test_delete_base2 test_delete_base3 test_delete_base4}
test delete-1.3 {delete the base class--class and all objects go away} {
list [itcl::delete class test_delete_base] \
[itcl::find classes test_delete_base] \
[namespace children :: test_delete_base] \
[namespace which -command test_delete_base] \
[itcl::find objects test_delete_base*]
} {{} {} {} {} {}}
# ----------------------------------------------------------------------
# Deleting classes and objects with inheritance
# ----------------------------------------------------------------------
test delete-2.1 {define a simple classes with inheritance} {
variable ::test_delete_watch ""
itcl::class test_delete_base {
variable num 0
method show {} {
return $num
}
destructor {
global ::test_delete_watch
lappend test_delete_watch $this
}
}
itcl::class test_delete {
inherit test_delete_base
method show {} {
return ">$num<"
}
}
} ""
test delete-2.2 {create some base and derived class objects} {
for {set i 0} {$i < 3} {incr i} {
test_delete_base #auto
}
for {set i 0} {$i < 3} {incr i} {
test_delete #auto
}
lsort [itcl::find objects -isa test_delete_base]
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
test delete-2.3 {delete the base class--class and all objects go away} {
list [itcl::delete class test_delete_base] \
[itcl::find classes test_delete*] \
[namespace children :: test_delete*] \
[namespace which -command test_delete_base] \
[namespace which -command test_delete] \
[itcl::find objects test_delete*]
} {{} {} {} {} {} {}}
test delete-2.4 {object destructors get invoked properly} {
lsort $test_delete_watch
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
# ----------------------------------------------------------------------
# Deleting class namespaces
# ----------------------------------------------------------------------
test delete-3.1 {redefine classes with inheritance} {
variable ::test_delete_watch ""
itcl::class test_delete_base {
variable num 0
method show {} {
return $num
}
destructor {
global test_delete_watch
lappend test_delete_watch $this
}
}
itcl::class test_delete {
inherit test_delete_base
method show {} {
return ">$num<"
}
}
} ""
test delete-3.2 {create some base and derived class objects} {
for {set i 0} {$i < 3} {incr i} {
test_delete_base #auto
}
for {set i 0} {$i < 3} {incr i} {
test_delete #auto
}
lsort [itcl::find objects -isa test_delete_base]
} {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2}
test delete-3.3 {deleting a class namespace is like deleting a class} {
list [namespace delete test_delete_base] \
[itcl::find classes test_delete*] \
[namespace children :: test_delete*] \
[namespace which -command test_delete_base] \
[namespace which -command test_delete] \
[itcl::find objects test_delete*]
} {{} {} {} {} {} {}}
test delete-3.4 {object destructors get invoked, even during catastrophe} {
lsort $test_delete_watch
} {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2}
# ----------------------------------------------------------------------
# Self-destructing objects
# ----------------------------------------------------------------------
test delete-4.1 {define a class where objects destroy themselves} {
itcl::class test_delete {
public variable x ""
public variable deletecommand ""
constructor {args} {
eval configure $args
}
destructor {
eval $deletecommand
}
method killme {code} {
itcl::delete object $this
eval $code
}
}
} {}
test delete-4.2 {an object can delete itself
} -body {
set obj [test_delete #auto -x "data stays"]
list [$obj killme {return $x}] [itcl::find objects -isa test_delete]
} -constraints {
only_working_in_itcl3.4
} -result {{data stays} {}}
test delete-4.3 {the "this" variable becomes null after delete} {
set obj [test_delete #auto]
list [$obj killme {return $this}] [itcl::find objects -isa test_delete]
} {{} {}}
test delete-4.4 {an object being destructed can't be deleted} {
set obj [test_delete #auto -deletecommand {itcl::delete object $this}]
list [catch {itcl::delete object $obj} msg] $msg
} {1 {can't delete an object while it is being destructed}}
if {[namespace which [namespace current]::test_delete] ne {}} {
namespace delete test_delete
}
# ----------------------------------------------------------------------
# Delete objects using path names and scoped values
# ----------------------------------------------------------------------
test delete-5.1 {define a simple class} {
itcl::class test_delete_name {
private variable x 0
method test {x} {
return $x
}
}
} {}
test delete-5.2 {delete using a qualified name} {
namespace eval test_delete2 {test_delete_name #auto}
set cmd {itcl::delete object test_delete2::test_delete_name0}
list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name]
} {0 {} {}}
test delete-5.3 {delete using a scoped value} {
set obj [namespace eval test_delete2 {itcl::code [test_delete_name #auto]}]
set cmd [list itcl::delete object $obj]
list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name]
} {0 {} {}}
test delete-5.4 {scoped command names are decoded properly} {
list [catch {itcl::delete object {namespace inscope ::xyzzy xxx}} msg] $msg \
[catch {itcl::delete object {namespace inscope :: xxx yyy}} msg] $msg \
[catch {itcl::delete object {namespace inscope :: xyzzy}} msg] $msg
} {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}}
namespace delete test_delete_name test_delete2
::tcltest::cleanupTests
return

319
pkgs/itcl4.2.0/tests/eclasscomponent.test Normal file
View File

@@ -0,0 +1,319 @@
#---------------------------------------------------------------------
# TITLE:
# eclasscomponent.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::extendedclass component command.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
#---------------------------------------------------------------------
loadTestedCommands
test component-1.1 {component defines variable} -body {
::itcl::extendedclass dog {
protected component mycomp
public proc test {} {
return $mycomp
}
}
dog fido
fido test
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {}
test component-1.2 {component -inherit} -body {
::itcl::extendedclass dog {
component mycomp -inherit
constructor {} {
set mycomp string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {3}
test component-1.3 {component -inherit can only have one of it} -body {
::itcl::extendedclass dogbase {
component mycompbase -inherit
}
::itcl::extendedclass dog {
inherit dogbase
component mycomp -inherit
constructor {} {
set mycomp string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete class dog
::itcl::delete class dogbase
} -returnCodes {
error
} -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"}
#-----------------------------------------------------------------------
# Typemethod delegation
test delegatemethod-1.1 {delegate method to non-existent component} -body {
set result ""
::itcl::extendedclass dog {
delegate method foo to bar
}
dog fido
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {::dog ::fido delegates method "foo" to undefined component "bar"}
test delegatemethod-1.2 {delegating to existing component} -body {
::itcl::extendedclass dog {
component string
delegate method length to string
constructor {} {
set string string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {3}
test delegatemethod-1.3 {delegating to existing component with error} -body {
::itcl::extendedclass dog {
# component string
delegate method length to string
constructor {} {
set string string
}
}
dog fido
fido length foo bar
} -cleanup {
::itcl::delete class dog
} -returnCodes {
error
} -result {wrong # args: should be "fido length string"}
test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body {
::itcl::extendedclass dog {
# component string
delegate method * to string
constructor {} {
set string string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {3}
test delegatemethod-1.6a {delegating unknown method to existing component with error} -body {
::itcl::extendedclass dog {
component stringhandler
delegate method * to stringhandler
constructor {} {
set stringhandler string
}
}
dog fido
fido foo bar
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -returnCodes {
error
} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
test delegatemethod-1.7 {can't delegate local method: order 1} -body {
::itcl::extendedclass dog {
component bar
method foo {} {}
delegate method foo to bar
}
} -returnCodes {
error
} -result {method "foo" has been defined locally}
test delegatemethod-1.8 {can't delegate local method: order 2} -body {
::itcl::extendedclass dog {
component bar
delegate method foo to bar
method foo {} {}
}
} -returnCodes {
error
} -result {method "foo" has been delegated}
test delegatemethod-1.9 {can't delegate local method: order 2} -body {
::itcl::extendedclass dog {
component bar
delegate method foo to bar
method foo {} {}
}
} -cleanup {
} -returnCodes {
error
} -result {method "foo" has been delegated}
# should be same as above
if {0} {
#-----------------------------------------------------------------------
# Typemethod delegation
test delegatemethod-1.1 {delegate method to non-existent component} -body {
set result ""
::itcl::extendedclass dog {
delegate method foo to bar
}
dog fido
} -returnCodes {
error
} -cleanup {
::itcl::delete class dog
} -result {::dog ::fido delegates method "foo" to undefined component "bar"}
test delegatemethod-1.2 {delegating to existing component} -body {
::itcl::extendedclass dog {
component string
delegate method length to string
constructor {} {
set string string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {3}
test delegatemethod-1.3 {delegating to existing component with error} -body {
::itcl::extendedclass dog {
# component string
delegate method length to string
constructor {} {
set string string
}
}
dog fido
fido length foo bar
} -cleanup {
::itcl::delete class dog
} -returnCodes {
error
} -result {wrong # args: should be "fido length string"}
test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body {
::itcl::extendedclass dog {
# component string
delegate method * to string
constructor {} {
set string string
}
}
dog fido
fido length foo
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -result {3}
test delegatemethod-1.6a {delegating unknown method to existing component with error} -body {
::itcl::extendedclass dog {
component stringhandler
delegate method * to stringhandler
constructor {} {
set stringhandler string
}
}
dog fido
fido foo bar
} -cleanup {
::itcl::delete object fido
::itcl::delete class dog
} -returnCodes {
error
} -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}
test delegatemethod-1.7 {can't delegate local method: order 1} -body {
::itcl::extendedclass dog {
component bar
method foo {} {}
delegate method foo to bar
}
} -cleanup {
} -returnCodes {
error
} -result {method "foo" has been defined locally}
test delegatemethod-1.8 {can't delegate local method: order 2} -body {
::itcl::extendedclass dog {
component bar
delegate method foo to bar
method foo {} {}
}
} -cleanup {
} -returnCodes {
error
} -result {method "foo" has been delegated}
# end
}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

225
pkgs/itcl4.2.0/tests/ensemble.test Normal file
View File

@@ -0,0 +1,225 @@
#
# Tests for the "ensemble" compound command facility
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
test ensemble-1.1 {ensemble name must be specified} {
list [catch {itcl::ensemble} msg] $msg
} {1 {wrong # args: should be "itcl::ensemble name ?command arg arg...?"}}
test ensemble-1.2 {creating a new ensemble} {
itcl::ensemble test_numbers {
part one {x} {
return "one: $x"
}
part two {x y} {
return "two: $x $y"
}
}
} ""
test ensemble-1.3 {adding to an existing ensemble} {
itcl::ensemble test_numbers part three {x y z} {
return "three: $x $y $z"
}
} ""
test ensemble-1.4 {invoking ensemble parts} {
list [test_numbers one 1] [test_numbers two 2 3] [test_numbers three 3 4 5]
} {{one: 1} {two: 2 3} {three: 3 4 5}}
test ensemble-1.5 {invoking parts with improper arguments} {
set res [catch "test_numbers three x" msg]
lappend res [string match "wrong # args*" $msg]
} {1 1}
test ensemble-1.6 {errors trigger a usage summary} {
list [catch "test_numbers foo x y" msg] $msg
} {1 {bad option "foo": should be one of...
test_numbers one x
test_numbers three x y z
test_numbers two x y}}
test ensemble-1.7 {one part can't overwrite another} {
set cmd {
itcl::ensemble test_numbers part three {} {
return "three: new version"
}
}
list [catch $cmd msg] $msg
} {1 {part "three" already exists in ensemble}}
test ensemble-1.8 {an ensemble can't overwrite another part} {
set cmd {
itcl::ensemble test_numbers ensemble three part new {} {
return "three: new version"
}
}
list [catch $cmd msg] $msg
} {1 {part "three" is not an ensemble}}
test ensemble-1.9 {body errors are handled gracefully} {
list [catch "itcl::ensemble test_numbers {foo bar baz}" msg] $msg $errorInfo
} {1 {invalid command name "foo"} {invalid command name "foo"
while executing
"foo bar baz"
("ensemble" body line 1)
invoked from within
"itcl::ensemble test_numbers {foo bar baz}"}}
test ensemble-1.10 {part errors are handled gracefully} {
list [catch "itcl::ensemble test_numbers {part foo}" msg] $msg $errorInfo
} {1 {wrong # args: should be "part name args body"} {wrong # args: should be "part name args body"
while executing
"part foo"
("ensemble" body line 1)
invoked from within
"itcl::ensemble test_numbers {part foo}"}}
test ensemble-1.11 {part argument errors are handled gracefully} {
list [catch "itcl::ensemble test_numbers {part foo {{}} {}}" msg] $msg $errorInfo
} {1 {procedure "foo" has argument with no name} {procedure "foo" has argument with no name
while executing
"part foo {{}} {}"
("ensemble" body line 1)
invoked from within
"itcl::ensemble test_numbers {part foo {{}} {}}"}}
test ensemble-2.0 {defining subensembles} {
itcl::ensemble test_numbers {
ensemble hex {
part base {} {
return 16
}
part digits {args} {
foreach num $args {
lappend result "0x$num"
}
return $result
}
}
ensemble octal {
part base {} {
return 8
}
part digits {{prefix 0} args} {
foreach num $args {
lappend result "$prefix$num"
}
return $result
}
}
}
list [catch "test_numbers foo" msg] $msg
} {1 {bad option "foo": should be one of...
test_numbers hex option ?arg arg ...?
test_numbers octal option ?arg arg ...?
test_numbers one x
test_numbers three x y z
test_numbers two x y}}
test ensemble-2.1 {invoking sub-ensemble parts} {
list [catch "test_numbers hex base" msg] $msg
} {0 16}
test ensemble-2.2 {invoking sub-ensemble parts} {
list [catch "test_numbers hex digits 3 a f" msg] $msg
} {0 {0x3 0xa 0xf}}
test ensemble-2.3 {errors from sub-ensembles} {
list [catch "test_numbers hex" msg] $msg
} {1 {wrong # args: should be "test_numbers hex subcommand ?arg ...?"}}
test ensemble-2.3a {errors from sub-ensembles
} -body {
list [catch "test_numbers hex" msg] $msg
} -constraints {
needs_frq_1773103
} -result {1 {wrong # args: should be one of...
test_numbers hex base
test_numbers hex digits ?arg arg ...?}}
test ensemble-2.4 {invoking sub-ensemble parts} {
list [catch "test_numbers octal base" msg] $msg
} {0 8}
test ensemble-2.5 {invoking sub-ensemble parts} {
list [catch "test_numbers octal digits 0o 3 5 10" msg] $msg
} {0 {0o3 0o5 0o10}}
test ensemble-2.6 {errors from sub-ensembles} {
list [catch "test_numbers octal" msg] $msg
} {1 {wrong # args: should be "test_numbers octal subcommand ?arg ...?"}}
test ensemble-2.6a {errors from sub-ensembles
} -body {
list [catch "test_numbers octal" msg] $msg
} -constraints {
needs_frq_1773103
} -result {1 {wrong # args: should be one of...
test_numbers octal base
test_numbers octal digits ?prefix? ?arg arg ...?}}
test ensemble-2.7 {sub-ensembles can't be accidentally redefined} {
set cmd {
itcl::ensemble test_numbers part octal {args} {
return "octal: $args"
}
}
list [catch $cmd msg] $msg
} {1 {part "octal" already exists in ensemble}}
test ensemble-3.0 {an error handler part can be used to handle errors} {
itcl::ensemble test_numbers {
part @error {args} {
return "error: $args"
}
}
list [catch {test_numbers foo 1 2 3} msg] $msg
} {0 {error: foo 1 2 3}}
test ensemble-3.1 {the error handler part shows up as generic "...and"} {
list [catch {test_numbers} msg] $msg
} {1 {wrong # args: should be "test_numbers subcommand ?arg ...?"}}
test ensemble-3.1a {the error handler part shows up as generic "...and"
} -body {
list [catch {test_numbers} msg] $msg
} -constraints {
needs_frq_1773103
} -result {1 {wrong # args: should be one of...
test_numbers hex option ?arg arg ...?
test_numbers octal option ?arg arg ...?
test_numbers one x
test_numbers three x y z
test_numbers two x y
...and others described on the man page}}
::itcl::delete ensemble test_numbers
test ensemble-4.0 {SF Bug 119} -setup {
itcl::ensemble foo part sub {} {error bar}
} -cleanup {
unset -nocomplain m o
rename foo {}
} -body {
catch {foo sub} m o
dict get $o -errorinfo
} -match glob -result {*itcl ensemble part*}
::tcltest::cleanupTests
return

237
pkgs/itcl4.2.0/tests/general1.test Normal file
View File

@@ -0,0 +1,237 @@
#
# Tests for general class handling
# ----------------------------------------------------------------------
# AUTHOR: Wolfgang Großer, Arnulf Wiedemann
# wolfgang@grosser-erding.de, arnulf@wiedemann-pri.de
# ----------------------------------------------------------------------
# Copyright (c) Wolfgang Großer, Arnulf Wiedemann
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Test protection with inheritance
# ----------------------------------------------------------------------
test general1-1.1 {define classes with different protection} {
variable ::test_cd_watch ""
itcl::class ClassA {
private variable priv privA
private variable privA privAA
protected variable prov provA
public variable pubv pubvA
constructor {args} {
lappend ::test_cd_watch constructorA
}
private method primA {} {
lappend ::test_cd_watch primA
set privA Hallo
lappend ::test_cd_watch [set priv]
}
protected method promA {} {
lappend ::test_cd_watch promA
lappend ::test_cd_watch [set prov]
}
public method pubmA {} {
lappend ::test_cd_watch pubmA
lappend ::test_cd_watch [set pubv]
}
public method doA {args} {eval $args}
}
itcl::class ClassB {
inherit ClassA
private variable priv privB
private variable privB privBB
protected variable prov provB
public variable pubv pubvB
constructor {args} {
lappend ::test_cd_watch [list constructorB $args]
}
destructor {
lappend ::test_cd_watch destructorB
}
private method primB {} {
lappend ::test_cd_watch primB
lappend ::test_cd_watch [set priv]
}
protected method promB {} {
lappend ::test_cd_watch promB
lappend ::test_cd_watch [set prov]
}
public method pubmB {} {
lappend ::test_cd_watch pubmB
lappend ::test_cd_watch [set pubv]
}
public method doB {args} {eval $args}
public method chkThis {} { set prov $this }
}
itcl::class ClassC {
inherit ClassB
private variable priv privC
protected variable prov provC
public variable pubv pubvC
constructor {args} {
eval ClassB::constructor $args
} {
lappend ::test_cd_watch [list "start constructorC" $args]
ClassA::constructor $args
lappend ::test_cd_watch [list "end constructorC"]
}
private method primC {} {
lappend ::test_cd_watch primC
lappend ::test_cd_watch [set priv]
}
protected method promC {} {
lappend ::test_cd_watch promC
lappend ::test_cd_watch [set prov]
}
public method pubmC {} {
lappend ::test_cd_watch pubmC
lappend ::test_cd_watch [set pubv]
$this primC
}
public method pubmC2 {arg1 {arg2 {}} {arg3 xxx}} {
lappend ::test_cd_watch "orig pubmC2"
}
public method doC {args} {
eval $args
}
}
} {}
test general1-1.2 {constructor of classA should be called twice} {
set ::test_cd_watch ""
list [ClassC #auto] [set ::test_cd_watch]
} {classC0 {constructorA {constructorB {}} {{start constructorC} {}} constructorA {{end constructorC}}}}
test general1-1.3 {body command should not produce error} {
set ::test_cd_watch ""
list [catch {
itcl::body ClassC::pubmC2 {aarg1 {aarg2 {}} {arg3 {xxx}}} {
lappend ::test_cd_watch "new body command for pubmC2 [list $aarg1 $aarg2 $arg3]"
}
} msg] $msg [classC0 pubmC2 Hallo]
} {0 {} {{new body command for pubmC2 Hallo {} xxx}}}
test general1-1.4 {call of configure} {
set ::test_cd_watch ""
list [lsort [classC0 configure]]
} {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC pubvC}}}
test general1-1.5 {call of configure with variable} {
set ::test_cd_watch ""
list [classC0 configure -pubv Arnulf]
} {{}}
test general1-1.6 {call of configure to check for changes} {
set ::test_cd_watch ""
list [lsort [classC0 configure]]
} {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC Arnulf}}}
test general1-1.7 {call of cget} {
set ::test_cd_watch ""
list [classC0 cget -pubv]
} {Arnulf}
test general1-1.8 {private method may not be called} {
set ::test_cd_watch ""
list [catch {classC0 primC} msg] $msg
} {1 {bad option "primC": should be one of...
classC0 cget -option
classC0 chkThis
classC0 configure ?-option? ?value -option value...?
classC0 doA ?arg arg ...?
classC0 doB ?arg arg ...?
classC0 doC ?arg arg ...?
classC0 isa className
classC0 pubmA
classC0 pubmB
classC0 pubmC
classC0 pubmC2 aarg1 ?aarg2? ?arg3?}}
test general1-1.9 {protected method may not be called} {
set ::test_cd_watch ""
list [catch {classC0 promC} msg] $msg
} {1 {bad option "promC": should be one of...
classC0 cget -option
classC0 chkThis
classC0 configure ?-option? ?value -option value...?
classC0 doA ?arg arg ...?
classC0 doB ?arg arg ...?
classC0 doC ?arg arg ...?
classC0 isa className
classC0 pubmA
classC0 pubmB
classC0 pubmC
classC0 pubmC2 aarg1 ?aarg2? ?arg3?}}
test general1-1.10 {can call private and protected methods from within the class} {
set ::test_cd_watch ""
list [catch {classC0 doC primC} msg] $msg [catch {classC0 doC promC} msg] $msg
} {0 {primC privC} 0 {primC privC promC provC}}
test general1-1.11 {*cannot* call private methods of inherited classes} {
set ::test_cd_watch ""
list [catch {classC0 doC primB} msg] $msg [catch {classC0 doC primA} msg] $msg
} {1 {invalid command name "primB"} 1 {invalid command name "primA"}}
test general1-1.12 {can call protected and public methods of inherited classes} {
set ::test_cd_watch ""
list [catch {classC0 doC promB} msg] $msg [catch {classC0 doC pubmC} msg] $msg [catch {classC0 doC promA} msg] $msg [catch {classC0 doC pubmA} msg] $msg
} {0 {promB provB} 0 {promB provB pubmC Arnulf primC privC} 0 {promB provB pubmC Arnulf primC privC promA provA} 0 {promB provB pubmC Arnulf primC privC promA provA pubmA pubvA}}
test general1-1.13 {"this" variable} {
set ::test_cd_watch ""
list [catch {classC0 doC doB set $this} msg] $msg
} {1 {can't read "this": no such variable}}
test general1-1.14 {can indirect calls through middle class} {
set ::test_cd_watch ""
list [catch {classC0 doC doB doA primA} msg] $msg [catch {classC0 doC doB doA promA} msg] $msg [catch {classC0 doC doB doA pubmA} msg] $msg
} {0 {primA privA} 0 {primA privA promA provA} 0 {primA privA promA provA pubmA pubvA}}
test general1-1.15 {*cannot* indirect private calls through middle class} {
set ::test_cd_watch ""
list [catch {classC0 doC doB primA} msg] $msg [catch {classC0 doC doB primC} msg] $msg
} {1 {invalid command name "primA"} 1 {invalid command name "primC"}}
test general1-1.16 {*cannot* indirect protected calls through middle class} {
set ::test_cd_watch ""
list [catch {classC0 doC doB promA} msg] $msg [catch {classC0 doC doB promC} msg] $msg
} {0 {promA provA} 1 {invalid command name "promC"}}
test general1-1.17 {access variables through calls through middle class} {
set ::test_cd_watch ""
list [catch {classC0 doC doB set privB} msg] $msg [catch {classC0 doC doB doA set pubv} msg] $msg
} {0 privBB 0 pubvA}
test general1-1.18 {"this" variable} {
set ::test_cd_watch ""
list [catch {classC0 doB set prov $this} msg] $msg \
[catch {classC0 chkThis} msg] $msg
} {1 {can't read "this": no such variable} 0 ::classC0}
test general1-1.20 {*cannot* read private variable from inherited class} {
set ::test_cd_watch ""
list [catch {classC0 doC set privA} msg] $msg [catch {classC0 doA set privA} msg] $msg [catch {classC0 doC set privB} msg] $msg [catch {classC0 doB set privB} msg] $msg
} {1 {can't read "privA": no such variable} 0 Hallo 1 {can't read "privB": no such variable} 0 privBB}
if {0} {
c publicC
}
::itcl::delete class ClassA
::tcltest::cleanupTests
return

48
pkgs/itcl4.2.0/tests/helpers.tcl Normal file
View File

@@ -0,0 +1,48 @@
# helpers.tcl --
#
# This file contains helper scripts for all tests, like a mem-leak checker, etc.
# -loadfile overwrites -load, so restore it from ::env(TESTFLAGS):
if {[info exists ::env(TESTFLAGS)]} {
array set testargs $::env(TESTFLAGS)
if {[info exists ::testargs(-load)]} {
eval $::testargs(-load)
}
unset testargs
}
package require itcl
if {[namespace which -command memory] ne "" && (
![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test
)
} {
proc getbytes {} {lindex [split [memory info] \n] 3 3}
proc leaktest {script {iterations 3}} {
set end [getbytes]
for {set i 0} {$i < $iterations} {incr i} {
uplevel 1 $script
set tmp $end
set end [getbytes]
}
return [expr {$end - $tmp}]
}
proc itcl_leaktest {testfile} {
set leak [leaktest [string map [list \
@test@ $testfile \
@testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}]
] {
interp create i
load {} Itcl i
i eval {set ::tcl::inl_mem_test 0}
i eval {package require tcltest; @testargv@}
i eval [list source @test@]
interp delete i
}]]
if {$leak} {
puts "LEAKED: $leak bytes"
}
}
itcl_leaktest [info script]
return -code return
}

183
pkgs/itcl4.2.0/tests/import.test Normal file
View File

@@ -0,0 +1,183 @@
#
# Tests for "auto_import" and autoloading facility
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
set ::itcllib [lindex [package ifneeded itcl [package require itcl]] 1]
# ----------------------------------------------------------------------
# Test "itcl::import::stub" command
# ----------------------------------------------------------------------
test import-1.1 {basic syntax for "stub" command} {
list [catch {itcl::import::stub} result] $result
} {1 {wrong # args: should be "itcl::import::stub subcommand ?arg ...?"}}
test import-1.1a {basic syntax for "stub" command
} -body {
list [catch {itcl::import::stub} result] $result
} -constraints {
needs_frq_1773103
} -result {1 {wrong # args: should be one of...
stub create name
stub exists name}}
test import-1.2 {"stub create" requires one argument} {
list [catch {itcl::import::stub create} result] $result \
[catch {itcl::import::stub create x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}}
test import-1.3 {"stub exists" requires one argument} {
list [catch {itcl::import::stub exists} result] $result \
[catch {itcl::import::stub exists x y} result] $result
} {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}}
set interp [interp create]
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval "
[list ::load $::itcllib itcl]
[::tcltest::configure -load]
proc auto_load {cmd {namespace {}}} {
global debug
proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
append debug \"(auto_load: \$cmd)\"
return 1
}
"
test import-1.4 {"stub create" creates a stub that triggers autoloading} {
$interp eval {
set debug ""
list [itcl::import::stub create foo::bar::test] \
[info commands ::foo::bar::test] \
[::foo::bar::test 1 2 3] \
$debug
}
} {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}}
test import-1.5 {"stub exists" recognizes stubs created by "stub create"} {
$interp eval {
set debug ""
itcl::import::stub create foo::bar::stub1
proc foo::bar::proc1 {{args {}}} {return "proc1: $args"}
list [itcl::import::stub exists foo::bar::stub1] \
[itcl::import::stub exists foo::bar::proc1]
}
} {1 0}
test import-1.6 {stubs can be autoloaded and replaced} {
$interp eval {
set debug ""
itcl::import::stub create foo::bar::stub2
list [itcl::import::stub exists foo::bar::stub2] \
[::foo::bar::stub2 a b c] \
[itcl::import::stub exists foo::bar::stub2] \
[::foo::bar::stub2 a b c] \
$debug
}
} {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}}
catch {interp delete $interp}
# ----------------------------------------------------------------------
# Test "itcl::import::stub" command
# ----------------------------------------------------------------------
set interp [interp create]
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval "
[list ::load $::itcllib itcl]
[::tcltest::configure -load]
proc auto_load {cmd {namespace {}}} {
proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\]
return 1
}
"
test import-2.1 {initialize some commands for autoloading} {
$interp eval {
namespace eval test {
namespace export foo*
}
itcl::import::stub create ::test::foo1
itcl::import::stub create ::test::foo2
lsort [info commands ::test::*]
}
} {::test::foo1 ::test::foo2}
test import-2.2 {stubs can be imported into other namespaces} {
$interp eval {
namespace eval user1 { namespace import ::test::* }
namespace eval user2 { namespace import ::test::* }
namespace eval user3 { namespace import ::test::* }
list [lsort [info commands ::user1::*]] \
[namespace origin ::user1::foo1] \
[namespace origin ::user1::foo2]
}
} {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2}
test import-2.3 {stubs can be autoloaded and imported links remain} {
$interp eval {
list [::user1::foo1 1 2 3 4] \
[namespace origin ::user1::foo1] \
[namespace origin ::user2::foo1] \
[namespace origin ::user3::foo1] \
[itcl::import::stub exists ::test::foo1]
}
} {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0}
test import-2.4 {itcl::class handles stubs correctly
} -body {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
list [::user2::foo2 x] \
[x info class] \
[namespace origin ::user1::foo2] \
[namespace origin ::user2::foo2] \
[namespace origin ::user3::foo2] \
[itcl::import::stub exists ::test::foo2]
}
} -constraints {
only_working_in_itcl3.4
} -result {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0}
test import-2.5 {itcl::class will overwrite stubs in an existing namespace} {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
namespace eval test::buried { }
itcl::import::stub create ::test::buried
itcl::import::stub create ::test::buried::stub
list [catch {::test::buried xx} result] $result [xx info class]
}
} {0 xx ::test::buried}
test import-2.6 {itcl::class will overwrite stubs} {
$interp eval {
proc auto_load {cmd {namespace {}}} {
itcl::class $cmd { }
return 1
}
itcl::import::stub create ::test::zonk
list [catch {::test::zonk yy} result] $result [yy info class]
}
} {0 yy ::test::zonk}
catch {interp delete $interp}
::tcltest::cleanupTests
return

425
pkgs/itcl4.2.0/tests/info.test Normal file
View File

@@ -0,0 +1,425 @@
#
# Tests for information accessed by the "info" command
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Class definition with one of everything
# ----------------------------------------------------------------------
test info-1.1 {define a simple class} {
itcl::class test_info_base {
method base {} {return "default"}
variable base {}
method do {args} {eval $args}
}
itcl::class test_info {
inherit test_info_base
constructor {args} {
foreach v [info variable] {
catch {set $v "new-[set $v]"}
}
}
destructor {}
method defm {} {return "default method"}
public method pubm {x} {return "public method"}
protected method prom {x y} {return "protected method"}
private method prim {x y z} {return "private method"}
proc defp {} {return "default proc"}
public proc pubp {x} {return "public proc"}
protected proc prop {x y} {return "protected proc"}
private proc prip {x y z} {return "private proc"}
variable defv "default"
public variable pubv "public" {set pubv "public: $pubv"}
protected variable prov "protected"
private variable priv "private"
common defc "default"
public common pubc "public"
protected common proc "protected"
private common pric "private"
method uninitm
proc uninitp {x y}
variable uninitv
common uninitc
set uninitc(0) zero
set uninitc(1) one
}
} ""
test info-1.2 {info: errors trigger usage info} {
list [catch {namespace eval test_info {info}} msg] $msg
} {1 {wrong # args: should be one of...
info args procname
info body procname
info class
info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body?
info heritage
info inherit
info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope?
...and others described on the man page}}
test info-1.3 {info: errors trigger usage info} {
test_info ti
list [catch {ti info} msg] $msg
} {1 {wrong # args: should be one of...
info args procname
info body procname
info class
info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body?
info heritage
info inherit
info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope?
...and others described on the man page}}
test info-1.4 {info: info class works on class itself} {
namespace eval test_info { info class }
} {::test_info}
# ----------------------------------------------------------------------
# Data members
# ----------------------------------------------------------------------
test info-2.1 {info: all variables} {
lsort [ti info variable]
} {::test_info::defc ::test_info::defv ::test_info::pric ::test_info::priv ::test_info::proc ::test_info::prov ::test_info::pubc ::test_info::pubv ::test_info::this ::test_info::uninitc ::test_info::uninitv ::test_info_base::base}
test info-2.2a {info: public variables} {
ti info variable pubv
} {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public}
test info-2.2b {info: public variables} -body {
list [ti info variable pubv -protection] \
[ti info variable pubv -type] \
[ti info variable pubv -name] \
[ti info variable pubv -init] \
[ti info variable pubv -config] \
[ti info variable pubv -value] \
[ti info variable pubv -scope] \
} -match glob -result {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public ::itcl::internal::variables::oo::Obj*::test_info::pubv}
test info-2.3a {info: protected variables} {
ti info variable prov
} {protected variable ::test_info::prov protected new-protected}
test info-2.3b {info: protected variables} -body {
list [ti info variable prov -protection] \
[ti info variable prov -type] \
[ti info variable prov -name] \
[ti info variable prov -init] \
[ti info variable prov -value] \
[ti info variable prov -scope] \
} -match glob -result {protected variable ::test_info::prov protected new-protected ::itcl::internal::variables::oo::Obj*::test_info::prov}
test info-2.4a {info: private variables} {
ti info variable priv
} {private variable ::test_info::priv private new-private}
test info-2.4b {info: private variables} -body {
list [ti info variable priv -protection] \
[ti info variable priv -type] \
[ti info variable priv -name] \
[ti info variable priv -init] \
[ti info variable priv -value] \
[ti info variable priv -scope] \
} -match glob -result {private variable ::test_info::priv private new-private ::itcl::internal::variables::oo::Obj*::test_info::priv}
test info-2.5 {"this" variable is built in} {
ti info variable this
} {protected variable ::test_info::this ::ti ::ti}
test info-2.6 {info: protected/private variables have no "config" code} {
list [ti info variable prov -config] [ti info variable priv -config]
} {{} {}}
test info-2.7 {by default, variables are "protected"} {
ti info variable defv
} {protected variable ::test_info::defv default new-default}
test info-2.8 {data members may be uninitialized} {
ti info variable uninitv
} {protected variable ::test_info::uninitv <undefined> <undefined>}
test info-2.9a {info: public common variables} {
ti info variable pubc
} {public common ::test_info::pubc public new-public}
test info-2.9b {info: public common variables} {
list [ti info variable pubc -protection] \
[ti info variable pubc -type] \
[ti info variable pubc -name] \
[ti info variable pubc -init] \
[ti info variable pubc -value] \
[ti info variable pubc -scope] \
} {public common ::test_info::pubc public new-public ::test_info::pubc}
test info-2.10a {info: protected common variables} {
ti info variable proc
} {protected common ::test_info::proc protected new-protected}
test info-2.10b {info: protected common variables} {
list [ti info variable proc -protection] \
[ti info variable proc -type] \
[ti info variable proc -name] \
[ti info variable proc -init] \
[ti info variable proc -value] \
[ti info variable proc -scope] \
} {protected common ::test_info::proc protected new-protected ::itcl::internal::variables::test_info::proc}
test info-2.11a {info: private common variables} {
ti info variable pric
} {private common ::test_info::pric private new-private}
test info-2.11b {info: private common variables} {
list [ti info variable pric -protection] \
[ti info variable pric -type] \
[ti info variable pric -name] \
[ti info variable pric -init] \
[ti info variable pric -value] \
[ti info variable pric -scope] \
} {private common ::test_info::pric private new-private ::itcl::internal::variables::test_info::pric}
test info-2.12 {info: public/protected/private vars have no "config" code} {
list [ti info variable pubc -config] \
[ti info variable proc -config] \
[ti info variable pric -config]
} {{} {} {}}
test info-2.13 {by default, variables are "protected"} {
ti info variable defc
} {protected common ::test_info::defc default new-default}
test info-2.14 {data members may be uninitialized} {
ti info variable uninitc
} {protected common ::test_info::uninitc <undefined> <undefined>}
test info-2.15 {common vars can be initialized within class definition} {
list [namespace eval test_info {lsort [array names uninitc]}] \
[namespace eval test_info {set uninitc(0)}] \
[namespace eval test_info {set uninitc(1)}]
} {{0 1} zero one}
test info-2.16 {flag syntax errors} {
list [catch {ti info variable defv -xyzzy} msg] $msg
} {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, -value, or -scope}}
# ----------------------------------------------------------------------
# Member functions
# ----------------------------------------------------------------------
test info-3.1 {info: all functions} {
lsort [ti info function]
} {::test_info::constructor ::test_info::defm ::test_info::defp ::test_info::destructor ::test_info::prim ::test_info::prip ::test_info::prom ::test_info::prop ::test_info::pubm ::test_info::pubp ::test_info::uninitm ::test_info::uninitp ::test_info_base::base ::test_info_base::cget ::test_info_base::configure ::test_info_base::do ::test_info_base::isa}
test info-3.2a {info: public methods} {
ti info function pubm
} {public method ::test_info::pubm x {return "public method"}}
test info-3.2b {info: public methods} {
list [ti info function pubm -protection] \
[ti info function pubm -type] \
[ti info function pubm -name] \
[ti info function pubm -args] \
[ti info function pubm -body]
} {public method ::test_info::pubm x {return "public method"}}
test info-3.3a {info: protected methods} {
ti info function prom
} {protected method ::test_info::prom {x y} {return "protected method"}}
test info-3.3b {info: protected methods} {
list [ti info function prom -protection] \
[ti info function prom -type] \
[ti info function prom -name] \
[ti info function prom -args] \
[ti info function prom -body]
} {protected method ::test_info::prom {x y} {return "protected method"}}
test info-3.4a {info: private methods} {
ti info function prim
} {private method ::test_info::prim {x y z} {return "private method"}}
test info-3.4b {info: private methods} {
list [ti info function prim -protection] \
[ti info function prim -type] \
[ti info function prim -name] \
[ti info function prim -args] \
[ti info function prim -body]
} {private method ::test_info::prim {x y z} {return "private method"}}
test info-3.5 {"configure" function is built in} {
ti info function configure
} {public method ::test_info_base::configure {?-option? ?value -option value...?} @itcl-builtin-configure}
test info-3.6 {by default, methods are "public"} {
ti info function defm
} {public method ::test_info::defm {} {return "default method"}}
test info-3.7 {methods may not have arg lists or bodies defined} {
ti info function uninitm
} {public method ::test_info::uninitm <undefined> <undefined>}
test info-3.8a {info: public procs} {
ti info function pubp
} {public proc ::test_info::pubp x {return "public proc"}}
test info-3.8b {info: public procs} {
list [ti info function pubp -protection] \
[ti info function pubp -type] \
[ti info function pubp -name] \
[ti info function pubp -args] \
[ti info function pubp -body]
} {public proc ::test_info::pubp x {return "public proc"}}
test info-3.9a {info: protected procs} {
ti info function prop
} {protected proc ::test_info::prop {x y} {return "protected proc"}}
test info-3.9b {info: protected procs} {
list [ti info function prop -protection] \
[ti info function prop -type] \
[ti info function prop -name] \
[ti info function prop -args] \
[ti info function prop -body]
} {protected proc ::test_info::prop {x y} {return "protected proc"}}
test info-3.10a {info: private procs} {
ti info function prip
} {private proc ::test_info::prip {x y z} {return "private proc"}}
test info-3.10b {info: private procs} {
list [ti info function prip -protection] \
[ti info function prip -type] \
[ti info function prip -name] \
[ti info function prip -args] \
[ti info function prip -body]
} {private proc ::test_info::prip {x y z} {return "private proc"}}
test info-3.11 {by default, procs are "public"} {
ti info function defp
} {public proc ::test_info::defp {} {return "default proc"}}
test info-3.12 {procs may not have arg lists or bodies defined} {
ti info function uninitp
} {public proc ::test_info::uninitp {x y} <undefined>}
test info-3.13 {flag syntax errors} {
list [catch {ti info function defm -xyzzy} msg] $msg
} {1 {bad option "-xyzzy": must be -args, -body, -name, -protection, or -type}}
# ----------------------------------------------------------------------
# Other object-related queries
# ----------------------------------------------------------------------
test info-4.1a {query class (wrong # args)} {
list [catch {ti info class x} result] $result
} {1 {wrong # args: should be "info class"}}
test info-4.1b {query most-specific class} {
list [ti info class] [ti do info class]
} {::test_info ::test_info}
test info-4.2a {query inheritance info (wrong # args)} {
list [catch {ti info inherit x} result] $result
} {1 {wrong # args: should be "info inherit"}}
test info-4.2b {query inheritance info} {
list [ti info inherit] [ti do info inherit]
} {::test_info_base {}}
test info-4.2c {query inheritance info} {
ti do ti info inherit
} {::test_info_base}
test info-4.3a {query heritage info (wrong # args)} {
list [catch {ti info heritage x} result] $result
} {1 {wrong # args: should be "info heritage"}}
test info-4.3b {query heritage info} {
list [ti info heritage] [ti do info heritage]
} {{::test_info ::test_info_base} ::test_info_base}
test info-4.3c {query heritage info} {
ti do ti info heritage
} {::test_info ::test_info_base}
test info-4.4a {query argument list (wrong # args)} {
list [catch {ti info args} result] $result \
[catch {ti info args x y} result] $result
} {1 {wrong # args: should be "info args function"} 1 {wrong # args: should be "info args function"}}
test info-4.4b {query argument list} {
ti info args prim
} {x y z}
test info-4.4c {query argument list (undefined)} {
ti info args uninitm
} {<undefined>}
test info-4.4d {query argument list of real proc} {
ti info args ::unknown
} {args}
test info-4.4e {query argument list of real proc} {
itcl::builtin::Info args ::unknown
} {args}
test info-4.5a {query body (wrong # args)} {
list [catch {ti info body} result] $result \
[catch {ti info body x y} result] $result
} {1 {wrong # args: should be "info body function"} 1 {wrong # args: should be "info body function"}}
test info-4.5b {query body} {
ti info body prim
} {return "private method"}
test info-4.5c {query body (undefined)} {
ti info body uninitm
} {<undefined>}
# ----------------------------------------------------------------------
# Other parts of the usual "info" command
# ----------------------------------------------------------------------
test info-5.1 {info vars} {
ti do info vars
} {args}
test info-5.2 {info exists} {
list [ti do info exists args] [ti do info exists xyzzy]
} {1 0}
test info-6.0 {Bug a03f579f7d} -setup {
# Must not segfault
itcl::class C {
proc p {} {info vars}
}
} -body {
C::p
} -cleanup {
itcl::delete class C
} -result {}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class test_info test_info_base
::tcltest::cleanupTests
return

591
pkgs/itcl4.2.0/tests/inherit.test Normal file
View File

@@ -0,0 +1,591 @@
#
# Tests for inheritance and scope handling
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Test construction/destruction with inheritance
# ----------------------------------------------------------------------
test inherit-1.1 {define classes with constructors/destructors} {
variable ::test_cd_watch ""
itcl::class test_cd_foo {
constructor {x y} {
global ::test_cd_watch
lappend test_cd_watch "foo: $x $y"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "foo destruct"
}
}
itcl::class test_cd_bar {
constructor {args} {
global ::test_cd_watch
lappend test_cd_watch "bar: $args"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "bar destruct"
}
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
constructor {x y args} {
test_cd_foo::constructor $x $y
} {
global ::test_cd_watch
lappend test_cd_watch "foobar: $x $y ($args)"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "foobar destruct"
}
}
itcl::class test_cd_geek {
constructor {} {
global ::test_cd_watch
lappend test_cd_watch "geek"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "geek destruct"
}
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
constructor {x} {
eval test_cd_foobar::constructor 1 2 fred $x
} {
global ::test_cd_watch
lappend test_cd_watch "mongrel: $x"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "mongrel destruct"
}
}
itcl::class test_cd_none {
inherit test_cd_bar test_cd_geek
}
itcl::class test_cd_skip {
inherit test_cd_none
constructor {} {
global ::test_cd_watch
lappend test_cd_watch "skip"
}
destructor {
global ::test_cd_watch
lappend test_cd_watch "skip destruct"
}
}
} {}
test inherit-1.2 {constructors should be invoked in the proper order} {
set ::test_cd_watch ""
list [test_cd_mongrel #auto bob] [set ::test_cd_watch]
} {test_cd_mongrel0 {{foo: 1 2} {bar: } {foobar: 1 2 (fred bob)} geek {mongrel: bob}}}
test inherit-1.3 {destructors should be invoked in the proper order} {
set ::test_cd_watch ""
list [itcl::delete object test_cd_mongrel0] [set ::test_cd_watch]
} {{} {{mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}}
test inherit-1.4 {constructors are optional} {
set ::test_cd_watch ""
list [test_cd_none #auto] [set ::test_cd_watch]
} {test_cd_none0 {geek {bar: }}}
test inherit-1.5 {destructors are optional} {
set ::test_cd_watch ""
list [itcl::delete object test_cd_none0] [set ::test_cd_watch]
} {{} {{bar destruct} {geek destruct}}}
test inherit-1.6 {construction ok if constructors are missing} {
set ::test_cd_watch ""
list [test_cd_skip #auto] [set ::test_cd_watch]
} {test_cd_skip0 {geek {bar: } skip}}
test inherit-1.7 {destruction ok if destructors are missing} {
set ::test_cd_watch ""
list [itcl::delete object test_cd_skip0] [set ::test_cd_watch]
} {{} {{skip destruct} {bar destruct} {geek destruct}}}
test inherit-1.8 {errors during construction are cleaned up and reported} knownBug {
global errorInfo test_cd_watch
set test_cd_watch ""
itcl::body test_cd_bar::constructor {args} {error "bar: failed"}
list [catch {test_cd_mongrel #auto bob} msg] $msg \
$errorInfo $test_cd_watch
} {1 {bar: failed} {bar: failed
while executing
"error "bar: failed""
while constructing object "::test_cd_mongrel1" in ::test_cd_bar::constructor (body line 1)
while constructing object "::test_cd_mongrel1" in ::test_cd_foobar::constructor (body line 1)
invoked from within
"test_cd_foobar::constructor 1 2 fred bob"
("eval" body line 1)
invoked from within
"eval test_cd_foobar::constructor 1 2 fred $x"
while constructing object "::test_cd_mongrel1" in ::test_cd_mongrel::constructor (body line 2)
invoked from within
"::itcl::parser::handleClass test_cd_mongrel ::test_cd_mongrel #auto bob"
invoked from within
"test_cd_mongrel #auto bob"} {{foo: 1 2} {mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}}
test inherit-1.9 {errors during destruction prevent object delete} {
global errorInfo test_cd_watch
itcl::body test_cd_bar::constructor {args} {return "bar: $args"}
itcl::body test_cd_bar::destructor {} {error "bar: failed"}
test_cd_mongrel mongrel1 ted
set test_cd_watch ""
list [catch {itcl::delete object mongrel1} msg] $msg \
$errorInfo $test_cd_watch [itcl::find objects mongrel*]
} {1 {bar: failed} {bar: failed
while executing
"error "bar: failed""
while deleting object "::mongrel1" in ::test_cd_bar::destructor (body line 1)
invoked from within
"itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1}
test inherit-1.10 {errors during destruction prevent class delete} {
itcl::body test_cd_bar::destructor {} {error "bar: failed"}
test_cd_mongrel mongrel2 xxx
list [catch {itcl::delete class test_cd_foo} msg] $msg
} {1 {bar: failed}}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test data member access and scoping
# ----------------------------------------------------------------------
test inherit-2.1 {define classes with data members} {
itcl::class test_cd_foo {
protected variable x "foo-x"
method do {args} {eval $args}
}
itcl::class test_cd_bar {
protected variable x "bar-x"
method do {args} {eval $args}
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
method do {args} {eval $args}
}
itcl::class test_cd_geek {
method do {args} {eval $args}
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
protected variable x "mongrel-x"
method do {args} {eval $args}
}
} {}
test inherit-2.2 {"info" provides access to shadowed data members} {
test_cd_mongrel #auto
list [lsort [test_cd_mongrel0 info variable]] \
[test_cd_mongrel0 info variable test_cd_foo::x] \
[test_cd_mongrel0 info variable test_cd_bar::x] \
[test_cd_mongrel0 info variable test_cd_mongrel::x] \
[test_cd_mongrel0 info variable x]
} {{::test_cd_bar::x ::test_cd_foo::x ::test_cd_mongrel::this ::test_cd_mongrel::x} {protected variable ::test_cd_foo::x foo-x foo-x} {protected variable ::test_cd_bar::x bar-x bar-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x}}
test inherit-2.3 {variable resolution works properly in methods} {
list [test_cd_mongrel0 test_cd_foo::do set x] \
[test_cd_mongrel0 test_cd_bar::do set x] \
[test_cd_mongrel0 test_cd_foobar::do set x] \
[test_cd_mongrel0 test_cd_mongrel::do set x]
} {foo-x bar-x foo-x mongrel-x}
test inherit-2.4 {methods have access to shadowed data members} {
list [test_cd_mongrel0 test_cd_foobar::do set x] \
[test_cd_mongrel0 test_cd_foobar::do set test_cd_foo::x] \
[test_cd_mongrel0 test_cd_foobar::do set test_cd_bar::x] \
[test_cd_mongrel0 test_cd_mongrel::do set test_cd_foo::x] \
[test_cd_mongrel0 test_cd_mongrel::do set test_cd_bar::x]
} {foo-x foo-x bar-x foo-x bar-x}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test public variables and "configure" method
# ----------------------------------------------------------------------
test inherit-3.1 {define classes with public variables} {
variable ::test_cd_watch ""
itcl::class test_cd_foo {
public variable x "foo-x" {
global test_cd_watch
lappend test_cd_watch "foo: $x in scope [namespace current]"
}
method do {args} {eval $args}
}
itcl::class test_cd_bar {
public variable x "bar-x" {
global test_cd_watch
lappend test_cd_watch "bar: $x in scope [namespace current]"
}
method do {args} {eval $args}
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
method do {args} {eval $args}
}
itcl::class test_cd_geek {
method do {args} {eval $args}
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
public variable x "mongrel-x" {
global test_cd_watch
lappend test_cd_watch "mongrel: $x in scope [namespace current]"
}
method do {args} {eval $args}
}
} {}
test inherit-3.2 {create an object with public variables} {
test_cd_mongrel #auto
} {test_cd_mongrel0}
test inherit-3.3 {"configure" lists all public variables} {
lsort [test_cd_mongrel0 configure]
} {{-test_cd_bar::x bar-x bar-x} {-test_cd_foo::x foo-x foo-x} {-x mongrel-x mongrel-x}}
test inherit-3.4 {"configure" treats simple names as "most specific"} {
lsort [test_cd_mongrel0 configure -x]
} {-x mongrel-x mongrel-x}
test inherit-3.5 {"configure" treats simple names as "most specific"} {
set ::test_cd_watch ""
list [test_cd_mongrel0 configure -x hello] \
[set ::test_cd_watch]
} {{} {{mongrel: hello in scope ::test_cd_mongrel}}}
test inherit-3.6 {"configure" allows access to shadowed options} {
set ::test_cd_watch ""
list [test_cd_mongrel0 configure -test_cd_foo::x hello] \
[test_cd_mongrel0 configure -test_cd_bar::x there] \
[set ::test_cd_watch]
} {{} {} {{foo: hello in scope ::test_cd_foo} {bar: there in scope ::test_cd_bar}}}
test inherit-3.7 {"configure" will change several variables at once} {
set ::test_cd_watch ""
list [test_cd_mongrel0 configure -x one \
-test_cd_foo::x two \
-test_cd_bar::x three] \
[set ::test_cd_watch]
} {{} {{mongrel: one in scope ::test_cd_mongrel} {foo: two in scope ::test_cd_foo} {bar: three in scope ::test_cd_bar}}}
test inherit-3.8 {"cget" does proper name resolution} {
list [test_cd_mongrel0 cget -x] \
[test_cd_mongrel0 cget -test_cd_foo::x] \
[test_cd_mongrel0 cget -test_cd_bar::x] \
[test_cd_mongrel0 cget -test_cd_mongrel::x]
} {one two three one}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test inheritance info
# ----------------------------------------------------------------------
test inherit-4.1 {define classes for inheritance info} {
itcl::class test_cd_foo {
method do {args} {eval $args}
}
itcl::class test_cd_bar {
method do {args} {eval $args}
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
method do {args} {eval $args}
}
itcl::class test_cd_geek {
method do {args} {eval $args}
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
method do {args} {eval $args}
}
} {}
test inherit-4.2 {create an object for inheritance tests} {
test_cd_mongrel #auto
} {test_cd_mongrel0}
test inherit-4.3 {"info class" should be virtual} {
list [test_cd_mongrel0 info class] \
[test_cd_mongrel0 test_cd_foo::do info class] \
[test_cd_mongrel0 test_cd_geek::do info class]
} {::test_cd_mongrel ::test_cd_mongrel ::test_cd_mongrel}
test inherit-4.4 {"info inherit" depends on class scope} {
list [test_cd_mongrel0 info inherit] \
[test_cd_mongrel0 test_cd_foo::do info inherit] \
[test_cd_mongrel0 test_cd_foobar::do info inherit]
} {{::test_cd_foobar ::test_cd_geek} {} {::test_cd_foo ::test_cd_bar}}
test inherit-4.5 {"info heritage" depends on class scope} {
list [test_cd_mongrel0 info heritage] \
[test_cd_mongrel0 test_cd_foo::do info heritage] \
[test_cd_mongrel0 test_cd_foobar::do info heritage]
} {{::test_cd_mongrel ::test_cd_foobar ::test_cd_foo ::test_cd_bar ::test_cd_geek} ::test_cd_foo {::test_cd_foobar ::test_cd_foo ::test_cd_bar}}
test inherit-4.6 {built-in "isa" method works} {
set status ""
foreach c [test_cd_mongrel0 info heritage] {
lappend status [test_cd_mongrel0 isa $c]
}
set status
} {1 1 1 1 1}
test inherit-4.7 {built-in "isa" method works within methods} {
set status ""
foreach c [test_cd_mongrel0 info heritage] {
lappend status [test_cd_mongrel0 test_cd_foo::do isa $c]
}
set status
} {1 1 1 1 1}
test inherit-4.8 {built-in "isa" method recognizes bad classes} {
itcl::class test_cd_other {}
test_cd_mongrel0 isa test_cd_other
} {0}
test inherit-4.9 {built-in "isa" method recognizes bad classes} {
list [catch {test_cd_mongrel0 isa test_cd_bogus} msg] $msg
} {1 {class "test_cd_bogus" not found in context "::test_cd_foo"}}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test "find objects"
# ----------------------------------------------------------------------
test inherit-5.1 {define classes for inheritance info} {
itcl::class test_cd_foo {
}
itcl::class test_cd_bar {
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
}
itcl::class test_cd_geek {
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
}
} {}
test inherit-5.2 {create objects for info tests} {
list [test_cd_foo #auto] [test_cd_foo #auto] \
[test_cd_foobar #auto] \
[test_cd_geek #auto] \
[test_cd_mongrel #auto]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_geek0 test_cd_mongrel0}
test inherit-5.3 {find objects: -class qualifier} {
lsort [itcl::find objects -class test_cd_foo]
} {test_cd_foo0 test_cd_foo1}
test inherit-5.4 {find objects: -class qualifier} {
lsort [itcl::find objects -class test_cd_mongrel]
} {test_cd_mongrel0}
test inherit-5.5 {find objects: -isa qualifier} {
lsort [itcl::find objects -isa test_cd_foo]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_mongrel0}
test inherit-5.6 {find objects: -isa qualifier} {
lsort [itcl::find objects -isa test_cd_mongrel]
} {test_cd_mongrel0}
test inherit-5.7 {find objects: name qualifier} {
lsort [itcl::find objects test_cd_foo*]
} {test_cd_foo0 test_cd_foo1 test_cd_foobar0}
test inherit-5.8 {find objects: -class and -isa qualifiers} {
lsort [itcl::find objects -isa test_cd_foo -class test_cd_foobar]
} {test_cd_foobar0}
test inherit-5.9 {find objects: -isa and name qualifiers} {
lsort [itcl::find objects -isa test_cd_foo *0]
} {test_cd_foo0 test_cd_foobar0 test_cd_mongrel0}
test inherit-5.10 {find objects: usage errors} {
list [catch {itcl::find objects -xyzzy value} msg] $msg
} {1 {wrong # args: should be "itcl::find objects ?-class className? ?-isa className? ?pattern?"}}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test method scoping and execution
# ----------------------------------------------------------------------
test inherit-6.1 {define classes for scope tests} {
itcl::class test_cd_foo {
method check {} {return "foo"}
method do {args} {return "foo says: [eval $args]"}
}
itcl::class test_cd_bar {
method check {} {return "bar"}
method do {args} {return "bar says: [eval $args]"}
}
itcl::class test_cd_foobar {
inherit test_cd_foo test_cd_bar
method check {} {return "foobar"}
method do {args} {return "foobar says: [eval $args]"}
}
itcl::class test_cd_geek {
method check {} {return "geek"}
method do {args} {return "geek says: [eval $args]"}
}
itcl::class test_cd_mongrel {
inherit test_cd_foobar test_cd_geek
method check {} {return "mongrel"}
method do {args} {return "mongrel says: [eval $args]"}
}
} {}
test inherit-6.2 {create objects for scoping tests} {
list [test_cd_mongrel #auto] [test_cd_foobar #auto]
} {test_cd_mongrel0 test_cd_foobar0}
test inherit-6.3 {methods are "virtual" outside of the class} {
test_cd_mongrel0 check
} {mongrel}
test inherit-6.4 {specific methods can be accessed by name} {
test_cd_mongrel0 test_cd_foo::check
} {foo}
test inherit-6.5 {methods are "virtual" within a class too} {
test_cd_mongrel0 test_cd_foobar::do check
} {foobar says: mongrel}
test inherit-6.6 {methods are executed where they were defined} {
list [test_cd_mongrel0 test_cd_foo::do namespace current] \
[test_cd_mongrel0 test_cd_foobar::do namespace current] \
[test_cd_mongrel0 do namespace current] \
} {{foo says: ::test_cd_foo} {foobar says: ::test_cd_foobar} {mongrel says: ::test_cd_mongrel}}
test inherit-6.7 {"virtual" command no longer exists} {
list [catch {
test_cd_mongrel0 test_cd_foobar::do virtual namespace current
} msg] $msg
} {1 {invalid command name "virtual"}}
test inherit-6.8 {"previous" command no longer exists} {
list [catch {
test_cd_mongrel0 test_cd_foobar::do previous check
} msg] $msg
} {1 {invalid command name "previous"}}
test inherit-6.9 {errors are detected and reported across class boundaries} {
#
# NOTE: For tcl8.2.3 and earlier the stack trace will have
# 'invoked from within "eval $args"' for the first eval
# statement. For later versions, it does not. Use
# string match to reduce the sensitivity to that.
#
list [catch {
test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error"
} msg] $msg [string match {some error
("eval" body line 1)*
(object "::test_cd_foobar0" method "::test_cd_foobar::do" body line 1)
invoked from within
"test_cd_foobar0 do error test {some error}"
("eval" body line 1)
invoked from within
"eval $args"
(object "::test_cd_mongrel0" method "::test_cd_mongrel::do" body line 1)
invoked from within
"test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error""} [set ::errorInfo]]
} {1 test 1}
test inherit-6.10 {errors codes are preserved across class boundaries} {
list [catch {
test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" CODE-BLUE
} msg] $msg [set ::errorCode]
} {1 test CODE-BLUE}
test inherit-6.11 {multi-value error codes are preserved across class boundaries} {
list [catch {
test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" "CODE BLUE 123"
} msg] $msg [set ::errorCode]
} {1 test {CODE BLUE 123}}
eval namespace delete [itcl::find classes test_cd_*]
# ----------------------------------------------------------------------
# Test inheritance errors
# ----------------------------------------------------------------------
test inherit-7.1 {cannot inherit from non-existant class} {
list [catch {
itcl::class bogus {
inherit non_existant_class_xyzzy
}
} msg] $msg
} {1 {cannot inherit from "non_existant_class_xyzzy" (class "non_existant_class_xyzzy" not found in context "::")}}
test inherit-7.2 {cannot inherit from procs} {
proc inherit_test_proc {x y} {
error "never call this"
}
list [catch {
itcl::class bogus {
inherit inherit_test_proc
}
} msg] $msg
} {1 {cannot inherit from "inherit_test_proc" (class "inherit_test_proc" not found in context "::")}}
test inherit-7.3 {cannot inherit from yourself} {
list [catch {
itcl::class bogus {
inherit bogus
}
} msg] $msg
} {1 {class "bogus" cannot inherit from itself}}
test inherit-7.4 {cannot have more than one inherit statement} {
list [catch {
itcl::class test_inherit_base1 { }
itcl::class test_inherit_base2 { }
itcl::class bogus {
inherit test_inherit_base1
inherit test_inherit_base2
}
} msg] $msg
} {1 {inheritance "test_inherit_base1 " already defined for class "::bogus"}}
::itcl::delete class test_inherit_base1 test_inherit_base2
# ----------------------------------------------------------------------
# Multiple base class error detection
# ----------------------------------------------------------------------
test inherit-8.1 {cannot inherit from the same base class more than once} {
itcl::class test_mi_base {}
itcl::class test_mi_foo {inherit test_mi_base}
itcl::class test_mi_bar {inherit test_mi_base}
list [catch {
itcl::class test_mi_foobar {inherit test_mi_foo test_mi_bar}
} msg] $msg
} {1 {class "::test_mi_foobar" inherits base class "::test_mi_base" more than once:
test_mi_foobar->test_mi_foo->test_mi_base
test_mi_foobar->test_mi_bar->test_mi_base}}
itcl::delete class test_mi_base
::tcltest::cleanupTests
return

88
pkgs/itcl4.2.0/tests/interp.test Normal file
View File

@@ -0,0 +1,88 @@
#
# Tests for using [incr Tcl] in slave interpreters
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Make sure that slave interpreters can be created and loaded
# with [incr Tcl]...
# ----------------------------------------------------------------------
test interp-1.1 {create a slave interp with [incr Tcl]} {
interp create slave
load "" Itcl slave
list [slave eval "namespace children :: itcl"] [interp delete slave]
} {::itcl {}}
test interp-1.2 {create a safe slave interp with [incr Tcl]} {
interp create -safe slave
load "" Itcl slave
list [slave eval "namespace children :: itcl"] [interp delete slave]
} {::itcl {}}
test interp-1.3 {errors are okay when slave interp is deleted} {
catch {interp delete slave}
interp create slave
load "" Itcl slave
slave eval {
itcl::class Troublemaker {
destructor { error "cannot delete this object" }
}
itcl::class Foo {
variable obj ""
constructor {} {
set obj [Troublemaker #auto]
}
destructor {
delete object $obj
}
}
Foo f
}
interp delete slave
} {}
test interp-1.4 {one namespace can cause another to be destroyed} {
interp create slave
load "" Itcl slave
slave eval {
namespace eval group {
itcl::class base1 {}
itcl::class base2 {}
}
itcl::class TroubleMaker {
inherit group::base1 group::base2
}
}
interp delete slave
} {}
test interp-1.5 {cleanup interp object list, this should not
include an object that deletes itself in ctor} {
interp create slave
load "" Itcl slave
slave eval {
itcl::class DeleteSelf {
constructor {} {
itcl::delete object $this
}
}
DeleteSelf ds
}
interp delete slave
} {}
::tcltest::cleanupTests
return

70
pkgs/itcl4.2.0/tests/local.test Normal file
View File

@@ -0,0 +1,70 @@
#
# Tests for "local" command for creating objects local to a proc
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Test "local" to create objects that only exist within a proc
# ----------------------------------------------------------------------
test local-1.1 {define a class to use for testing} {
itcl::class test_local {
common status ""
constructor {} {
lappend status "created $this"
}
destructor {
lappend status "deleted $this"
}
proc clear {} {
set status ""
}
proc check {} {
return $status
}
proc test {} {
itcl::local test_local #auto
lappend status "processing"
}
proc test2 {} {
itcl::local test_local #auto
lappend status "call test..."
test
lappend status "...back"
}
}
test_local #auto
} {test_local0}
test local-1.2 {} {
test_local::clear
test_local::test
test_local::check
} {{created ::test_local::test_local1} processing {deleted ::test_local::test_local1}}
test local-1.3 {} {
test_local::clear
test_local::test2
test_local::check
} {{created ::test_local::test_local2} {call test...} {created ::test_local::test_local3} processing {deleted ::test_local::test_local3} ...back {deleted ::test_local::test_local2}}
test local-1.4 {} {
itcl::find objects -isa test_local
} {test_local0}
itcl::delete class test_local
::tcltest::cleanupTests
return

163
pkgs/itcl4.2.0/tests/methods.test Normal file
View File

@@ -0,0 +1,163 @@
#
# Tests for argument lists and method execution
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Methods with various argument lists
# ----------------------------------------------------------------------
test methods-1.1 {define a class with lots of methods and arg lists} {
itcl::class test_args {
method none {} {
return "none"
}
method two {x y} {
return "two: $x $y"
}
method defvals {x {y def1} {z def2}} {
return "defvals: $x $y $z"
}
method varargs {x {y def1} args} {
return "varargs: $x $y ($args)"
}
method nomagic {args x} {
return "nomagic: $args $x"
}
method clash {x bang boom} {
return "clash: $x $bang $boom"
}
method clash_time {x bang boom} {
time {set result "clash_time: $x $bang $boom"} 1
return $result
}
proc crash {x bang boom} {
return "crash: $x $bang $boom"
}
proc crash_time {x bang boom} {
time {set result "crash_time: $x $bang $boom"} 1
return $result
}
variable bang "ok"
common boom "no-problem"
}
} ""
test methods-1.2 {create an object to execute tests} {
test_args ta
} {ta}
test methods-1.3 {argument checking: not enough args} {
list [catch {ta two 1} msg] $msg
} {1 {wrong # args: should be "ta two x y"}}
test methods-1.4a {argument checking: too many args} {
list [catch {ta two 1 2 3} msg] $msg
} {1 {wrong # args: should be "ta two x y"}}
test methods-1.4b {argument checking: too many args} {
list [catch {ta none 1 2 3} msg] $msg
} {1 {wrong # args: should be "ta none"}}
test methods-1.5a {argument checking: just right} {
list [catch {ta two 1 2} msg] $msg
} {0 {two: 1 2}}
test methods-1.5b {argument checking: just right} {
list [catch {ta none} msg] $msg
} {0 none}
test methods-1.6a {default arguments: not enough args} {
list [catch {ta defvals} msg] $msg
} {1 {wrong # args: should be "ta defvals x ?y? ?z?"}}
test methods-1.6b {default arguments: missing arguments supplied} {
list [catch {ta defvals 1} msg] $msg
} {0 {defvals: 1 def1 def2}}
test methods-1.6c {default arguments: missing arguments supplied} {
list [catch {ta defvals 1 2} msg] $msg
} {0 {defvals: 1 2 def2}}
test methods-1.6d {default arguments: all arguments assigned} {
list [catch {ta defvals 1 2 3} msg] $msg
} {0 {defvals: 1 2 3}}
test methods-1.6e {default arguments: too many args} {
list [catch {ta defvals 1 2 3 4} msg] $msg
} {1 {wrong # args: should be "ta defvals x ?y? ?z?"}}
test methods-1.7a {variable arguments: not enough args} {
list [catch {ta varargs} msg] $msg
} {1 {wrong # args: should be "ta varargs x ?y? ?arg arg ...?"}}
test methods-1.7b {variable arguments: empty} {
list [catch {ta varargs 1 2} msg] $msg
} {0 {varargs: 1 2 ()}}
test methods-1.7c {variable arguments: one} {
list [catch {ta varargs 1 2 one} msg] $msg
} {0 {varargs: 1 2 (one)}}
test methods-1.7d {variable arguments: two} {
list [catch {ta varargs 1 2 one two} msg] $msg
} {0 {varargs: 1 2 (one two)}}
test methods-1.8 {magic "args" argument has no magic unless at end of list} {
list [catch {ta nomagic 1 2 3 4} msg] $msg
} {1 {wrong # args: should be "ta nomagic args x"}}
test methods-1.9 {formal args don't clobber class members} {
list [catch {ta clash 1 2 3} msg] $msg \
[ta info variable bang -value] \
[ta info variable boom -value]
} {0 {clash: 1 2 3} ok no-problem}
test methods-1.10 {formal args don't clobber class members} {
list [catch {test_args::crash 4 5 6} msg] $msg \
[ta info variable bang -value] \
[ta info variable boom -value]
} {0 {crash: 4 5 6} ok no-problem}
test methods-1.11 {formal args don't clobber class members, even in "time"} {
list [catch {ta clash_time 7 8 9} msg] $msg \
[ta info variable bang -value] \
[ta info variable boom -value]
} {0 {clash_time: 7 8 9} ok no-problem}
test methods-1.12 {formal args don't clobber class members, even in "time"} {
list [catch {test_args::crash_time a b c} msg] $msg \
[ta info variable bang -value] \
[ta info variable boom -value]
} {0 {crash_time: a b c} ok no-problem}
test methods-2.1 {covers leak condition test for compiled locals, no args} {
for {set i 0} {$i < 100} {incr i} {
::itcl::class LeakClass {
proc leakProc {} { set n 1 }
}
LeakClass::leakProc
::itcl::delete class LeakClass
}
list 0
} 0
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class test_args
::tcltest::cleanupTests
return

83
pkgs/itcl4.2.0/tests/mkindex.itcl Normal file
View File

@@ -0,0 +1,83 @@
# Test file for:
# auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility. Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser. It must recognize constructs like this:
#
# namespace eval foo {
# class Internal { ... }
# body Internal::func {x y} { ... }
# namespace eval bar {
# class Another { ... }
# }
# }
#
# Note that class definitions can be nested inside of namespaces.
#
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
#
# Should be able to handle simple class definitions, even if
# they are prefaced with white space.
#
namespace import itcl::*
class Simple1 {
variable x 0
public method bump {} {incr x}
}
itcl::class Simple2 {
variable x 0
public variable by 1
public method bump {}
}
itcl::ensemble ens {
part one {x} {}
part two {x y} {}
part three {x y z} {}
}
#
# Should be able to handle "body" and "configbody" declarations.
#
body Simple2::bump {} {incr x $by}
configbody Simple2::by {if {$by <= 0} {error "bad increment"}}
#
# Should be able to handle class declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
class inside {
variable x 0
public variable by 1
public method bump {}
method skip {x y z} {}
proc find {args} {}
}
body inside::bump {} {incr x $by}
configbody inside::by {if {$by <= 0} {error "bad increment"}}
class ::top {
method skip {x y z} {}
method ignore {} {}
public proc find {args} {}
protected proc notice {args} {}
}
ensemble ens {
part one {x} {}
part two {x y} {}
part three {x y z} {}
}
namespace eval under {
itcl::class neath { }
}
namespace eval deep {
::itcl::class within { }
}
}

57
pkgs/itcl4.2.0/tests/mkindex.test Normal file
View File

@@ -0,0 +1,57 @@
#
# Tests for "auto_mkindex" and autoloading facility
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
set ::tcl::inl_mem_test 0
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Test "auto_mkindex" in the presence of class definitions
# ----------------------------------------------------------------------
test mkindex-1.1 {remove any existing tclIndex file} {
file delete tclIndex
file exists tclIndex
} {0}
test mkindex-1.2 {build tclIndex based on a test file} {
if {[pwd] != $::tcltest::testsDirectory} {
file copy -force [file join $::tcltest::testsDirectory mkindex.itcl] \
./mkindex.itcl
}
auto_mkindex . mkindex.itcl
if {[pwd] != $::tcltest::testsDirectory} {
file delete -force ./mkindex.itcl
}
file exists tclIndex
} {1}
set element "{source [file join . mkindex.itcl]}"
test mkindex-1.3 {examine tclIndex} {
namespace eval itcl_mkindex_tmp {
set dir "."
variable auto_index
source tclIndex
set result ""
foreach elem [lsort [array names auto_index]] {
lappend result [list $elem $auto_index($elem)]
}
set result
}
} "{::Simple2::bump $element} {::Simple2::by $element} {::buried::deep::within $element} {::buried::ens $element} {::buried::inside $element} {::buried::inside::bump $element} {::buried::inside::by $element} {::buried::inside::find $element} {::buried::under::neath $element} {::top::find $element} {::top::notice $element} {Simple1 $element} {Simple2 $element} {ens $element} {top $element}"
file delete tclIndex
::tcltest::cleanupTests
return

100
pkgs/itcl4.2.0/tests/namespace.test Normal file
View File

@@ -0,0 +1,100 @@
#
# Tests for classes within namespaces
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.2
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Classes within namespaces
# ----------------------------------------------------------------------
test namespace-1.1 {same class name can be used in different namespaces
} -body {
namespace eval test_ns_1 {
itcl::class Counter {
variable num 0
method ++ {{by 1}} {
incr num $by
}
method do {args} {
return [eval $args]
}
common tag 1
}
proc exists {} { return "don't clobber me!" }
}
namespace eval test_ns_2 {
itcl::class Counter {
variable num 0
method ++ {{by 2}} {
if {$num == 0} {
set num 1
} else {
set num [expr {$num*$by}]
}
}
method do {args} {
return [eval $args]
}
common tag 2
}
}
} -result {}
test namespace-1.2 {classes in different namespaces are different
} -body {
list [namespace eval test_ns_1::Counter {info variable tag}] \
[namespace eval test_ns_2::Counter {info variable tag}] \
} -result {{protected common ::test_ns_1::Counter::tag 1 1} {protected common ::test_ns_2::Counter::tag 2 2}}
test namespace-1.3 {create an object in one namespace
} -body {
namespace eval test_ns_1 {
list [Counter c] [c ++] [c ++] [c ++] [c ++]
}
} -result {c 1 2 3 4}
test namespace-1.4 {create an object in another namespace
} -body {
namespace eval test_ns_2 {
list [Counter c] [c ++] [c ++] [c ++] [c ++]
}
} -cleanup {
namespace delete ::itcl::internal::variables::test_ns_2
namespace delete test_ns_2
} -result {c 1 2 4 8}
test namespace-1.5 {can find classes wrapped in a namespace
} -body {
list [catch {test_ns_1::c do itcl::find objects -isa Counter} msg] $msg \
[catch {test_ns_1::c do itcl::find objects -class Counter} msg] $msg
} -result {0 ::test_ns_1::c 0 ::test_ns_1::c}
test namespace-1.6 {can't create an object that clobbers a command in this namespace
} -body {
list [catch {namespace eval test_ns_1 {Counter exists}} msg] $msg
} -result {1 {command "exists" already exists in namespace "::test_ns_1"}}
test namespace-1.7 {can create an object that shadows a command in the global namespace
} -body {
list [catch {namespace eval test_ns_1 {Counter lreplace}} msg] $msg \
[catch {itcl::find objects *lreplace} msg] $msg \
[namespace eval test_ns_1 {namespace which lreplace}]
} -cleanup {
namespace delete ::itcl::internal::variables::test_ns_1
namespace delete test_ns_1
} -result {0 lreplace 0 ::test_ns_1::lreplace ::test_ns_1::lreplace}
::tcltest::cleanupTests
return

374
pkgs/itcl4.2.0/tests/protection.test Normal file
View File

@@ -0,0 +1,374 @@
#
# Tests for method/variable protection and access
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Class members are protected by access restrictions
# ----------------------------------------------------------------------
test protect-1.1 {define a class with various protection levels} {
itcl::class test_pr {
public {
variable pubv "public var"
common pubc "public com"
method pubm {} {return "public method"}
method ovpubm {} {return "overloaded public method"}
proc pubp {} {return "public proc"}
}
protected {
variable prov "protected var"
common proc "protected com"
method prom {} {return "protected method"}
method ovprom {} {return "overloaded protected method"}
proc prop {} {return "protected proc"}
}
private {
variable priv "private var"
common pric "private com"
method prim {} {return "private method"}
method ovprim {} {return "overloaded private method"}
proc prip {} {return "private proc"}
}
method do {args} {eval $args}
}
} ""
test protect-1.2 {create an object to execute tests} {
test_pr #auto
} {test_pr0}
test protect-1.3a {public methods can be accessed from outside} {
list [catch {test_pr0 pubm} msg] $msg
} {0 {public method}}
test protect-1.3b {public methods can be accessed from inside} {
list [catch {test_pr0 do pubm} msg] $msg
} {0 {public method}}
test protect-1.4a {protected methods are blocked from outside} {
list [catch {test_pr0 prom} msg] $msg
} {1 {bad option "prom": should be one of...
test_pr0 cget -option
test_pr0 configure ?-option? ?value -option value...?
test_pr0 do ?arg arg ...?
test_pr0 isa className
test_pr0 ovpubm
test_pr0 pubm}}
test protect-1.4b {protected methods can be accessed from inside} {
list [catch {test_pr0 do prom} msg] $msg
} {0 {protected method}}
test protect-1.5a {private methods are blocked from outside} {
list [catch {test_pr0 prim} msg] $msg
} {1 {bad option "prim": should be one of...
test_pr0 cget -option
test_pr0 configure ?-option? ?value -option value...?
test_pr0 do ?arg arg ...?
test_pr0 isa className
test_pr0 ovpubm
test_pr0 pubm}}
test protect-1.5b {private methods can be accessed from inside} {
list [catch {test_pr0 do prim} msg] $msg
} {0 {private method}}
test protect-1.6a {public procs can be accessed from outside} {
list [catch {test_pr::pubp} msg] $msg
} {0 {public proc}}
test protect-1.6b {public procs can be accessed from inside} {
list [catch {test_pr0 do pubp} msg] $msg
} {0 {public proc}}
test protect-1.7a {protected procs are blocked from outside} {
list [catch {test_pr::prop} msg] $msg
} {1 {can't access "::test_pr::prop": protected function}}
test protect-1.7b {protected procs can be accessed from inside} {
list [catch {test_pr0 do prop} msg] $msg
} {0 {protected proc}}
test protect-1.8a {private procs are blocked from outside} {
list [catch {test_pr::prip} msg] $msg
} {1 {can't access "::test_pr::prip": private function}}
test protect-1.8b {private procs can be accessed from inside} {
list [catch {test_pr0 do prip} msg] $msg
} {0 {private proc}}
test protect-1.9a {public commons can be accessed from outside} {
list [catch {set test_pr::pubc} msg] $msg
} {0 {public com}}
test protect-1.9b {public commons can be accessed from inside} {
list [catch {test_pr0 do set pubc} msg] $msg
} {0 {public com}}
test protect-1.10 {protected commons can be accessed from inside} {
list [catch {test_pr0 do set proc} msg] $msg
} {0 {protected com}}
test protect-1.11 {private commons can be accessed from inside} {
list [catch {test_pr0 do set pric} msg] $msg
} {0 {private com}}
test protect-1.12a {object-specific variables require an access command} {
list [catch {set test_pr::pubv} msg] $msg
} {1 {can't read "test_pr::pubv": no such variable}}
test protect-1.12b {public variables can be accessed from inside} {
list [catch {test_pr0 do set pubv} msg] $msg
} {0 {public var}}
test protect-1.13a {object-specific variables require an access command} {
list [catch {set test_pr::prov} msg] $msg
} {1 {can't read "test_pr::prov": no such variable}}
test protect-1.13b {protected variables can be accessed from inside} {
list [catch {test_pr0 do set prov} msg] $msg
} {0 {protected var}}
test protect-1.14a {object-specific variables require an access command} {
list [catch {set test_pr::priv} msg] $msg
} {1 {can't read "test_pr::priv": no such variable}}
test protect-1.14b {private variables can be accessed from inside} {
list [catch {test_pr0 do set priv} msg] $msg
} {0 {private var}}
# ----------------------------------------------------------------------
# Access restrictions work properly with inheritance
# ----------------------------------------------------------------------
test protect-2.1 {define a derived class} {
itcl::class test_pr_derived {
inherit test_pr
method do {args} {eval $args}
public method ovpubm {} {return "specific public method"}
protected method ovprom {} {return "specific protected method"}
private method ovprim {} {return "specific private method"}
public method dpubm {} {return "pub (only in derived)"}
protected method dprom {} {return "pro (only in derived)"}
private method dprim {} {return "pri (only in derived)"}
}
} ""
test protect-2.2 {create an object to execute tests} {
test_pr_derived #auto
} {test_pr_derived0}
test protect-2.3 {public methods can be accessed from inside} {
list [catch {test_pr_derived0 do pubm} msg] $msg
} {0 {public method}}
test protect-2.4 {protected methods can be accessed from inside} {
list [catch {test_pr_derived0 do prom} msg] $msg
} {0 {protected method}}
test protect-2.5 {private methods are blocked} {
list [catch {test_pr_derived0 do prim} msg] $msg
} {1 {invalid command name "prim"}}
test protect-2.6 {public procs can be accessed from inside} {
list [catch {test_pr_derived0 do pubp} msg] $msg
} {0 {public proc}}
test protect-2.7 {protected procs can be accessed from inside} {
list [catch {test_pr_derived0 do prop} msg] $msg
} {0 {protected proc}}
test protect-2.8 {private procs are blocked} {
list [catch {test_pr_derived0 do prip} msg] $msg
} {1 {invalid command name "prip"}}
test protect-2.9 {public commons can be accessed from inside} {
list [catch {test_pr_derived0 do set pubc} msg] $msg
} {0 {public com}}
test protect-2.10 {protected commons can be accessed from inside} {
list [catch {test_pr_derived0 do set proc} msg] $msg
} {0 {protected com}}
test protect-2.11 {private commons are blocked} {
list [catch {test_pr_derived0 do set pric} msg] $msg
} {1 {can't read "pric": no such variable}}
test protect-2.12 {public variables can be accessed from inside} {
list [catch {test_pr_derived0 do set pubv} msg] $msg
} {0 {public var}}
test protect-2.13 {protected variables can be accessed from inside} {
list [catch {test_pr_derived0 do set prov} msg] $msg
} {0 {protected var}}
test protect-2.14 {private variables are blocked} {
list [catch {test_pr_derived0 do set priv} msg] $msg
} {1 {can't read "priv": no such variable}}
test protect-2.15 {can access overloaded public method} {
set cmd {namespace eval test_pr_derived {test_pr_derived0 ovpubm}}
list [catch $cmd msg] $msg
} {0 {specific public method}}
test protect-2.16 {can access overloaded public method} {
set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprom}}
list [catch $cmd msg] $msg
} {0 {specific protected method}}
test protect-2.17 {can access overloaded private method} {
set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprim}}
list [catch $cmd msg] $msg
} {0 {specific private method}}
test protect-2.18 {can access overloaded public method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 ovpubm}}
list [catch $cmd msg] $msg
} {0 {specific public method}}
test protect-2.19 {can access overloaded protected method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 ovprom}}
list [catch $cmd msg] $msg
} {0 {specific protected method}}
test protect-2.20 {*cannot* access overloaded private method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 ovprim}}
list [catch $cmd msg] $msg
} {1 {bad option "ovprim": should be one of...
test_pr_derived0 cget -option
test_pr_derived0 configure ?-option? ?value -option value...?
test_pr_derived0 do ?arg arg ...?
test_pr_derived0 dpubm
test_pr_derived0 isa className
test_pr_derived0 ovprom
test_pr_derived0 ovpubm
test_pr_derived0 prim
test_pr_derived0 prom
test_pr_derived0 pubm}}
test protect-2.21 {can access non-overloaded public method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 dpubm}}
list [catch $cmd msg] $msg
} {0 {pub (only in derived)}}
test protect-2.22 {*cannot* access non-overloaded protected method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 dprom}}
list [catch $cmd msg] $msg
} {1 {bad option "dprom": should be one of...
test_pr_derived0 cget -option
test_pr_derived0 configure ?-option? ?value -option value...?
test_pr_derived0 do ?arg arg ...?
test_pr_derived0 dpubm
test_pr_derived0 isa className
test_pr_derived0 ovprom
test_pr_derived0 ovpubm
test_pr_derived0 prim
test_pr_derived0 prom
test_pr_derived0 pubm}}
test protect-2.23 {*cannot* access non-overloaded private method from base class} {
set cmd {namespace eval test_pr {test_pr_derived0 dprim}}
list [catch $cmd msg] $msg
} {1 {bad option "dprim": should be one of...
test_pr_derived0 cget -option
test_pr_derived0 configure ?-option? ?value -option value...?
test_pr_derived0 do ?arg arg ...?
test_pr_derived0 dpubm
test_pr_derived0 isa className
test_pr_derived0 ovprom
test_pr_derived0 ovpubm
test_pr_derived0 prim
test_pr_derived0 prom
test_pr_derived0 pubm}}
eval namespace delete [itcl::find classes test_pr*]
# ----------------------------------------------------------------------
# Access restrictions don't mess up "info"
# ----------------------------------------------------------------------
test protect-3.1 {define a base class with private variables} {
itcl::class test_info_base {
private variable pribv "pribv-value"
private common pribc "pribc-value"
protected variable probv "probv-value"
protected common probc "probc-value"
public variable pubbv "pubbv-value"
public common pubbc "pubbc-value"
}
itcl::class test_info_derived {
inherit test_info_base
private variable pridv "pridv-value"
private common pridc "pridc-value"
}
} ""
test protect-3.2 {create an object to execute tests} {
test_info_derived #auto
} {test_info_derived0}
test protect-3.3 {all variables are reported} {
list [catch {test_info_derived0 info variable} msg] [lsort $msg]
} {0 {::test_info_base::pribc ::test_info_base::pribv ::test_info_base::probc ::test_info_base::probv ::test_info_base::pubbc ::test_info_base::pubbv ::test_info_derived::pridc ::test_info_derived::pridv ::test_info_derived::this}}
test protect-3.4 {private base class variables can be accessed} {
list [catch {test_info_derived0 info variable pribv} msg] $msg
} {0 {private variable ::test_info_base::pribv pribv-value pribv-value}}
test protect-3.5 {private base class commons can be accessed} {
list [catch {test_info_derived0 info variable pribc} msg] $msg
} {0 {private common ::test_info_base::pribc pribc-value pribc-value}}
test protect-3.6 {protected base class variables can be accessed} {
list [catch {test_info_derived0 info variable probv} msg] $msg
} {0 {protected variable ::test_info_base::probv probv-value probv-value}}
test protect-3.7 {protected base class commons can be accessed} {
list [catch {test_info_derived0 info variable probc} msg] $msg
} {0 {protected common ::test_info_base::probc probc-value probc-value}}
test protect-3.8 {public base class variables can be accessed} {
list [catch {test_info_derived0 info variable pubbv} msg] $msg
} {0 {public variable ::test_info_base::pubbv pubbv-value {} pubbv-value}}
test protect-3.9 {public base class commons can be accessed} {
list [catch {test_info_derived0 info variable pubbc} msg] $msg
} {0 {public common ::test_info_base::pubbc pubbc-value pubbc-value}}
test protect-3.10 {private derived class variables can be accessed} {
list [catch {test_info_derived0 info variable pridv} msg] $msg
} {0 {private variable ::test_info_derived::pridv pridv-value pridv-value}}
test protect-3.11 {private derived class commons can be accessed} {
list [catch {test_info_derived0 info variable pridc} msg] $msg
} {0 {private common ::test_info_derived::pridc pridc-value pridc-value}}
test protect-3.12 {private base class variables can't be accessed from class} {
list [catch {
namespace eval test_info_derived {info variable pribv}
} msg] $msg
} {1 {cannot access object-specific info without an object context}}
test protect-3.13 {private base class commons can be accessed from class} {
list [catch {
namespace eval test_info_derived {info variable pribc}
} msg] $msg
} {0 {private common ::test_info_base::pribc pribc-value pribc-value}}
eval namespace delete [itcl::find classes test_info*]
::tcltest::cleanupTests
return

227
pkgs/itcl4.2.0/tests/scope.test Normal file
View File

@@ -0,0 +1,227 @@
#
# Tests for code/scope commands
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
# ----------------------------------------------------------------------
# Syntax of the "scope" command
# ----------------------------------------------------------------------
test scope-1.1 {scope command takes one argument} {
list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg
} {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}}
test scope-1.2 {argument to scope command must be a variable} {
variable test_scope_var 0
list [catch {itcl::scope xyzzy} msg] $msg \
[catch {itcl::scope test_scope_var} msg] $msg
} {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var}
test scope-1.3 {if variable is already fully qualified, scope does nothing} {
list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var]
} {::xyzzy ::test_scope_var}
test scope-1.4 {scope command returns fully qualified name} {
namespace eval test_scope_ns {
namespace eval child {
variable v1 0
itcl::scope v1
}
}
} {::test_scope_ns::child::v1}
namespace delete test_scope_ns
unset test_scope_var
# ----------------------------------------------------------------------
# Syntax of the "code" command
# ----------------------------------------------------------------------
test scope-2.1 {code command takes at least one argument} {
list [catch {itcl::code} msg] $msg
} {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}}
test scope-2.2 {code command with one argument} {
itcl::code arg1
} {namespace inscope :: arg1}
test scope-2.3 {code command with many arguments} {
list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4]
} {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}}
test scope-2.4 {code command appends arguments as list elements} {
list [itcl::code "foo bar"] \
[itcl::code "foo bar" "hello, world!" "one, two, three"]
} {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}}
test scope-2.5 {code command inside code command} {
itcl::code [itcl::code arg1 arg2] arg3
} {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}}
test scope-2.6 {code command returns fully qualified names} {
namespace eval test_scope_ns {
namespace eval child {
itcl::code foo bar baz
}
}
} {namespace inscope ::test_scope_ns::child {foo bar baz}}
test scope-2.7 {code command lets you specify a namespace} {
list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \
[catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg
} {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}}
test scope-2.8 {last namespace wins} {
itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1
} {namespace inscope ::test_scope_ns arg1}
test scope-2.9 {"--" terminates switches} {
list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \
[catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg
} {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}}
namespace delete test_scope_ns
# ----------------------------------------------------------------------
# Test code/scope commands in a class
# ----------------------------------------------------------------------
test scope-3.1 {define simple classes with things to export} {
itcl::class test_scope {
private variable priv "private-value"
protected variable prov "protected-value"
public variable pubv "public-value"
private common pric "private-common-value"
protected common proc "protected-common-value"
public common pubc "public-common-value"
variable varray
common carray
method mcontext {args} {
return [eval $args]
}
proc pcontext {args} {
return [eval $args]
}
private method prim {args} {
return "prim: $args"
}
protected method prom {args} {
return "prom: $args"
}
public method pubm {args} {
return "pubm: $args"
}
}
test_scope #auto
} {test_scope0}
test scope-3.2 {code command captures only class context} {
list [test_scope0 mcontext itcl::code arg1 arg2] \
[test_scope::pcontext itcl::code arg1 arg2]
} {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}}
test scope-3.3 {scope command captures class and object context} -body {
list [test_scope0 mcontext itcl::scope priv] \
[test_scope::pcontext itcl::scope pric]
} -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::test_scope::pric}
test scope-3.4 {scope command must recognize variable} {
list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg
} {1 {variable "xyzzy" not found in class "::test_scope"}}
test scope-3.5 {scope command provides access to instance variables} {
set result ""
foreach vname {priv prov pubv} {
lappend result [test_scope0 info variable $vname]
set var [test_scope0 mcontext itcl::scope $vname]
set $var "$vname-new"
lappend result [test_scope0 info variable $vname]
}
set result
} {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}}
test scope-3.6 {scope command provides access to common variables} {
set result ""
foreach vname {pric proc pubc} {
lappend result [test_scope0 info variable $vname]
set var [test_scope0 mcontext itcl::scope $vname]
set $var "$vname-new"
lappend result [test_scope0 info variable $vname]
}
set result
} {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}}
test scope-3.7 {code command provides access to methods} {
set result ""
foreach mname {prim prom pubm} {
set cmd [test_scope0 mcontext eval itcl::code \$this $mname]
lappend result $cmd [uplevel 0 $cmd 1 2 3]
}
set result
} {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}}
test scope-3.8 {scope command allows access to slots in an array} -body {
test_scope0 mcontext set varray(0) "defined"
test_scope::pcontext set carray(0) "defined"
list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \
[catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \
[catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \
[catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg
} -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::test_scope::carray(1)}
itcl::delete class test_scope
# ----------------------------------------------------------------------
# Test code/scope commands in a namespace
# ----------------------------------------------------------------------
test scope-4.1 {define simple namespace with things to export} {
namespace eval test_scope_ns {
variable array
proc pcontext {args} {
return [eval $args]
}
}
namespace children :: ::test_scope_ns
} {::test_scope_ns}
test scope-4.2 {scope command allows access to slots in an array} {
test_scope_ns::pcontext set array(0) "defined"
list [catch {test_scope_ns::pcontext itcl::scope array(0)} msg] $msg \
[catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg
} {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)}
namespace delete test_scope_ns
test scope-5.0 {Bug e5f529da75} -setup {
itcl::class B {
common c
method v {} {itcl::scope c}
}
itcl::class D {
inherit B
method v {} {itcl::scope c}
}
B b
D d
} -body {
string equal [b v] [d v]
} -cleanup {
itcl::delete class B
} -result 1
::tcltest::cleanupTests
return

680
pkgs/itcl4.2.0/tests/sfbugs.test Normal file
View File

@@ -0,0 +1,680 @@
#
# Tests for SF bugs
# ----------------------------------------------------------------------
# AUTHOR: Arnulf Wiedemann
# arnulf@wiedemann-pri.de
# ----------------------------------------------------------------------
# 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.
package require tcltest 2.1
namespace import ::tcltest::test
::tcltest::loadTestedCommands
package require itcl
global ::test_status
# ----------------------------------------------------------------------
# Test bugs of the SourceForge bug tracker for incrtcl
# ----------------------------------------------------------------------
test sfbug-163 {upvar has to resolve instance variables in caller} -setup {
itcl::class o1 {
public method getValue {name} {
upvar $name val
set val 22
}
}
itcl::class o2 {
public variable command
constructor {cls2} {
$cls2 getValue command
}
public method b {cls2} {
return $command
}
}
o1 test1
o2 test2 test1
} -body {
test2 b test1
} -cleanup {
itcl::delete class o2
itcl::delete class o1
} -result 22
test sfbug-187 {upvar with this variable SF bug #187
} -body {
::itcl::class foo {
method test {} {
PopID
}
proc PopID {} {
upvar 1 this me
set me
}
}
foo bar
bar test
} -result {::bar} \
-cleanup {::itcl::delete class foo}
test sfbug-234 {chain with no argument SF bug #234
} -body {
set ::test_status ""
itcl::class One {
public method t1 {x} {
lappend ::test_status "$this One.t1($x)"
}
public method t2 {} {
lappend ::test_status "$this One.t2"
}
}
itcl::class Two {
inherit One
public method t1 {x} {
lappend ::test_status "$this Two.t1($x)"
chain $x
}
public method t2 {} {
lappend ::test_status "$this Two.t2"
chain
}
}
set y [Two #auto]
$y t1 a
$y t2
} -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \
-cleanup {::itcl::delete class Two}
test sfbug-236 {problem with inheritance of methods SF bug #236
} -body {
set ::test_status ""
::itcl::class c_mem {
private method get_ports {}
public method get_mem {}
}
::itcl::class c_rom {
inherit c_mem
private method get_ports {}
}
::itcl::body c_rom::get_ports {} {
return "toto"
}
::itcl::body c_mem::get_ports {} {
return "tata"
}
::itcl::body c_mem::get_mem {} {
return [concat "titi" [get_ports]]
}
set ptr [c_rom #auto]
lappend ::test_status [$ptr get_mem]
# expected output:
# titi toto
} -result {{titi toto}} \
-cleanup {::itcl::delete class c_rom}
test sfbug-237 { problem with chain command SF bug #237
} -body {
set ::test_status ""
itcl::class main {
constructor {} {
lappend ::test_status "OK ITCL constructor"
}
public method init_OK1 { parm } {
lappend ::test_status "OK1 MAIN $parm"
}
public method init_OK2 {} {
lappend ::test_status "OK2 MAIN"
}
public method init_ERR1 {} {
lappend ::test_status "ERR1 MAIN"
}
}
itcl::class child {
inherit main
constructor {} {}
public method init_OK1 {} {
lappend ::test_status "OK1 CHILD"
chain TEST
}
public method init_OK2 {} {
lappend ::test_status "OK2 CHILD"
next
}
public method init_ERR1 {} {
lappend ::test_status "ERR1 CHILD"
chain
}
}
set obj [child #auto]
$obj init_OK1
$obj init_OK2
$obj init_ERR1
} -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \
-cleanup {::itcl::delete class child}
test sfbug-243 {faulty namespace behaviour SF bug #243
} -body {
set ::test_status ""
namespace eval ns {}
itcl::class ns::A {
method do {} {nsdo}
method nsdo {} {
lappend ::test_status "body do: [info function do -body]"
}
}
[ns::A #auto] do
itcl::body ns::A::do {} {A::nsdo}
[ns::A #auto] do
itcl::body ns::A::do {} {::ns::A::nsdo}
[ns::A #auto] do
itcl::body ns::A::do {} {ns::A::nsdo}
[ns::A #auto] do
} -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \
-cleanup {::itcl::delete class ns::A}
test sfbug-244 { SF bug 244
} -body {
set ::test_status ""
proc foo {body} {
uplevel $body
}
itcl::class A {
method do {body} {foo $body}
method do2 {} {lappend ::test_status done}
}
set y [A #auto]
$y do {
lappend ::test_status "I'm $this"
do2
}
} -result {{I'm ::a0} done} \
-cleanup {::itcl::delete class A; rename foo {}}
test sfbug-250 { SF bug #250
} -body {
set ::test_status ""
::itcl::class A {
variable b
constructor {} {
set b [B #auto]
}
public method m1 {} {
$b m3
}
public method m2 {} {
lappend ::test_status m2
}
}
::itcl::class B {
public method m3 {} {
uplevel m2
}
}
set a [A #auto]
$a m1
} -result {m2} \
-cleanup {::itcl::delete class A B}
test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx
} -body {
set ::test_status ""
itcl::class foo {
method kerplunk {args} {
lappend ::test_status [info level 0]
lappend ::test_status [::info level 0]
lappend ::test_status [[namespace which info] level 0]
}
}
[foo #auto] kerplunk hello world
} -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \
-cleanup {::itcl::delete class foo}
test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb]
} -body {
set interp [interp create]
set ::test_status ""
$interp eval {
oo::class destroy
}
lappend ::test_status "::oo::class destroy worked"
if {[catch {
$interp eval [::tcltest::loadScript]
$interp eval {
package require itcl
}
} msg]} {
lappend ::test_status $msg
}
} -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \
-cleanup {interp delete $interp}
test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb]
} -body {
set interp [interp create]
set ::test_status ""
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval [::tcltest::loadScript]
$interp eval {
package require itcl
oo::class destroy
}
lappend ::test_status "::oo::class destroy worked"
if {[catch {
$interp eval {
::itcl::class ::test {}
}
} msg]} {
lappend ::test_status $msg
}
} -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \
-cleanup {interp delete $interp}
test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb]
} -body {
set interp [interp create]
set ::test_status ""
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval [::tcltest::loadScript]
$interp eval {
package require itcl
::itcl::class ::test {}
}
lappend ::test_status "::test class created"
$interp eval {
oo::class destroy
}
lappend ::test_status "::oo::class destroy worked"
if {[catch {
$interp eval {
::test x
}
} msg]} {
lappend ::test_status $msg
}
if {[catch {
$interp eval {
::itcl::class ::test2 {inherit ::test}
}
} msg]} {
lappend ::test_status $msg
}
} -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \
-cleanup {interp delete $interp}
test sfbug-255 { SF bug #255
} -body {
set ::test_status ""
proc ::sfbug_255_do_uplevel { body } {
uplevel 1 $body
}
proc ::sfbug_255_testclass { pathName args } {
uplevel TestClass $pathName $args
}
::itcl::class TestClass {
public variable property "value"
constructor {} {
}
private method internal-helper {} {
return "TestClass::internal-helper"
}
public method api-call {} {
lappend ::test_status "TestClass::api-call"
lappend ::test_status [internal-helper]
lappend ::test_status [sfbug_255_do_uplevel { internal-helper }]
lappend ::test_status [cget -property]
sfbug_255_do_uplevel { lappend ::test_status [cget -property] }
}
}
[::sfbug_255_testclass tc] api-call
} -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \
-cleanup {::itcl::delete class TestClass}
test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23
} -body {
::itcl::class ::Naughty {
private method die {} {
}
}
::Naughty die
} -cleanup {
::itcl::delete class ::Naughty
} -result {die}
test sfbug-256 { SF bug #256
} -body {
set ::test_status ""
proc ::sfbug_256_do_uplevel { body } {
uplevel 1 $body
}
proc ::sfbug_256_testclass { pathName args } {
uplevel TestClass256 $pathName $args
}
::itcl::class TestClass256 {
public variable property "value"
constructor {} {
}
private method internal-helper {} {
lappend ::test_status "TestClass::internal-helper"
sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
}
public method api-call {} {
lappend ::test_status "TestClass::api-call"
lappend ::test_status [internal-helper]
lappend ::test_status [sfbug_256_do_uplevel { internal-helper }]
lappend ::test_status [cget -property]
sfbug_256_do_uplevel { lappend ::test_status [cget -property] }
}
}
[::sfbug_256_testclass tc] api-call
} -result {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value} value value} \
-cleanup {::itcl::delete class TestClass256}
test sfbug-257 { SF bug #257
} -body {
set interp [interp create]
$interp eval {set ::tcl::inl_mem_test 0}
$interp eval [::tcltest::loadScript]
$interp eval {
package require itcl
set ::test_status ""
::itcl::class ::cl1 {
method m1 {} {
::oo::class destroy
lappend ::test_status "method Hello World"
}
proc p1 {} {
lappend ::test_status "proc Hello World"
}
}
set obj1 [::cl1 #auto]
::cl1::p1
$obj1 p1
$obj1 m1
catch {
$obj1 m1
::cl1::p1
} msg
lappend ::test_status $msg
}
} -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \
-cleanup {interp delete $interp}
test sfbug-259 { SF bug #257 } -setup {
interp create slave
load {} Itcl slave
} -cleanup {
interp delete slave
} -body {
slave eval {
proc do_uplevel { body } {
uplevel 1 $body
}
proc ::testclass { pathName args } {
uplevel TestClass $pathName $args
}
itcl::class TestClass {
constructor {} {}
public variable property "value"
public method api-call {}
protected method internal-helper {}
}
itcl::body TestClass::internal-helper {} {
}
itcl::configbody TestClass::property {
internal-helper
}
itcl::body TestClass::api-call {} {
do_uplevel {configure -property blah}
}
set tc [::testclass .]
$tc api-call
}
}
test sfbug-261 { SF bug #261 } -setup {
itcl::class A {
public method a1 {} {a2}
public method a2 {} {uplevel a3 hello}
public method a3 {s} {return $s}
}
A x
} -body {
x a1
} -cleanup {
itcl::delete class A
} -result hello
test sfbug-265.1 { SF bug #265 } -setup {
itcl::class C {}
} -body {
namespace eval A {C c}
namespace eval B {C c}
} -cleanup {
itcl::delete class C
namespace delete A B
} -result c
test sfbug-265.2 { SF bug #265 } -setup {
itcl::class C {}
itcl::class B::C {}
} -body {
C ::A::B
B::C ::A
} -cleanup {
itcl::delete class B::C
itcl::delete class C
namespace delete A B
} -result ::A
test sfbug-268 { SF bug #268 } -setup {
itcl::class C {
private variable v
destructor {error foo}
public method demo {} {set v 0}
}
C c
} -body {
catch {itcl::delete object c}
c demo
} -cleanup {
rename c {}
itcl::delete class C
} -result 0
test sfbug-273 { SF bug #273 } -setup {
itcl::class C {
public proc call {m} {$m}
public proc crash {} {
call null
info frame 2
return ok
}
public proc null {} {}
}
} -body {
C::call crash
} -cleanup {
itcl::delete class C
} -result ok
test sfbug-276.0 { SF bug #276 } -setup {
set ::answer {}
itcl::class A {
constructor {} {
lappend ::answer [uplevel namespace current]
}
}
itcl::class B {
inherit A
constructor {} {}
}
} -body {
B b
set ::answer
} -cleanup {
itcl::delete class A B
unset -nocomplain ::answer
} -result ::B
test sfbug-276.1 { SF bug #276 } -setup {
set ::answer {}
itcl::class A {
constructor {} {
lappend ::answer [uplevel namespace current]
}
}
itcl::class E {
constructor {} {
lappend ::answer [uplevel namespace current]
}
}
itcl::class B {
inherit A E
constructor {} {}
}
} -body {
B b
set ::answer
} -cleanup {
itcl::delete class A B E
unset -nocomplain ::answer
} -result {::B ::B}
test fossil-9.0 {d0126511d9} -setup {
itcl::class N::B {}
} -body {
itcl::class N {}
} -cleanup {
itcl::delete class N::B N
} -result {}
test fossil-9.1 {d0126511d9} -setup {
itcl::class N::B {}
itcl::delete class N::B
namespace delete N
} -body {
itcl::class N {}
} -cleanup {
itcl::delete class N
catch {namespace delete N}
} -result {}
test fossil-9.2 {ec215db901} -setup {
set ::answer {}
itcl::class Object {
constructor {} {set n 1} {set ::answer $n}
}
} -body {
Object foo
set ::answer
} -cleanup {
itcl::delete class Object
unset -nocomplain ::answer
} -result 1
test fossil-9.3 {c45384364c} -setup {
itcl::class A {
method demo script {uplevel 1 $script}
}
A a
itcl::class B {
method demo script {eval $script; a demo $script}
}
B b
} -body {
b demo {lappend result $this}
} -cleanup {
itcl::delete class A B
} -result {::b ::b}
test fossil-9.4 {9eea4912b9} -setup {
itcl::class A {
public method foo WRONG
}
} -body {
itcl::body A::foo {RIGHT} {}
A a
a info args foo
} -cleanup {
itcl::delete class A
} -result RIGHT
test sfbugs-281 {Resolve inherited common} -setup {
itcl::class Parent {protected common x 0}
} -cleanup {
itcl::delete class Parent
} -body {
itcl::class Child {
inherit Parent
set Parent::x
}
} -result {}
#test sfbug-xxx { SF bug xxx
#} -body {
# set ::test_status ""
#
#} -result {::bar} \
# -cleanup {::itcl::delete class yyy}
::tcltest::cleanupTests
return

23
pkgs/itcl4.2.0/tests/tclIndex Normal file
View File

@@ -0,0 +1,23 @@
# Tcl autoload index file, version 2.0
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
# sets an element in the auto_index array, where the
# element name is the name of a command and the value is
# a script that loads the command.
set auto_index(Simple1) [list source [file join $dir mkindex.itcl]]
set auto_index(Simple2) [list source [file join $dir mkindex.itcl]]
set auto_index(ens) [list source [file join $dir mkindex.itcl]]
set auto_index(::Simple2::bump) [list source [file join $dir mkindex.itcl]]
set auto_index(::Simple2::by) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::inside) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::inside::find) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::inside::bump) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::inside::by) [list source [file join $dir mkindex.itcl]]
set auto_index(top) [list source [file join $dir mkindex.itcl]]
set auto_index(::top::find) [list source [file join $dir mkindex.itcl]]
set auto_index(::top::notice) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::ens) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::under::neath) [list source [file join $dir mkindex.itcl]]
set auto_index(::buried::deep::within) [list source [file join $dir mkindex.itcl]]

606
pkgs/itcl4.2.0/tests/typeclass.test Normal file
View File

@@ -0,0 +1,606 @@
#---------------------------------------------------------------------
# TITLE:
# typeclass.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code from the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type command.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
interp alias {} type {} ::itcl::type
loadTestedCommands
#-----------------------------------------------------------------------
# type destruction
test typedestruction-1.1 {type command is deleted} -body {
type dog { }
dog destroy
info command ::dog
} -result {}
test typedestruction-1.2 {instance commands are deleted} -body {
type dog { }
dog create spot
dog destroy
info command ::spot
} -result {}
test typedestruction-1.3 {type namespace is deleted} -body {
type dog { }
dog destroy
namespace exists ::dog
} -result {0}
test typedestruction-1.4 {type proc is destroyed on error} -body {
catch {type dog {
error "Error creating dog"
}} result
list [namespace exists ::dog] [info command ::dog]
} -result {0 {}}
#-----------------------------------------------------------------------
# type and typemethods
test type-1.1 {type names get qualified} -body {
type dog {}
} -cleanup {
dog destroy
} -result {::dog}
test type-1.2 {typemethods can be defined} -body {
type dog {
typemethod foo {a b} {
return [list $a $b]
}
}
dog foo 1 2
} -cleanup {
dog destroy
} -result {1 2}
test type-1.3 {upvar works in typemethods} -body {
type dog {
typemethod goodname {varname} {
upvar $varname myvar
set myvar spot
}
}
set thename fido
dog goodname thename
set thename
} -cleanup {
dog destroy
unset thename
} -result {spot}
test type-1.4 {typemethod args can't include type} -body {
type dog {
typemethod foo {a type b} { }
}
} -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly}
test type-1.5 {typemethod args can't include self} -body {
type dog {
typemethod foo {a self b} { }
}
} -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly}
test type-1.6 {typemethod args can span multiple lines} -body {
# This case caused an error at definition time in 0.9 because the
# arguments were included in a comment in the compile script, and
# the subsequent lines weren't commented.
type dog {
typemethod foo {
a
b
} { }
}
} -cleanup {
dog destroy
} -result {::dog}
#---------------------------------------------------------------------
# typeconstructor
test typeconstructor-1.1 {a typeconstructor can be defined} -body {
type dog {
typevariable a
typeconstructor {
set a 1
}
typemethod aget {} {
return $a
}
}
dog aget
} -cleanup {
dog destroy
} -result {1}
test typeconstructor-1.2 {only one typeconstructor can be defined} -body {
type dog {
typevariable a
typeconstructor {
set a 1
}
typeconstructor {
set a 2
}
}
} -returnCodes {
error
} -result {"typeconstructor" already defined in class "::dog"}
test typeconstructor-1.3 {type proc is destroyed on error} -body {
catch {
type dog {
typeconstructor {
error "Error creating dog"
}
}
} result
list [namespace exists ::dog] [info command ::dog]
} -result {0 {}}
#-----------------------------------------------------------------------
# Type components
test typecomponent-1.1 {typecomponent defines typevariable} -body {
type dog {
typecomponent mycomp
typemethod test {} {
return $mycomp
}
}
dog test
} -cleanup {
dog destroy
} -result {}
test typecomponent-1.4 {typecomponent -inherit yes} -body {
type dog {
typecomponent mycomp -inherit yes
typeconstructor {
set mycomp string
}
}
dog length foo
} -cleanup {
dog destroy
} -result {3}
#-----------------------------------------------------------------------
# type creation
test creation-1.1 {type instance names get qualified} -body {
type dog { }
dog create spot
} -cleanup {
dog destroy
} -result {::spot}
test creation-1.2 {type instance names can be generated} -body {
type dog { }
dog create my#auto
} -cleanup {
dog destroy
} -result {::mydog0}
test creation-1.3 {"create" method is optional} -body {
type dog { }
dog fido
} -cleanup {
dog destroy
} -result {::fido}
test creation-1.4 {constructor arg can't be type} -body {
type dog {
constructor {type} { }
}
} -returnCodes {
error
} -result {constructor's arglist may not contain "type" explicitly}
test creation-1.5 {constructor arg can't be self} -body {
type dog {
constructor {self} { }
}
} -returnCodes {
error
} -result {constructor's arglist may not contain "self" explicitly}
test creation-1.6 {weird names are OK} -body {
# I.e., names with non-identifier characters
type confused-dog {
method meow {} {
return "$self meows."
}
}
confused-dog spot
spot meow
} -cleanup {
confused-dog destroy
} -result {::spot meows.}
#-----------------------------------------------------------------------
# renaming
test typeclass-rename-1.1 {mymethod uses name of instance name variable} -body {
type dog {
method mymethod {} {
list [mymethod] [mymethod "A B"] [mymethod A B]
}
}
dog fido
fido mymethod
} -cleanup {
dog destroy
} -match glob -result {{::itcl::builtin::callinstance *} {::itcl::builtin::callinstance * {A B}} {::itcl::builtin::callinstance * A B}}
test typeclass-rename-1.2 {instances can be renamed} -body {
type dog {
method names {} {
list [mymethod] $selfns $win $self
}
}
dog fido
set a [fido names]
rename fido spot
set b [spot names]
concat $a $b
} -cleanup {
dog destroy
} -match glob -result {{::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::fido {::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::spot}
test rename-1.3 {rename to "" deletes an instance} -body {
type dog { }
dog fido
rename fido ""
namespace children ::dog
} -cleanup {
dog destroy
} -result {}
test rename-1.4 {rename to "" deletes an instance even after a rename} -body {
type dog { }
dog fido
rename fido spot
rename spot ""
namespace children ::dog
} -cleanup {
dog destroy
} -result {}
test rename-1.5 {creating an object twice destroys the first instance} -body {
type dog {
typemethod x {} {}
}
dog fido
set ns [info object namespace fido]
set a [namespace children ::itcl::internal::variables$ns]
dog fido
set ns [info object namespace fido]
set b [namespace children ::itcl::internal::variables$ns]
fido destroy
set c [namespace which ::itcl::internal::variables$ns]
list $a $b $c
} -cleanup {
dog destroy
} -match glob -result {::itcl::internal::variables::*::dog ::itcl::internal::variables::*::dog {}}
test typeclass-component-1.1 {component defines variable} -body {
type dog {
typecomponent mycomp
public proc test {} {
return $mycomp
}
}
dog fido
fido test
} -cleanup {
fido destroy
dog destroy
} -result {}
test typeclass-component-1.2 {component -inherit} -body {
type dog {
component mycomp -inherit
constructor {} {
set mycomp string
}
}
dog fido
fido length foo
} -cleanup {
fido destroy
dog destroy
} -result {3}
test typeclass-component-1.3 {component -inherit can only have one of it} -body {
type dogbase {
component mycompbase -inherit
}
type dog {
inherit dogbase
component mycomp -inherit
constructor {} {
set mycomp string
}
}
dog fido
fido length foo
} -cleanup {
dog destroy
dogbase destroy
} -returnCodes {
error
} -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"}
#-----------------------------------------------------------------------
# constructor
test constructor-1.1 {constructor can do things} -body {
type dog {
variable a
variable b
constructor {args} {
set a 1
set b 2
}
method foo {} {
list $a $b
}
}
dog create spot
spot foo
} -cleanup {
dog destroy
} -result {1 2}
test constructor-1.2 {constructor with no configurelist ignores args} -body {
type dog {
constructor {args} { }
option -color golden
option -akc 0
}
dog create spot -color white -akc 1
list [spot cget -color] [spot cget -akc]
} -cleanup {
dog destroy
} -result {golden 0}
test constructor-1.3 {constructor with configurelist gets args} -body {
type dog {
constructor {args} {
$self configure {*}$args
}
option -color golden
option -akc 0
}
dog create spot -color white -akc 1
list [spot cget -color] [spot cget -akc]
} -cleanup {
dog destroy
} -result {white 1}
test constructor-1.4 {constructor with specific args} -body {
type dog {
option -value ""
constructor {a b args} {
set itcl_options(-value) [list $a $b $args]
}
}
dog spot retriever golden -akc 1
spot cget -value
} -cleanup {
dog destroy
} -result {retriever golden {-akc 1}}
test constructor-1.5 {constructor with list as one list arg} -body {
type dog {
option -value ""
constructor {args} {
set itcl_options(-value) $args
}
}
dog spot {retriever golden}
spot cget -value
} -cleanup {
dog destroy
} -result {{retriever golden}}
test constructor-1.6 {default constructor configures options} -body {
type dog {
option -color brown
option -breed mutt
}
dog spot -color golden -breed retriever
list [spot cget -color] [spot cget -breed]
} -cleanup {
dog destroy
} -result {golden retriever}
test constructor-1.7 {default constructor takes no args if no options} -body {
type dog {
variable color
}
dog spot -color golden
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {type "dog" has no options, but constructor has option arguments}
#-----------------------------------------------------------------------
# destroy
test destroy-1.1 {destroy cleans up the instance} -body {
type dog {
option -color golden
}
set a [namespace children ::dog::]
dog create spot
set ns [info object namespace spot]
set b [namespace children ::itcl::internal::variables$ns]
spot destroy
set c [namespace which ::itcl::internal::variables$ns]
list $a $b $c [info commands ::dog::spot]
} -cleanup {
dog destroy
} -match glob -result {{} ::itcl::internal::variables::*::dog {} {}}
test destroy-1.2 {incomplete objects are destroyed} -body {
array unset ::dog::snit_ivars
type dog {
option -color golden
constructor {args} {
$self configure {*}$args
if {"red" == [$self cget -color]} {
error "No Red Dogs!"
}
}
}
catch {dog create spot -color red} result
set names [array names ::dog::snit_ivars]
list $result $names [info commands ::dog::spot]
} -cleanup {
dog destroy
} -result {{No Red Dogs!} {} {}}
test destroy-1.3 {user-defined destructors are called} -body {
type dog {
typevariable flag ""
constructor {args} {
set flag "created $self"
}
destructor {
set flag "destroyed $self"
}
typemethod getflag {} {
return $flag
}
}
dog create spot
set a [dog getflag]
spot destroy
list $a [dog getflag]
} -cleanup {
dog destroy
} -result {{created ::spot} {destroyed ::spot}}
test install-1.7 {install works for itcl::types
} -body {
type tail {
option -tailcolor black
}
type dog {
delegate option -tailcolor to tail
constructor {args} {
installcomponent tail using tail $self.tail
}
}
dog fido
fido cget -tailcolor
} -cleanup {
dog destroy
tail destroy
} -result {black}
#-----------------------------------------------------------------------
# Setting the widget class explicitly
test widgetclass-1.1 {can't set widgetclass for itcl::types} -body {
type dog {
widgetclass Dog
}
} -returnCodes {
error
} -result {can't set widgetclass for ::itcl::type}
#-----------------------------------------------------------------------
# hulltype statement
test hulltype-1.1 {can't set hulltype for snit::types} -body {
type dog {
hulltype Dog
}
} -returnCodes {
error
} -result {can't set hulltype for ::itcl::type}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

844
pkgs/itcl4.2.0/tests/typedelegation.test Normal file
View File

@@ -0,0 +1,844 @@
#---------------------------------------------------------------------
# TITLE:
# typefunction.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type proc, method, typemethod commands.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
interp alias {} type {} ::itcl::type
if {1} {
#-----------------------------------------------------------------------
# Typemethod delegation
test dtypemethod-1.1 {delegate typemethod to non-existent component} -body {
set result ""
type dog {
delegate typemethod foo to bar
}
dog foo
} -returnCodes {
error
} -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"}
test dtypemethod-1.2 {delegating to existing typecomponent} -body {
type dog {
delegate typemethod length to string
typeconstructor {
set string string
}
}
dog length foo
} -cleanup {
dog destroy
} -result {3}
test dtypemethod-1.4 {delegating to existing typecomponent with error} -body {
type dog {
delegate typemethod length to string
typeconstructor {
set string string
}
}
dog length foo bar
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {wrong # args: should be "dog length string"}
test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body {
type dog {
delegate typemethod * to string
typeconstructor {
set string string
}
}
dog length foo
} -cleanup {
dog destroy
} -result {3}
test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body {
type dog {
delegate typemethod * to stringhandler
typeconstructor {
set stringhandler string
}
}
dog foo bar
} -cleanup {
dog destroy
} -returnCodes {
error
} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body {
type dog {
typemethod foo {} {}
delegate typemethod foo to bar
}
} -returnCodes {
error
} -result {Error in "delegate typemethod foo...", "foo" has been defined locally.}
test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body {
type dog {
delegate typemethod foo to bar
typemethod foo {} {}
}
} -returnCodes {
error
} -result {Error in "typemethod foo...", "foo" has been delegated}
test dtypemethod-1.10 {excepted methods are caught properly} -body {
type dog {
delegate typemethod * to string except {match index}
typeconstructor {
set string string
}
}
catch {dog length foo} a
catch {dog match foo} b
catch {dog index foo} c
list $a $b $c
} -cleanup {
dog destroy
} -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}}
test dtypemethod-1.11 {as clause can include arguments} -body {
proc tail {a b} {
return "<$a $b>"
}
type dog {
delegate typemethod wag to tail as {wag briskly}
typeconstructor {
set tail tail
}
}
dog wag
} -cleanup {
dog destroy
rename tail ""
} -result {<wag briskly>}
test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body {
type dog {
delegate typemethod length to string using {%c %m}
typeconstructor {
set string string
}
}
dog length foo
} -cleanup {
dog destroy
} -result {3}
test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body {
proc echo {args} {
return $args
}
type dog {
delegate typemethod tail using {echo %% %t %M %m %j %n %w %s %c}
}
dog tail
} -cleanup {
dog destroy
rename echo ""
} -result {% ::dog tail tail tail %n %w %s %c}
test dtypemethod-2.3 {"%%" is handled properly} -body {
proc echo {args} { join $args "|" }
type dog {
delegate typemethod wag using {echo %%m %%%m}
}
dog wag
} -cleanup {
dog destroy
rename echo ""
} -result {%m|%wag}
test dtypemethod-2.4 {Method "*" and "using"} -body {
proc echo {args} { join $args "|" }
type dog {
delegate typemethod * using {echo %m}
}
list [dog wag] [dog bark loudly]
} -cleanup {
dog destroy
rename echo ""
} -result {wag bark|loudly}
test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body {
proc echo {args} { join $args "|" }
type dog {
delegate typemethod length to mycomp
typeconstructor {
set mycomp string
}
typemethod switchit {} {
set mycomp echo
}
}
set a [dog length foo]
dog switchit
set b [dog length foo]
list $a $b
} -cleanup {
dog destroy
rename echo ""
} -result {3 length|foo}
test dtypemethod-4.4 {redefinition is OK} -body {
type wag {
method tail {} {return "wags tail"}
method briskly {} {return "wags tail briskly"}
}
type dog {
typeconstructor {
set wag [wag #auto]
}
delegate typemethod tail to wag as tail
delegate typemethod tail to wag as briskly
}
dog tail
} -cleanup {
dog destroy
wag destroy
} -result {wags tail briskly}
#-----------------------------------------------------------------------
# delegate: general syntax tests
test delegate-1.1 {can only delegate methods or options} -body {
type dog {
delegate foo bar to baz
}
} -returnCodes {
error
} -result {bad option "foo": should be one of...
delegate method name to targetName as scipt using script
delegate option option to targetOption as script
delegate typemethod name to targetName as scipt using script}
test delegate-1.2 {"to" must appear in the right place} -body {
type dog {
delegate method foo from bar
}
} -returnCodes {
error
} -result {bad option "from" should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
test delegate-1.3 {"as" must have a target} -body {
type dog {
delegate method foo to bar as
}
} -returnCodes {
error
} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
test delegate-1.4 {"as" must have a single target} -body {
type dog {
delegate method foo to bar as baz quux
}
} -returnCodes {
error
} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
test delegate-1.5 {"as" doesn't work with "*"} -body {
type dog {
delegate method * to hull as foo
}
} -returnCodes {
error
} -result {cannot specify "as" with "delegate method *"}
test delegate-1.6 {"except" must have a target} -body {
type dog {
delegate method * to bar except
}
} -returnCodes {
error
} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
test delegate-1.7 {"except" must have a single target} -body {
type dog {
delegate method * to bar except baz quux
}
} -returnCodes {
error
} -result {wrong # args should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
test delegate-1.8 {"except" works only with "*"} -body {
type dog {
delegate method foo to hull except bar
}
} -returnCodes {
error
} -result {can only specify "except" with "delegate method *"}
test delegate-1.9 {only "as" or "except"} -body {
type dog {
delegate method foo to bar with quux
}
} -returnCodes {
error
} -result {bad option "with" should be delegate method <methodName> to <componentName> ?as <targetName>?
delegate method <methodName> ?to <componentName>? using <pattern>
delegate method * ?to <componentName>? ?using <pattern>? ?except <methods>?}
#-----------------------------------------------------------------------
# delegated methods
test dmethod-1.1 {delegate method to non-existent component} -body {
type dog {
delegate method foo to bar
}
dog create spot
spot foo
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {::dog ::spot delegates method "foo" to undefined component "bar"}
test dmethod-1.2 {delegating to existing component} -body {
type dog {
constructor {args} {
set string string
}
delegate method length to string
}
dog create spot
spot length foo
} -cleanup {
dog destroy
} -result {3}
test dmethod-1.4 {delegating to existing component with error} -body {
type dog {
constructor {args} {
set string string
}
delegate method length to string
}
dog create spot
spot length foo bar
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {wrong # args: should be "spot length string"}
test dmethod-1.5 {delegating unknown methods to existing component} -body {
type dog {
constructor {args} {
set string string
}
delegate method * to string
}
dog create spot
spot length foo
} -cleanup {
dog destroy
} -result {3}
test dmethod-1.6a {delegating unknown method to existing component with error} -body {
type dog {
constructor {args} {
set stringhandler string
}
delegate method * to stringhandler
}
dog create spot
spot foo bar
} -returnCodes {
error
} -cleanup {
dog destroy
} -match glob -result {unknown or ambiguous subcommand "foo": must be *}
test dmethod-1.7 {can't delegate local method: order 1} -body {
type cat {
method foo {} {}
delegate method foo to hull
}
} -returnCodes {
error
} -result {method "foo" has been defined locally}
test dmethod-1.8 {can't delegate local method: order 2} -body {
type cat {
delegate method foo to hull
method foo {} {}
}
} -returnCodes {
error
} -result {method "foo" has been delegated}
test dmethod-1.10 {excepted methods are caught properly} -body {
type tail {
method wag {} {return "wagged"}
method flaunt {} {return "flaunted"}
method tuck {} {return "tuck"}
}
type cat {
method meow {} {}
delegate method * to tail except {wag tuck}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
catch {fifi flaunt} a
catch {fifi wag} b
catch {fifi tuck} c
list $a $b $c
} -cleanup {
cat destroy
tail destroy
} -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}}
test dmethod-1.11 {as clause can include arguments} -body {
type tail {
method wag {adverb} {return "wagged $adverb"}
}
type dog {
delegate method wag to tail as {wag briskly}
constructor {args} {
set tail [tail #auto]
}
}
dog spot
spot wag
} -cleanup {
dog destroy
tail destroy
} -result {wagged briskly}
test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body {
type tail {
method wag {adverb} {return "wagged $adverb"}
}
type dog {
delegate method wag to tail using {%c %m}
constructor {args} {
set tail [tail #auto]
}
}
dog spot
spot wag briskly
} -cleanup {
dog destroy
tail destroy
} -result {wagged briskly}
test dmethod-2.3 {"%%" is handled properly} -body {
proc echo {args} { join $args "|" }
type dog {
delegate method wag using {echo %%m %%%m}
}
dog spot
spot wag
} -cleanup {
dog destroy
rename echo ""
} -result {%m|%wag}
test dmethod-2.4 {Method "*" and "using"} -body {
proc echo {args} { join $args "|" }
type dog {
delegate method * using {echo %m}
}
dog spot
list [spot wag] [spot bark loudly]
} -cleanup {
dog destroy
rename echo ""
} -result {wag bark|loudly}
test dmethod-3.1 {component names can be changed dynamically} -body {
type tail1 {
method wag {} {return "wagged"}
}
type tail2 {
method wag {} {return "drooped"}
}
type dog {
delegate method wag to tail
constructor {args} {
set tail [tail1 #auto]
}
method switchit {} {
set tail [tail2 #auto]
}
}
dog fido
set a [fido wag]
fido switchit
set b [fido wag]
list $a $b
} -cleanup {
dog destroy
tail1 destroy
tail2 destroy
} -result {wagged drooped}
#-----------------------------------------------------------------------
# delegated options
test doption-1.1 {delegate option to non-existent component} -body {
type dog {
delegate option -foo to bar
}
dog create spot
spot cget -foo
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {component "bar" is undefined, needed for option "-foo"}
test doption-1.2 {delegating option to existing component: cget} -body {
type cat {
option -color "black"
}
cat create hershey
type dog {
constructor {args} {
set catthing ::hershey
}
delegate option -color to catthing
}
dog create spot
spot cget -color
} -cleanup {
dog destroy
cat destroy
} -result {black}
test doption-1.3 {delegating option to existing component: configure} -body {
type cat {
option -color "black"
}
cat create hershey
type dog {
constructor {args} {
set catthing ::hershey
$self configure {*}$args
}
delegate option -color to catthing
}
dog create spot -color blue
list [spot cget -color] [hershey cget -color]
} -cleanup {
dog destroy
cat destroy
} -result {blue blue}
test doption-1.4 {delegating unknown options to existing component} -body {
type cat {
option -color "black"
}
cat create hershey
type dog {
constructor {args} {
set catthing ::hershey
# Note: must do this after components are defined; this
# may be a problem.
$self configure {*}$args
}
delegate option * to catthing
}
dog create spot -color blue
list [spot cget -color] [hershey cget -color]
} -cleanup {
dog destroy
cat destroy
} -result {blue blue}
test doption-1.7 {delegating unknown options to existing component: error} -body {
type cat {
option -color "black"
}
cat create hershey
type dog {
constructor {args} {
set catthing ::hershey
$self configure {*}$args
}
delegate option * to catthing
}
dog create spot -colour blue
} -returnCodes {
error
} -cleanup {
dog destroy
cat destroy
} -result {unknown option "-colour"}
test doption-1.8 {can't delegate local option: order 1} -body {
type cat {
option -color "black"
delegate option -color to hull
}
} -returnCodes {
error
} -result {option "-color" has been defined locally}
test doption-1.9 {can't delegate local option: order 2} -body {
type cat {
delegate option -color to hull
option -color "black"
}
} -returnCodes {
error
} -result {cannot define option "-color" locally, it has already been delegated}
test doption-1.10 {excepted options are caught properly on cget} -body {
type tail {
option -a a
option -b b
option -c c
}
type cat {
delegate option * to tail except {-b -c}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
catch {fifi cget -a} a
catch {fifi cget -b} b
catch {fifi cget -c} c
list $a $b $c
} -cleanup {
cat destroy
tail destroy
} -result {a {unknown option "-b"} {unknown option "-c"}}
test doption-1.11 {excepted options are caught properly on configurelist} -body {
type tail {
option -a a
option -b b
option -c c
}
type cat {
delegate option * to tail except {-b -c}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
catch {fifi configure {*}{-a 1}} a
catch {fifi configure {*}{-b 1}} b
catch {fifi configure {*}{-c 1}} c
list $a $b $c
} -cleanup {
cat destroy
tail destroy
} -result {{} {unknown option "-b"} {unknown option "-c"}}
test doption-1.12 {excepted options are caught properly on configure, 1} -body {
type tail {
option -a a
option -b b
option -c c
}
type cat {
delegate option * to tail except {-b -c}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
catch {fifi configure -a 1} a
catch {fifi configure -b 1} b
catch {fifi configure -c 1} c
list $a $b $c
} -cleanup {
cat destroy
tail destroy
} -result {{} {unknown option "-b"} {unknown option "-c"}}
test doption-1.13 {excepted options are caught properly on configure, 2} -body {
type tail {
option -a a
option -b b
option -c c
}
type cat {
delegate option * to tail except {-b -c}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
catch {fifi configure -a} a
catch {fifi configure -b} b
catch {fifi configure -c} c
list $a $b $c
} -cleanup {
cat destroy
tail destroy
} -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}}
test doption-1.14 {configure query skips excepted options} -body {
type tail {
option -a a
option -b b
option -c c
}
type cat {
option -d d
delegate option * to tail except {-b -c}
constructor {args} {
set tail [tail #auto]
}
}
cat fifi
fifi configure
} -cleanup {
cat destroy
tail destroy
} -result {{-d d D d d} {-a a A a a}}
# end
}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

356
pkgs/itcl4.2.0/tests/typefunction.test Normal file
View File

@@ -0,0 +1,356 @@
#---------------------------------------------------------------------
# TITLE:
# typefunction.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type proc, method, typemethod commands.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
interp alias {} type {} ::itcl::type
#-----------------------------------------------------------------------
# procs
test proc-1.1 {proc args can span multiple lines} -body {
# This case caused an error at definition time in 0.9 because the
# arguments were included in a comment in the compile script, and
# the subsequent lines weren't commented.
type dog {
proc foo {
a
b
} { }
}
} -cleanup {
dog destroy
} -result {::dog}
#-----------------------------------------------------------------------
# methods
test method-1.1 {methods get called} -body {
type dog {
method bark {} {
return "$self barks"
}
}
dog create spot
spot bark
} -cleanup {
dog destroy
} -result {::spot barks}
test method-1.2 {methods can call other methods} -body {
type dog {
method bark {} {
return "$self barks."
}
method chase {quarry} {
return "$self chases $quarry; [$self bark]"
}
}
dog create spot
spot chase cat
} -cleanup {
dog destroy
} -result {::spot chases cat; ::spot barks.}
test method-1.3 {instances can call one another} -body {
type dog {
method bark {} {
return "$self barks."
}
method chase {quarry} {
return "$self chases $quarry; [$quarry bark] [$self bark]"
}
}
dog create spot
dog create fido
spot chase ::fido
} -cleanup {
dog destroy
} -result {::spot chases ::fido; ::fido barks. ::spot barks.}
test method-1.4 {upvar works in methods} -body {
type dog {
method goodname {varname} {
upvar $varname myvar
set myvar spot
}
}
dog create fido
set thename fido
fido goodname thename
set thename
} -cleanup {
dog destroy
} -result {spot}
test method-1.6 {unknown methods get an error } -body {
type dog { }
dog create spot
set result ""
spot chase
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {bad option "chase": should be one of...
spot callinstance <instancename>
spot cget -option
spot configure ?-option? ?value -option value...?
spot destroy
spot getinstancevar <instancename>
spot isa className
spot mymethod
spot myvar
spot unknown}
test method-1.7 {info type method returns the object's type} -body {
type dog { }
dog create spot
spot info type
} -cleanup {
dog destroy
} -result {::dog}
test method-1.8 {instance method can call type method} -body {
type dog {
typemethod hello {} {
return "Hello"
}
method helloworld {} {
return "[$type hello], World!"
}
}
dog create spot
spot helloworld
} -cleanup {
dog destroy
} -result {Hello, World!}
test method-1.9 {type methods must be qualified} -body {
type dog {
typemethod hello {} {
return "Hello"
}
method helloworld {} {
return "[hello], World!"
}
}
dog create spot
spot helloworld
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {invalid command name "hello"}
test method-1.11 {too few arguments} -body {
type dog {
method bark {volume} { }
}
dog create spot
spot bark
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {wrong # args: should be "spot bark volume"}
test method-1.13 {too many arguments} -body {
type dog {
method bark {volume} { }
}
dog create spot
spot bark really loud
} -cleanup {
dog destroy
} -returnCodes {
error
} -result {wrong # args: should be "spot bark volume"}
test method-1.14 {method args can't include type} -body {
type dog {
method foo {a type b} { }
}
} -returnCodes {
error
} -result {method foo's arglist may not contain "type" explicitly}
test method-1.15 {method args can't include self} -body {
type dog {
method foo {a self b} { }
}
} -returnCodes {
error
} -result {method foo's arglist may not contain "self" explicitly}
test method-1.16 {method args can span multiple lines} -body {
# This case caused an error at definition time in 0.9 because the
# arguments were included in a comment in the compile script, and
# the subsequent lines weren't commented.
type dog {
method foo {
a
b
} { }
}
} -cleanup {
dog destroy
} -result {::dog}
#-----------------------------------------------------------------------
# mymethod actually works
test mymethod-1.1 {run mymethod handler} -body {
type foo {
option -command {}
method runcmd {} {
eval [linsert $itcl_options(-command) end $self snarf]
return
}
}
type bar {
variable sub
constructor {args} {
set sub [foo fubar -command [mymethod Handler]]
return
}
method Handler {args} {
set ::RES $args
}
method test {} {
$sub runcmd
return
}
}
set ::RES {}
bar boogle
boogle test
set ::RES
} -cleanup {
bar destroy
foo destroy
} -result {::bar::fubar snarf}
#-----------------------------------------------------------------------
# myproc
test myproc-1.1 {myproc qualifies proc names} -body {
type dog {
proc foo {} {}
typemethod getit {} {
return [myproc foo]
}
}
dog getit
} -cleanup {
dog destroy
} -result {::dog::foo}
test myproc-1.2 {myproc adds arguments} -body {
type dog {
proc foo {} {}
typemethod getit {} {
return [myproc foo "a b"]
}
}
dog getit
} -cleanup {
dog destroy
} -result {::dog::foo {a b}}
test myproc-1.3 {myproc adds arguments} -body {
type dog {
proc foo {} {}
typemethod getit {} {
return [myproc foo "a b" c d]
}
}
dog getit
} -cleanup {
dog destroy
} -result {::dog::foo {a b} c d}
test myproc-1.4 {procs with selfns work} -body {
type dog {
variable datum foo
method qualify {} {
return [myproc getdatum $selfns]
}
proc getdatum {selfns} {
return [set ${selfns}::datum]
}
}
dog create spot
eval [spot qualify]
} -cleanup {
dog destroy
} -result {foo}
#-----------------------------------------------------------------------
# mytypemethod
test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body {
type dog {
typemethod this {} {}
typemethod a {} {
return [mytypemethod this]
}
typemethod b {} {
return [mytypemethod this x]
}
typemethod c {} {
return [mytypemethod this "x y"]
}
typemethod d {} {
return [mytypemethod this x y]
}
}
list [dog a] [dog b] [dog c] [dog d]
} -cleanup {
dog destroy
} -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

1210
pkgs/itcl4.2.0/tests/typeinfo.test Normal file
View File

File diff suppressed because it is too large Load Diff

556
pkgs/itcl4.2.0/tests/typeoption.test Normal file
View File

@@ -0,0 +1,556 @@
#---------------------------------------------------------------------
# TITLE:
# typeoption.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type proc, method, typemethod commands.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
interp alias {} type {} ::itcl::type
#-----------------------------------------------------------------------
# Options
test option-1.1 {options get default values} -body {
type dog {
option -color golden
}
dog create spot
spot cget -color
} -cleanup {
dog destroy
} -result {golden}
test option-1.2 {options can be set} -body {
type dog {
option -color golden
}
dog create spot
spot configure -color black
spot cget -color
} -cleanup {
dog destroy
} -result {black}
test option-1.3 {multiple options can be set} -body {
type dog {
option -color golden
option -akc 0
}
dog create spot
spot configure -color brown -akc 1
list [spot cget -color] [spot cget -akc]
} -cleanup {
dog destroy
} -result {brown 1}
test option-1.4 {options can be retrieved as instance variable} -body {
type dog {
option -color golden
option -akc 0
method listopts {} {
list $itcl_options(-color) $itcl_options(-akc)
}
}
dog create spot
spot configure -color black -akc 1
spot listopts
} -cleanup {
dog destroy
} -result {black 1}
test option-1.5 {options can be set as an instance variable} -body {
type dog {
option -color golden
option -akc 0
method setopts {} {
set itcl_options(-color) black
set itcl_options(-akc) 1
}
}
dog create spot
spot setopts
list [spot cget -color] [spot cget -akc]
} -cleanup {
dog destroy
} -result {black 1}
test option-1.6 {options can be set at creation time} -body {
type dog {
option -color golden
option -akc 0
}
dog create spot -color white -akc 1
list [spot cget -color] [spot cget -akc]
} -cleanup {
dog destroy
} -result {white 1}
test option-1.7 {undefined option: cget} -body {
type dog {
option -color golden
option -akc 0
}
dog create spot
spot cget -colour
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {unknown option "-colour"}
test option-1.8 {undefined option: configure} -body {
type dog {
option -color golden
option -akc 0
}
dog create spot
spot configure -colour blue
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {unknown option "-colour"}
test option-1.9 {options default to ""} -body {
type dog {
option -color
}
dog create spot
spot cget -color
} -cleanup {
dog destroy
} -result {<undefined>}
test option-1.10 {spaces allowed in option defaults} -body {
type dog {
option -breed "golden retriever"
}
dog fido
fido cget -breed
} -cleanup {
dog destroy
} -result {golden retriever}
test option-1.11 {brackets allowed in option defaults} -body {
type dog {
option -regexp {[a-z]+}
}
dog fido
fido cget -regexp
} -cleanup {
dog destroy
} -result {[a-z]+}
test option-2.1 {configure returns info, local options only} -body {
type dog {
option -color black
option -akc 1
}
dog create spot
spot configure -color red
spot configure -akc 0
lsort [spot configure]
} -cleanup {
dog destroy
} -result {{-akc akc Akc 1 0} {-color color Color black red}}
test option-2.2 {configure -opt returns info, local options only} -body {
type dog {
option -color black
option -akc 1
}
dog create spot
spot configure -color red
spot configure -color
} -cleanup {
dog destroy
} -result {-color color Color black red}
test option-2.3 {configure -opt returns info, explicit options} -body {
type papers {
option -akcflag 1
}
type dog {
option -color black
delegate option -akc to papers as -akcflag
constructor {args} {
set papers [papers create $self.papers]
}
destructor {
catch {$self.papers destroy}
}
}
dog create spot
spot configure -akc 0
spot configure -akc
} -cleanup {
dog destroy
papers destroy
} -result {-akc akc Akc 1 0}
test option-2.4 {configure -unknownopt} -body {
type papers {
option -akcflag 1
}
type dog {
option -color black
delegate option -akc to papers as -akcflag
constructor {args} {
set papers [papers create $self.papers]
}
destructor {
catch {$self.papers destroy}
}
}
dog create spot
spot configure -foo
} -returnCodes {
error
} -cleanup {
dog destroy
papers destroy
} -result {unknown option "-foo"}
test option-3.1 {set option resource name explicitly} -body {
type dog {
option {-tailcolor tailColor} black
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
} -result {-tailcolor tailColor TailColor black black}
test option-3.2 {set option class name explicitly} -body {
type dog {
option {-tailcolor tailcolor TailColor} black
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
} -result {-tailcolor tailcolor TailColor black black}
test option-3.3 {delegated option's names come from owner} -body {
type tail {
option -color black
}
type dog {
delegate option -tailcolor to tail as -color
constructor {args} {
set tail [tail fidotail]
}
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
tail destroy
} -result {-tailcolor tailcolor Tailcolor black black}
test option-3.4 {delegated option's resource name set explicitly} -body {
type tail {
option -color black
}
type dog {
delegate option {-tailcolor tailColor} to tail as -color
constructor {args} {
set tail [tail fidotail]
}
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
tail destroy
} -result {-tailcolor tailColor TailColor black black}
test option-3.5 {delegated option's class name set explicitly} -body {
type tail {
option -color black
}
type dog {
delegate option {-tailcolor tailcolor TailColor} to tail as -color
constructor {args} {
set tail [tail fidotail]
}
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
tail destroy
} -result {-tailcolor tailcolor TailColor black black}
test option-3.6 {delegated option's default comes from component} -body {
type tail {
option -color black
}
type dog {
delegate option -tailcolor to tail as -color
constructor {args} {
set tail [tail fidotail -color red]
}
}
dog fido
fido configure -tailcolor
} -cleanup {
dog destroy
tail destroy
} -result {-tailcolor tailcolor Tailcolor black red}
test option-4.1 {local option name must begin with hyphen} -body {
type dog {
option nohyphen
}
} -returnCodes {
error
} -result {bad option name "nohyphen", options must start with a "-"}
test option-4.2 {local option name must be lower case} -body {
type dog {
option -Upper
}
} -returnCodes {
error
} -result {bad option name "-Upper" , options must not contain uppercase characters}
test option-4.3 {local option name may not contain spaces} -body {
type dog {
option {"-with space"}
}
} -returnCodes {
error
} -result {bad option name "-with space", option names must not contain " "}
test option-4.4 {delegated option name must begin with hyphen} -body {
type dog {
delegate option nohyphen to tail
}
} -returnCodes {
error
} -result {bad delegated option name "nohyphen", options must start with a "-"}
test option-4.5 {delegated option name must be lower case} -body {
type dog {
delegate option -Upper to tail
}
} -returnCodes {
error
} -result {bad option name "-Upper" , options must not contain uppercase characters}
test option-4.6 {delegated option name may not contain spaces} -body {
type dog {
delegate option {"-with space"} to tail
}
} -returnCodes {
error
} -result {bad option name "-with space", option names must not contain " "}
test option-6.1a {itcl_options variable is always there} -body {
type dog {
variable dummy
}
dog spot
spot info vars itcl_options
} -cleanup {
dog destroy
} -result {itcl_options}
test option-6.2 {if no options, no options methods} -body {
type dog {
variable dummy
}
dog spot
spot info methods c*
} -cleanup {
dog destroy
} -result {}
#-----------------------------------------------------------------------
# option -validatemethod
test validatemethod-1.1 {Validate method is called} -body {
type dog {
variable flag 0
option -color \
-default black \
-validatemethod ValidateColor
method ValidateColor {option value} {
set flag 1
}
method getflag {} {
return $flag
}
}
dog fido -color brown
fido getflag
} -cleanup {
dog destroy
} -result {1}
test validatemethod-1.2 {Validate method gets correct arguments} -body {
type dog {
option -color \
-default black \
-validatemethod ValidateColor
method ValidateColor {option value} {
if {![string equal $option "-color"] ||
![string equal $value "brown"]} {
error "Expected '-color brown'"
}
}
}
dog fido -color brown
} -cleanup {
dog destroy
} -result {::fido}
test validatemethod-1.4 {Invalid -validatemethod causes error} -body {
type dog {
option -foo -default bar -validatemethod bogus
}
dog fido
fido configure -foo quux
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {invalid command name "bogus"}
test validatemethod-1.5 {hierarchical -validatemethod} -body {
type dog {
option -foo -default bar -validatemethod {Val Opt}
method {Val Opt} {option value} {
error "Dummy"
}
}
dog fido -foo value
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {Dummy}
#-----------------------------------------------------------------------
# option -readonly semantics
test optionreadonly-1.1 {Readonly options can be set at creation time} -body {
type dog {
option -color \
-default black \
-readonly true
}
dog fido -color brown
fido cget -color
} -cleanup {
dog destroy
} -result {brown}
test optionreadonly-1.2 {Readonly options can't be set after creation} -body {
type dog {
option -color \
-default black \
-readonly true
}
dog fido
fido configure -color brown
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {option "-color" can only be set at instance creation}
test optionreadonly-1.3 {Readonly options can't be set after creation} -body {
type dog {
option -color \
-default black \
-readonly true
}
dog fido -color yellow
fido configure -color brown
} -returnCodes {
error
} -cleanup {
dog destroy
} -result {option "-color" can only be set at instance creation}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

335
pkgs/itcl4.2.0/tests/typevariable.test Normal file
View File

@@ -0,0 +1,335 @@
#---------------------------------------------------------------------
# TITLE:
# typefunction.test
#
# AUTHOR:
# Arnulf Wiedemann with a lot of code form the snit tests by
# Will Duquette
#
# DESCRIPTION:
# Test cases for ::itcl::type proc, method, typemethod commands.
# Uses the ::tcltest:: harness.
#
# The tests assume tcltest 2.2
#-----------------------------------------------------------------------
package require tcltest 2.2
namespace import ::tcltest::*
::tcltest::loadTestedCommands
package require itcl
interp alias {} type {} ::itcl::type
#-----------------------------------------------------------------------
# Type variables
test typevariable-1.2 {undefined typevariables are OK} -body {
type dog {
typevariable theValue
method tset {value} {
set theValue $value
}
method tget {} {
return $theValue
}
}
dog create spot
dog create fido
spot tset Howdy
list [spot tget] [fido tget] [set ::dog::theValue]
} -cleanup {
dog destroy
} -result {Howdy Howdy Howdy}
test typevariable-1.3 {predefined typevariables are OK} -body {
type dog {
typevariable greeting Hello
method tget {} {
return $greeting
}
}
dog create spot
dog create fido
list [spot tget] [fido tget] ;# FIXME [set ::dog::greeting]
} -cleanup {
dog destroy
} -result {Hello Hello}
test typevariable-1.4 {typevariables can be arrays} -body {
type dog {
typevariable greetings
method fill {} {
set greetings(a) Hi
set greetings(b) Howdy
}
}
dog create spot
spot fill
list $::dog::greetings(a) $::dog::greetings(b)
} -cleanup {
dog destroy
} -result {Hi Howdy}
test typevariable-1.5 {typevariables can used in typemethods} -body {
type dog {
typevariable greetings Howdy
typemethod greet {} {
return $greetings
}
}
dog greet
} -cleanup {
dog destroy
} -result {Howdy}
test typevariable-1.6 {typevariables can used in procs} -body {
type dog {
typevariable greetings Howdy
method greet {} {
return [realGreet]
}
proc realGreet {} {
return $greetings
}
}
dog create spot
spot greet
} -cleanup {
dog destroy
} -result {Howdy}
test typevariable-1.7 {mytypevar qualifies typevariables} -body {
type dog {
method tvname {name} {
mytypevar $name
}
}
dog create spot
spot tvname myvar
} -cleanup {
dog destroy
} -result {::dog::myvar}
test typevariable-1.8 {typevariable with too many initializers throws an error} -body {
type dog {
typevariable color dark brown
}
} -returnCodes {
error
} -result {wrong # args: should be "typevariable varname ?init?"}
test typevariable-1.9 {typevariable with too many initializers throws an error} -body {
type dog {
typevariable color -array dark brown
}
set result
} -returnCodes {
error
} -result {wrong # args: should be "typevariable varname ?init|-array init?"}
test typevariable-1.10 {typevariable can initialize array variables} -body {
type dog {
typevariable data -array {
family jones
color brown
}
typemethod getdata {item} {
return $data($item)
}
}
list [dog getdata family] [dog getdata color]
} -cleanup {
dog destroy
} -result {jones brown}
#-----------------------------------------------------------------------
# instance variable
test ivariable-1.1 {myvar qualifies instance variables} -body {
type dog {
method vname {name} {
myvar $name
}
}
dog create spot
spot vname somevar
} -cleanup {
dog destroy
} -match glob -result {::itcl::internal::variables::*::dog::somevar}
test ivariable-1.2 {undefined instance variables are OK} -body {
type dog {
variable greeting
method setgreeting {value} {
set greeting $value
}
method getgreeting {} {
return $greeting
}
}
set spot [dog create spot]
spot setgreeting Hey
dog create fido
fido setgreeting Howdy
list [spot getgreeting] [fido getgreeting] [set ::itcl::internal::variables[info object namespace spot]::dog::greeting]
} -cleanup {
dog destroy
} -result {Hey Howdy Hey}
test ivariable-1.3 {instance variables are destroyed automatically} -body {
type dog {
variable greeting
constructor {args} {
set greeting Hi
}
}
dog create spot
set ns [info object namespace spot]
set g1 [set ::itcl::internal::variables${ns}::dog::greeting]
spot destroy
list $g1 [info exists ::itcl::internal::variables${ns}::dog::greeting]
} -cleanup {
dog destroy
} -result {Hi 0}
test ivariable-1.4 {defined instance variables need not be declared} -body {
type dog {
variable greetings
method put {} {
set greetings Howdy
}
method get {} {
return $greetings
}
}
dog create spot
spot put
spot get
} -cleanup {
dog destroy
} -result {Howdy}
test ivariable-1.5 {instance variables can be arrays} -body {
type dog {
variable greetings
method fill {} {
set greetings(a) Hi
set greetings(b) Howdy
}
method vname {} {
return [myvar greetings]
}
}
dog create spot
spot fill
list [set [spot vname](a)] [set [spot vname](b)]
} -cleanup {
dog destroy
} -result {Hi Howdy}
test ivariable-1.6 {instance variables can be initialized in the definition} -body {
type dog {
variable greetings {Hi Howdy}
variable empty {}
method list {} {
list $greetings $empty
}
}
dog create spot
spot list
} -cleanup {
dog destroy
} -result {{Hi Howdy} {}}
test ivariable-1.9 {procs which define selfns see instance variables} -body {
type dog {
variable greeting Howdy
method caller {} {
return [callee $selfns]
}
proc callee {selfns} {
return [set ${selfns}::greeting]
}
}
dog create spot
spot caller
} -cleanup {
dog destroy
} -result {Howdy}
test ivariable-1.11 {variable with too many initializers throws an error} -body {
type dog {
variable color dark brown
}
} -returnCodes {
error
} -result {wrong # args: should be "variable name ?init?"}
test ivariable-1.12 {variable with too many initializers throws an error} -body {
type dog {
variable color -array dark brown
}
} -returnCodes {
error
} -result {wrong # args: should be "variable varname ?init|-array init?"}
test ivariable-1.13 {variable can initialize array variables} -body {
type dog {
variable data -array {
family jones
color brown
}
method getdata {item} {
return $data($item)
}
}
dog spot
list [spot getdata family] [spot getdata color]
} -cleanup {
dog destroy
} -result {jones brown}
#---------------------------------------------------------------------
# Clean up
cleanupTests
return

Some files were not shown because too many files have changed in this diff Show More