├── .fossil-settings ├── crlf-glob ├── ignore-glob └── manifest ├── .github └── workflows │ └── linux-build.yml ├── .project ├── ChangeLog ├── Makefile.in ├── README ├── TODO ├── aclocal.m4 ├── configure ├── configure.ac ├── doc ├── Class.3 ├── List.3 ├── Object.3 ├── Preserve.3 ├── RegisterC.3 ├── Stack.3 ├── body.n ├── class.n ├── code.n ├── configbody.n ├── delete.n ├── ensemble.n ├── find.n ├── is.n ├── itcl.n ├── itclcomponent.n ├── itcldelegate.n ├── itclextendedclass.n ├── itcloption.n ├── itclvars.n ├── itclwidget.n ├── license.terms ├── local.n ├── man.macros └── scope.n ├── generic ├── itcl.decls ├── itcl.h ├── itcl2TclOO.c ├── itcl2TclOO.h ├── itclBase.c ├── itclBuiltin.c ├── itclClass.c ├── itclCmd.c ├── itclDecls.h ├── itclEnsemble.c ├── itclHelpers.c ├── itclInfo.c ├── itclInt.h ├── itclIntDecls.h ├── itclLinkage.c ├── itclMethod.c ├── itclMigrate2TclCore.c ├── itclMigrate2TclCore.h ├── itclObject.c ├── itclParse.c ├── itclResolve.c ├── itclStubInit.c ├── itclStubLib.c ├── itclStubs.c ├── itclTclIntStubsFcn.c ├── itclTclIntStubsFcn.h ├── itclTestRegisterC.c └── itclUtil.c ├── itclConfig.sh.in ├── itclWidget ├── Makefile.in ├── aclocal.m4 ├── configure ├── configure.ac ├── doc │ └── itclWidget.n ├── generic │ ├── itclWidgetBase.c │ ├── itclWidgetBuiltin.c │ ├── itclWidgetCmd.c │ ├── itclWidgetInfo.c │ ├── itclWidgetInt.h │ ├── itclWidgetObject.c │ ├── itclWidgetParse.c │ ├── itclWidgetStubInit.c │ └── itclWidgetStubLib.c ├── license.terms ├── pkgIndex.tcl.in ├── tclconfig │ ├── install-sh │ └── tcl.m4 └── tests │ ├── all.tcl │ ├── itclwidget.test │ ├── widgetadaptor.test │ └── widgetclass.test ├── library ├── itcl.tcl ├── itclHullCmds.tcl ├── itclWidget.tcl └── test_Itcl_CreateObject.tcl ├── license.terms ├── pkgIndex.tcl.in ├── releasenotes.txt ├── tests-perf └── itcl-basic.perf.tcl ├── tests ├── all.tcl ├── basic.test ├── body.test ├── chain.test ├── delete.test ├── eclasscomponent.test ├── ensemble.test ├── general1.test ├── helpers.tcl ├── import.test ├── info.test ├── inherit.test ├── interp.test ├── local.test ├── methods.test ├── mkindex.itcl ├── mkindex.test ├── namespace.test ├── protection.test ├── scope.test ├── sfbugs.test ├── tclIndex ├── typeclass.test ├── typedelegation.test ├── typefunction.test ├── typeinfo.test ├── typeoption.test ├── typevariable.test ├── widgetadaptor.test └── widgetclass.test ├── tools └── genStubs.tcl └── win ├── dllEntryPoint.c ├── gitmanifest.in ├── itcl.rc ├── itclUuid.h.in ├── makefile.vc ├── nmakehlp.c ├── rules-ext.vc ├── rules.vc ├── svnmanifest.in ├── targets.vc ├── toaster.bmp └── x86_64-w64-mingw32-nmakehlp.exe /.fossil-settings/crlf-glob: -------------------------------------------------------------------------------- 1 | win/*.vc 2 | -------------------------------------------------------------------------------- /.fossil-settings/ignore-glob: -------------------------------------------------------------------------------- 1 | *.a 2 | *.dll 3 | *.dylib 4 | *.dylib.E 5 | *.exe 6 | *.exp 7 | *.la 8 | *.lib 9 | *.lo 10 | *.o 11 | *.obj 12 | *.pdb 13 | *.res 14 | *.sl 15 | *.so 16 | Makefile 17 | autom4te.cache 18 | config.cache 19 | config.log 20 | config.status 21 | itclConfig.sh 22 | pkgIndex.tcl 23 | versions.vc 24 | version.vc 25 | libitcl.vfs 26 | libitcl_*.zip 27 | html 28 | win/nmakehlp.out 29 | win/nmhlp-out.txt 30 | -------------------------------------------------------------------------------- /.fossil-settings/manifest: -------------------------------------------------------------------------------- 1 | u 2 | -------------------------------------------------------------------------------- /.github/workflows/linux-build.yml: -------------------------------------------------------------------------------- 1 | name: Linux 2 | on: [push] 3 | defaults: 4 | run: 5 | shell: bash 6 | jobs: 7 | build: 8 | runs-on: ubuntu-24.04 9 | strategy: 10 | matrix: 11 | compiler: 12 | - "gcc" 13 | - "g++" 14 | - "clang" 15 | steps: 16 | - name: Checkout 17 | uses: actions/checkout@v4 18 | - name: Setup Environment (compiler=${{ matrix.compiler }}) 19 | run: | 20 | sudo apt-get install tcl8.6-dev 21 | mkdir "$HOME/install dir" 22 | curl https://core.tcl-lang.org/tclconfig/tarball/main/tclconfig.tar.gz >tclconfig.tar.gz 23 | tar xfz tclconfig.tar.gz 24 | echo "CFGOPT=--with-tcl=/usr/lib/tcl8.6" >> $GITHUB_ENV 25 | echo "CC=$COMPILER" >> $GITHUB_ENV 26 | env: 27 | COMPILER: ${{ matrix.compiler }} 28 | OPTS: ${{ matrix.compiler }} 29 | - name: Configure 30 | run: | 31 | ./configure $CFGOPT "--prefix=$HOME/install dir" "--exec-prefix=$HOME/install dir" || { 32 | cat config.log 33 | echo "::error::Failure during Configure" 34 | exit 1 35 | } 36 | - name: Build 37 | run: | 38 | make || { 39 | echo "::error::Failure during Build" 40 | exit 1 41 | } 42 | - name: Run Tests 43 | run: | 44 | make test || { 45 | echo "::error::Failure during Test" 46 | exit 1 47 | } 48 | env: 49 | ERROR_ON_FAILURES: 1 50 | - name: Test-Drive Installation 51 | run: | 52 | make install || { 53 | echo "::error::Failure during Install" 54 | exit 1 55 | } 56 | - name: Create Distribution Package 57 | run: | 58 | make dist || { 59 | echo "::error::Failure during Distribute" 60 | exit 1 61 | } 62 | -------------------------------------------------------------------------------- /.project: -------------------------------------------------------------------------------- 1 | 2 | 3 | itcl 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | README: Itcl 2 | 3 | This is the 4.3.3 source distribution of Itcl, an object oriented 4 | extension for Tcl. Itcl releases are available from Sourceforge at: 5 | 6 | https://sourceforge.net/projects/incrtcl/files/%5Bincr%20Tcl_Tk%5D-4-source/ 7 | 8 | 1. Introduction 9 | 10 | This directory contains the source code, documentation, and test scripts 11 | for the itcl extension. This version is the next major release to follow 12 | Itcl 3.4. This version claims to be script level compatible with Itcl 3.4. 13 | 14 | Itcl is a freely-available open source package as in the past. 15 | You can do virtually anything you like with it, such as modifying it, 16 | redistributing it, and selling it either in whole or in part. See the file 17 | "license.terms" for complete information. 18 | 19 | 2. Compiling and Installing. 20 | 21 | Itcl is built in much the same way that Tcl itself is. Once you have 22 | a Tcl build environment set up, you should be able to simply 23 | enter the commands: 24 | 25 | cd itcl 26 | ./configure 27 | make all 28 | make test 29 | make install 30 | 31 | 3. Mailing lists 32 | 33 | SourceForge hosts a mailing list, incrtcl-users to discuss issues with using 34 | and developing Itcl. For more information and to subscribe, visit 35 | 36 | http://sourceforge.net/projects/incrtcl 37 | 38 | and go to the 'Mailing Lists' page. 39 | 40 | 4. Support 41 | 42 | We are very interested in receiving bug reports, patches, and suggestions 43 | for improvements. We prefer that you send this information to us via the 44 | bug database, rather than emailing us directly. The bug database is at: 45 | 46 | https://core.tcl.tk/itcl/ticket 47 | 48 | We will log and follow-up on each bug, although we cannot promise a 49 | specific turn-around time. Enhancements, reported via the Feature 50 | Requests form at the same web site, may take longer and may not happen 51 | at all unless there is widespread support for them. 52 | 53 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | This is the TODO list: 2 | 3 | - finish the feature list of ::itcl::extendedclass 4 | 5 | - describe the API's for ::itcl::extendedclass 6 | 7 | - enhance documentation (all parts) 8 | 9 | - maybe: add some demo examples for preferred use of ::itcl::extendedclass 10 | -------------------------------------------------------------------------------- /aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /doc/Class.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_CreateClass 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_CreateClass, Itcl_DeleteClass, Itcl_FindClass, Itcl_IsClass, Itcl_IsClassNamespace \- Manipulate classes. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | int 18 | \fBItcl_CreateClass\fR(\fIinterp, path, info, rPtr\fR) 19 | 20 | int 21 | \fBItcl_DeleteClass\fR(\fIinterp, cdefnPtr\fR) 22 | 23 | ItclClass * 24 | \fBItcl_FindClass\fR(\fIinterp, path, autoload\fR) 25 | 26 | int 27 | \fBItcl_IsClass\fR(\fIcmd\fR) 28 | 29 | int 30 | \fBItcl_IsClassNamespace\fR(\fInamesp\fR) 31 | .fi 32 | .SH ARGUMENTS 33 | .AP Tcl_Interp *interp in 34 | Interpreter to modify. 35 | .AP "const char" *path in 36 | Path of the class. 37 | .AP ItclObjectInfo *info in 38 | TODO. 39 | .AP ItclClass **rPtr in/out 40 | The address of the pointer to modify. 41 | .AP ItclClass *cdefnPtr in 42 | Pointer to class info struct. 43 | .AP int autoload in 44 | Flag value for if the class should be autoloaded 45 | .AP Tcl_Command cmd in 46 | Command to check. 47 | .AP Tcl_Namespace *namesp in 48 | Namespace to check. 49 | .BE 50 | 51 | .SH DESCRIPTION 52 | .PP 53 | 54 | .SH KEYWORDS 55 | class, find 56 | -------------------------------------------------------------------------------- /doc/List.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_InitList 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_InitList, Itcl_DeleteList, Itcl_CreateListElem, Itcl_DeleteListElem, Itcl_InsertList, Itcl_InsertListElem, Itcl_AppendList, Itcl_AppendListElem, Itcl_SetListValue \- Manipulate an Itcl list object. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | void 18 | \fBItcl_InitList\fR(\fIlist\fR) 19 | 20 | void 21 | \fBItcl_DeleteList\fR(\fIlist\fR) 22 | 23 | Itcl_ListElem * 24 | \fBItcl_CreateListElem\fR(\fIlist\fR) 25 | 26 | Itcl_ListElem * 27 | \fBItcl_DeleteListElem\fR(\fIelem\fR) 28 | 29 | Itcl_ListElem * 30 | \fBItcl_InsertList\fR(\fIlist, clientData\fR) 31 | 32 | Itcl_ListElem * 33 | \fBItcl_InsertListElem\fR(\fIelem, clientData\fR) 34 | 35 | Itcl_ListElem * 36 | \fBItcl_AppendList\fR(\fIlist, clientData\fR) 37 | 38 | Itcl_ListElem * 39 | \fBItcl_AppendListElem\fR(\fIelem, clientData\fR) 40 | 41 | void 42 | \fBItcl_SetListValue\fR(\fIelem, clientData\fR) 43 | .fi 44 | .SH ARGUMENTS 45 | .AP Itcl_List *list in 46 | List info structure. 47 | .AP Itcl_ListElem *elem in 48 | List element info structure. 49 | .AP void *clientData in 50 | Arbitrary one-word value to save in the list. 51 | .BE 52 | 53 | .SH DESCRIPTION 54 | .PP 55 | 56 | .SH KEYWORDS 57 | list 58 | 59 | -------------------------------------------------------------------------------- /doc/Object.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_CreateObject 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_CreateObject, Itcl_DeleteObject, Itcl_FindObject, Itcl_IsObject, Itcl_IsObjectIsa \- Manipulate an class instance. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | void 18 | \fBItcl_PreserveData\fR(\fIcdata\fR) 19 | 20 | void 21 | \fBItcl_ReleaseData\fR(\fIcdata\fR) 22 | 23 | void 24 | \fBItcl_EventuallyFree\fR(\fIcdata, fproc\fR) 25 | .fi 26 | .SH ARGUMENTS 27 | .AP Tcl_FreeProc *fproc in 28 | Address of function to call when the block is to be freed. 29 | .AP void *clientData in 30 | Arbitrary one-word value. 31 | .BE 32 | 33 | .SH DESCRIPTION 34 | .PP 35 | 36 | .SH KEYWORDS 37 | free, memory 38 | 39 | -------------------------------------------------------------------------------- /doc/Preserve.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_PreserveData 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_Alloc, Itcl_Free, Itcl_PreserveData, Itcl_ReleaseData, Itcl_EventuallyFree \- Manipulate an Itcl list object. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | void * 18 | \fBItcl_Alloc\fR(\fIsize\fR) 19 | 20 | void 21 | \fBItcl_PreserveData\fR(\fIptr\fR) 22 | 23 | void 24 | \fBItcl_ReleaseData\fR(\fIptr\fR) 25 | 26 | void 27 | \fBItcl_EventuallyFree\fR(\fIptr, fproc\fR) 28 | 29 | void 30 | \fBItcl_Free\fR(\fIptr\fR) 31 | .fi 32 | .SH ARGUMENTS 33 | .AP size_t size in 34 | Number of bytes to allocate. 35 | .AP void *ptr in 36 | Pointer value allocated by \fBItcl_Alloc\fR. 37 | .AP Tcl_FreeProc *fproc in 38 | Address of function to call when the block is to be freed. 39 | .BE 40 | 41 | .SH DESCRIPTION 42 | .PP 43 | These procedures are used to allocate and release memory, especially blocks 44 | of memory that will be used by multiple independent modules. They are similar 45 | in function to the routines in the public Tcl interface, \fBTcl_Alloc\fR, 46 | \fBTcl_Free\fR, \fBTcl_Preserve\fR, \fBTcl_Release\fR, and 47 | \fBTcl_EventuallyFree\fR. The Tcl routines suffer from issues with 48 | performance scaling as the number of blocks managed grows large. The facilities 49 | of Itcl encounter these performance scaling issues and require an 50 | alternative that does not suffer from them. 51 | .PP 52 | \fBItcl_Alloc\fR returns an untyped pointer to an allocated block 53 | of memory of at least \fIsize\fR bytes. All \fIsize\fR bytes are 54 | initialized to zero. 55 | .PP 56 | A module calls \fBItcl_PreserveData\fR on a pointer \fIptr\fR 57 | allocated by \fBItcl_Alloc\fR to prevent deallocation of that memory while 58 | the module remains interested in it. 59 | .PP 60 | A module calls \fBItcl_ReleaseData\fR on a pointer \fIptr\fR previously 61 | preserved by \fBItcl_PreserveData\fR to indicate the module no longer has 62 | an interest in the block of memory, and will not be disturbed by its 63 | deallocation. 64 | .PP 65 | \fBItcl_EventuallyFree\fR is called on a pointer \fIptr\fR allocated by 66 | \fBItcl_Alloc\fR to register a deallocation routine \fIfproc\fR to be 67 | called when the number of calls to \fBItcl_ReleaseData\fR on \fIptr\fR 68 | matches the number of calls to \fBItcl_PreserveData\fR on \fIptr\fR. This 69 | condition indicates all modules have ended their interest in the block 70 | of memory and a call to \fIfproc\fR with argument \fIptr\fR will deallocate 71 | the memory that no module needs anymore. 72 | .PP 73 | \fBItcl_Free\fR is a deallocation routine for a \fIptr\fR value allocated 74 | by \fBItcl_Alloc\fR. It may be called on any \fIptr\fR with no history of 75 | an \fBItcl_PreserveData\fR call unmatched by an \fBItcl_ReleaseData\fR 76 | call. It is best used as an \fIfproc\fR argument to \fBItcl_EventuallyFree\fR 77 | or as a routine called from within such an \fIfproc\fR routine. It can also 78 | be used to deallocate a \fIptr\fR value when it can be assured that value 79 | has never been passed to \fBItcl_PreserveData\fR or \fBItcl_EventuallyFree\fR. 80 | 81 | .SH KEYWORDS 82 | free, memory 83 | 84 | -------------------------------------------------------------------------------- /doc/RegisterC.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_RegisterC 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_RegisterC, Itcl_RegisterObjC, Itcl_RegisterObjC2, Itcl_FindC, Itcl_FindC2 \- Associate a symbolic name with a C procedure. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | int 18 | \fBItcl_RegisterC\fR(\fIinterp, cmdName, argProc, clientData, deleteProc\fR) 19 | 20 | int 21 | \fBItcl_RegisterObjC\fR(\fIinterp, cmdName, objProc, clientData, deleteProc\fR) 22 | 23 | int 24 | \fBItcl_RegisterObjC2\fR(\fIinterp, cmdName, objProc2, clientData, deleteProc\fR) 25 | 26 | int 27 | \fBItcl_FindC\fR(\fIinterp, cmdName, argProcPtr, objProcPtr, cDataPtr\fR) 28 | 29 | int 30 | \fBItcl_FindC2\fR(\fIinterp, cmdName, objProc2Ptr, cDataPtr\fR) 31 | .fi 32 | .SH ARGUMENTS 33 | .AP Tcl_Interp *interp in 34 | Interpreter in which to create new command. 35 | .AP "const char" *cmdName in 36 | Name of command. 37 | .AP Tcl_CmdProc *argProc in 38 | Implementation of new command: \fIargProc\fR will be called whenever 39 | .AP Tcl_CmdProc **argProcPtr in/out 40 | The Tcl_CmdProc * to receive the pointer. Can be NULL. 41 | .AP Tcl_ObjCmdProc *objProc in 42 | Implementation of the new command: \fIobjProc\fR will be called whenever 43 | .AP Tcl_ObjCmdProc2 *objProc2 in 44 | Implementation of the new command: \fIobjProc2\fR will be called whenever 45 | .AP Tcl_ObjCmdProc **objProcPtr in/out 46 | The Tcl_ObjCmdProc * to receive the pointer. 47 | .AP Tcl_ObjCmdProc2 **objProc2Ptr in/out 48 | The Tcl_ObjCmdProc2 * to receive the pointer. 49 | .AP void *clientData in 50 | Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. 51 | .AP void **cDataPtr in/out 52 | The void * to receive the pointer. 53 | .AP Tcl_CmdDeleteProc *deleteProc in 54 | Procedure to call before \fIcmdName\fR is deleted from the interpreter; 55 | allows for command-specific cleanup. If NULL, then no procedure is 56 | called before the command is deleted. 57 | .BE 58 | 59 | .SH DESCRIPTION 60 | .PP 61 | Used to associate a symbolic name with an (argc,argv) C procedure 62 | that handles a Tcl command. Procedures that are registered in this 63 | manner can be referenced in the body of an [incr Tcl] class 64 | definition to specify C procedures to acting as methods/procs. 65 | Usually invoked in an initialization routine for an extension, 66 | called out in Tcl_AppInit() at the start of an application. 67 | .PP 68 | Each symbolic procedure can have an arbitrary client data value 69 | associated with it. This value is passed into the command 70 | handler whenever it is invoked. 71 | .PP 72 | A symbolic procedure name can be used only once for a given style 73 | (arg/obj) handler. If the name is defined with an arg-style 74 | handler, it can be redefined with an obj-style handler; or if 75 | the name is defined with an obj-style handler, it can be redefined 76 | with an arg-style handler. In either case, any previous client 77 | data is discarded and the new client data is remembered. However, 78 | if a name is redefined to a different handler of the same style, 79 | this procedure returns an error. 80 | .PP 81 | Returns TCL_OK on success, or TCL_ERROR (along with an error message 82 | in interp->result) if anything goes wrong. 83 | .PP 84 | C procedures can be integrated into an \fB[incr\ Tcl]\fR class 85 | definition to implement methods, procs, and the "config" code 86 | for public variables. Any body that starts with "\fB@\fR" 87 | is treated as the symbolic name for a C procedure. 88 | .PP 89 | Symbolic names are established by registering procedures via 90 | \fBItcl_RegisterObjC()\fR or \fBItcl_RegisterObjC2()\fR or 91 | \fBItcl_RegisterC()\fR. This is usually done in the \fBTcl_AppInit()\fR 92 | procedure, which is automatically called when the interpreter starts up. 93 | In the following example, the procedure \fCMy_FooObjCmd()\fR is registered 94 | with the symbolic name "foo". This procedure can be referenced in 95 | the \fBbody\fR command as "\fC@foo\fR". 96 | .CS 97 | int 98 | Tcl_AppInit(interp) 99 | Tcl_Interp *interp; /* Interpreter for application. */ 100 | { 101 | if (Itcl_Init(interp) == TCL_ERROR) { 102 | return TCL_ERROR; 103 | } 104 | 105 | if (Itcl_RegisterObjC(interp, "foo", My_FooObjCmd) != TCL_OK) { 106 | return TCL_ERROR; 107 | } 108 | } 109 | .CE 110 | C procedures are implemented just like ordinary Tcl commands. 111 | See the \fBCrtCommand\fR man page for details. Within the procedure, 112 | class data members can be accessed like ordinary variables 113 | using \fBTcl_SetVar()\fR, \fBTcl_GetVar()\fR, \fBTcl_TraceVar()\fR, 114 | etc. Class methods and procs can be executed like ordinary commands 115 | using \fBTcl_Eval()\fR. \fB[incr\ Tcl]\fR makes this possible by 116 | automatically setting up the context before executing the C procedure. 117 | .PP 118 | This scheme provides a natural migration path for code development. 119 | Classes can be developed quickly using Tcl code to implement the 120 | bodies. An entire application can be built and tested. When 121 | necessary, individual bodies can be implemented with C code to 122 | improve performance. 123 | .PP 124 | See the Archetype class in \fB[incr\ Tk]\fR for an example of how this 125 | C linking method is used. 126 | 127 | .SH "SEE ALSO" 128 | Tcl_CreateCommand, Tcl_CreateObjCommand 129 | 130 | .SH KEYWORDS 131 | class, object 132 | 133 | -------------------------------------------------------------------------------- /doc/Stack.3: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH Itcl_InitStack 3 3.0 itcl "[incr\ Tcl] Library Procedures" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | Itcl_InitStack, Itcl_DeleteStack, Itcl_PushStack, Itcl_PopStack, Itcl_PeekStack, Itcl_GetStackValue, Itcl_GetStackSize \- Manipulate an Itcl stack object. 13 | .SH SYNOPSIS 14 | .nf 15 | \fB#include \fR 16 | 17 | int 18 | \fBItcl_InitStack\fR(\fIstack\fR) 19 | 20 | int 21 | \fBItcl_DeleteStack\fR(\fIstack\fR) 22 | 23 | int 24 | \fBItcl_PushStack\fR(\fIcdata, stack\fR) 25 | 26 | void * 27 | \fBItcl_PopStack\fR(\fIstack\fR) 28 | 29 | void * 30 | \fBItcl_PeekStack\fR(\fIstack\fR) 31 | 32 | void * 33 | \fBItcl_GetStackValue\fR(\fIstack, pos\fR) 34 | 35 | int 36 | \fBItcl_GetStackSize\fR(\fIstack\fR) 37 | .fi 38 | .SH ARGUMENTS 39 | .AP Itcl_Stack *stack in 40 | Stack info structure. 41 | .AP int pos in 42 | position in stack order from the top. 43 | .AP void *clientData in 44 | Arbitrary one-word value to save in the stack. 45 | .BE 46 | 47 | .SH DESCRIPTION 48 | .PP 49 | \fBItcl_InitStack\fR initializes a stack structure and \fBItcl_DeleteStack\fR 50 | deletes it. \fBItcl_PushStack\fR pushes the \fIcdata\fR value onto the stack. 51 | \fBItcl_PopStack\fR removes and returns the top most \fIcdata\fR value. 52 | \fBItcl_PeekStack\fR returns the top most value, but does not remove it. 53 | \fBItcl_GetStackValue\fR gets a value at some index within the stack. Index 54 | "0" is the first value pushed onto the stack. \fBItcl_GetStackSize\fR 55 | returns the count of entries on the stack. 56 | 57 | .SH KEYWORDS 58 | stack 59 | 60 | -------------------------------------------------------------------------------- /doc/body.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH body n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::body \- change the body for a class method/proc 13 | .SH SYNOPSIS 14 | \fBitcl::body \fIclassName\fB::\fIfunction args body\fR 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBbody\fR command is used outside of an \fB[incr\ Tcl]\fR 20 | class definition to define or redefine the body of a class 21 | method or proc. This facility allows a class definition 22 | to have separate "interface" and "implementation" parts. 23 | The "interface" part is a \fBclass\fR command with declarations 24 | for methods, procs, instance variables and common variables. 25 | The "implementation" part is a series of \fBbody\fR and 26 | \fBconfigbody\fR commands. If the "implementation" part 27 | is kept in a separate file, it can be sourced again and 28 | again as bugs are fixed, to support interactive development. 29 | When using the "tcl" mode in the \fBemacs\fR editor, the 30 | "interface" and "implementation" parts can be kept in the 31 | same file; as bugs are fixed, individual bodies can be 32 | highlighted and sent to the test application. 33 | .PP 34 | The name "\fIclassName\fB::\fIfunction\fR" 35 | identifies the method/proc being changed. 36 | .PP 37 | If an \fIargs\fR list was specified when the \fIfunction\fR was 38 | defined in the class definition, the \fIargs\fR list for the 39 | \fBbody\fR command must match in meaning. Variable names 40 | can change, but the argument lists must have the same required 41 | arguments and the same default values for optional arguments. 42 | The special \fBargs\fR argument acts as a wildcard when included 43 | in the \fIargs\fR list in the class definition; it will match 44 | zero or more arguments of any type when the body is redefined. 45 | .PP 46 | If the \fIbody\fR string starts with "\fB@\fR", it is treated 47 | as the symbolic name for a C procedure. The \fIargs\fR list 48 | has little meaning for the C procedure, except to document 49 | the expected usage. (The C procedure is not guaranteed to 50 | use arguments in this manner.) If \fIbody\fR does not start 51 | with "\fB@\fR", it is treated as a Tcl command script. When 52 | the function is invoked, command line arguments are matched 53 | against the \fIargs\fR list, and local variables are created 54 | to represent each argument. This is the usual behavior for 55 | a Tcl-style proc. 56 | .PP 57 | Symbolic names for C procedures are established by registering 58 | procedures via \fBItcl_RegisterObjC()\fR. This is usually done 59 | in the \fBTcl_AppInit()\fR procedure, which is automatically called 60 | when the interpreter starts up. In the following example, 61 | the procedure \fCMy_FooObjCmd()\fR is registered with the 62 | symbolic name "foo". This procedure can be referenced in 63 | the \fBbody\fR command as "\fC@foo\fR". 64 | .CS 65 | int 66 | Tcl_AppInit(interp) 67 | Tcl_Interp *interp; /* Interpreter for application. */ 68 | { 69 | if (Itcl_Init(interp) == TCL_ERROR) { 70 | return TCL_ERROR; 71 | } 72 | 73 | if (Itcl_RegisterObjC(interp, "foo", My_FooObjCmd) != TCL_OK) { 74 | return TCL_ERROR; 75 | } 76 | } 77 | .CE 78 | 79 | .SH EXAMPLE 80 | In the following example, a "File" class is defined to represent 81 | open files. The method bodies are included below the class 82 | definition via the \fBbody\fR command. Note that the bodies 83 | of the constructor/destructor must be included in the class 84 | definition, but they can be redefined via the \fBbody\fR command 85 | as well. 86 | .CS 87 | itcl::class File { 88 | private variable fid "" 89 | constructor {name access} { 90 | set fid [open $name $access] 91 | } 92 | destructor { 93 | close $fid 94 | } 95 | 96 | method get {} 97 | method put {line} 98 | method eof {} 99 | } 100 | 101 | itcl::body File::get {} { 102 | return [gets $fid] 103 | } 104 | itcl::body File::put {line} { 105 | puts $fid $line 106 | } 107 | itcl::body File::eof {} { 108 | return [::eof $fid] 109 | } 110 | 111 | # 112 | # See the File class in action: 113 | # 114 | File x /etc/passwd "r" 115 | while {![x eof]} { 116 | puts "=> [x get]" 117 | } 118 | itcl::delete object x 119 | .CE 120 | 121 | .SH KEYWORDS 122 | class, object, procedure 123 | -------------------------------------------------------------------------------- /doc/code.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH code n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::code \- capture the namespace context for a code fragment 13 | .SH SYNOPSIS 14 | \fBitcl::code \fR?\fB-namespace \fIname\fR? \fIcommand \fR?\fIarg arg ...\fR? 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | Creates a scoped value for the specified \fIcommand\fR and its 20 | associated \fIarg\fR arguments. A scoped value is a list with three 21 | elements: the "\fC@scope\fR" keyword, a namespace context, 22 | and a value string. For example, the command 23 | .CS 24 | namespace foo { 25 | code puts "Hello World!" 26 | } 27 | .CE 28 | produces the scoped value: 29 | .CS 30 | @scope ::foo {puts {Hello World!}} 31 | .CE 32 | Note that the \fBcode\fR command captures the current namespace 33 | context. If the \fB-namespace\fR flag is specified, then the 34 | current context is ignored, and the \fIname\fR string is used 35 | as the namespace context. 36 | .PP 37 | Extensions like Tk execute ordinary code fragments in the global 38 | namespace. A scoped value captures a code fragment together with 39 | its namespace context in a way that allows it to be executed 40 | properly later. It is needed, for example, to wrap up code fragments 41 | when a Tk widget is used within a namespace: 42 | .CS 43 | namespace foo { 44 | private proc report {mesg} { 45 | puts "click: $mesg" 46 | } 47 | 48 | button .b1 -text "Push Me" \ 49 | -command [code report "Hello World!"] 50 | pack .b1 51 | } 52 | .CE 53 | The code fragment associated with button \fC.b1\fR only makes 54 | sense in the context of namespace "foo". Furthermore, the 55 | "report" procedure is private, and can only be accessed within 56 | that namespace. The \fBcode\fR command wraps up the code 57 | fragment in a way that allows it to be executed properly 58 | when the button is pressed. 59 | .PP 60 | Also, note that the \fBcode\fR command preserves the integrity 61 | of arguments on the command line. This makes it a natural replacement 62 | for the \fBlist\fR command, which is often used to format Tcl code 63 | fragments. In other words, instead of using the \fBlist\fR command 64 | like this: 65 | .CS 66 | after 1000 [list puts "Hello $name!"] 67 | .CE 68 | use the \fBcode\fR command like this: 69 | .CS 70 | after 1000 [code puts "Hello $name!"] 71 | .CE 72 | This not only formats the command correctly, but also captures 73 | its namespace context. 74 | .PP 75 | Scoped commands can be invoked like ordinary code fragments, with 76 | or without the \fBeval\fR command. For example, the following 77 | statements work properly: 78 | .CS 79 | set cmd {@scope ::foo .b1} 80 | $cmd configure -background red 81 | 82 | set opts {-bg blue -fg white} 83 | eval $cmd configure $opts 84 | .CE 85 | Note that scoped commands by-pass the usual protection mechanisms; 86 | the command: 87 | .CS 88 | @scope ::foo {report {Hello World!}} 89 | .CE 90 | can be used to access the "foo::report" proc from any namespace 91 | context, even though it is private. 92 | 93 | .SH KEYWORDS 94 | scope, callback, namespace, public, protected, private 95 | -------------------------------------------------------------------------------- /doc/configbody.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH configbody n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::configbody \- change the "config" code for a public variable 13 | .SH SYNOPSIS 14 | \fBitcl::configbody \fIclassName\fB::\fIvarName body\fR 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBconfigbody\fR command is used outside of an \fB[incr\ Tcl]\fR 20 | class definition to define or redefine the configuration code 21 | associated with a public variable. Public variables act like 22 | configuration options for an object. They can be modified 23 | outside the class scope using the built-in \fBconfigure\fR method. 24 | Each variable can have a bit of "config" code associate with it 25 | that is automatically executed when the variable is configured. 26 | The \fBconfigbody\fR command can be used to define or redefine 27 | this body of code. 28 | .PP 29 | Like the \fBbody\fR command, this facility allows a class definition 30 | to have separate "interface" and "implementation" parts. 31 | The "interface" part is a \fBclass\fR command with declarations 32 | for methods, procs, instance variables and common variables. 33 | The "implementation" part is a series of \fBbody\fR and 34 | \fBconfigbody\fR commands. If the "implementation" part 35 | is kept in a separate file, it can be sourced again and 36 | again as bugs are fixed, to support interactive development. 37 | When using the "tcl" mode in the \fBemacs\fR editor, the 38 | "interface" and "implementation" parts can be kept in the 39 | same file; as bugs are fixed, individual bodies can be 40 | highlighted and sent to the test application. 41 | .PP 42 | The name "\fIclassName\fB::\fIvarName\fR" 43 | identifies the public variable being updated. 44 | If the \fIbody\fR string starts with "\fB@\fR", it is treated 45 | as the symbolic name for a C procedure. Otherwise, it is 46 | treated as a Tcl command script. 47 | .PP 48 | Symbolic names for C procedures are established by registering 49 | procedures via \fBItcl_RegisterObjC()\fR. This is usually done 50 | in the \fBTcl_AppInit()\fR procedure, which is automatically called 51 | when the interpreter starts up. In the following example, 52 | the procedure \fCMy_FooObjCmd()\fR is registered with the 53 | symbolic name "foo". This procedure can be referenced in 54 | the \fBconfigbody\fR command as "\fC@foo\fR". 55 | .CS 56 | int 57 | Tcl_AppInit(interp) 58 | Tcl_Interp *interp; /* Interpreter for application. */ 59 | { 60 | if (Itcl_Init(interp) == TCL_ERROR) { 61 | return TCL_ERROR; 62 | } 63 | 64 | if (Itcl_RegisterObjC(interp, "foo", My_FooObjCmd) != TCL_OK) { 65 | return TCL_ERROR; 66 | } 67 | } 68 | .CE 69 | 70 | .SH EXAMPLE 71 | In the following example, a "File" class is defined to represent 72 | open files. Whenever the "-name" option is configured, the 73 | existing file is closed, and a new file is opened. Note that 74 | the "config" code for a public variable is optional. The "-access" 75 | option, for example, does not have it. 76 | .CS 77 | itcl::class File { 78 | private variable fid "" 79 | 80 | public variable name "" 81 | public variable access "r" 82 | 83 | constructor {args} { 84 | eval configure $args 85 | } 86 | destructor { 87 | if {$fid != ""} { 88 | close $fid 89 | } 90 | } 91 | 92 | method get {} 93 | method put {line} 94 | method eof {} 95 | } 96 | 97 | itcl::body File::get {} { 98 | return [gets $fid] 99 | } 100 | itcl::body File::put {line} { 101 | puts $fid $line 102 | } 103 | itcl::body File::eof {} { 104 | return [::eof $fid] 105 | } 106 | 107 | itcl::configbody File::name { 108 | if {$fid != ""} { 109 | close $fid 110 | } 111 | set fid [open $name $access] 112 | } 113 | 114 | # 115 | # See the File class in action: 116 | # 117 | File x 118 | 119 | x configure -name /etc/passwd 120 | while {![x eof]} { 121 | puts "=> [x get]" 122 | } 123 | itcl::delete object x 124 | .CE 125 | 126 | .SH KEYWORDS 127 | class, object, variable, configure 128 | -------------------------------------------------------------------------------- /doc/delete.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH delete n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::delete \- delete things in the interpreter 13 | .SH SYNOPSIS 14 | \fBitcl::delete \fIoption\fR ?\fIarg arg ...\fR? 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBdelete\fR command is used to delete things in the interpreter. 20 | It is implemented as an ensemble, so extensions can add their own 21 | options and extend the behavior of this command. By default, the 22 | \fBdelete\fR command handles the destruction of namespaces. 23 | .PP 24 | The \fIoption\fR argument determines what action is carried out 25 | by the command. The legal \fIoptions\fR (which may be abbreviated) 26 | are: 27 | .TP 28 | \fBdelete class \fIname\fR ?\fIname...\fR? 29 | . 30 | Deletes one or more \fB[incr\ Tcl]\fR classes called \fIname\fR. 31 | This deletes all objects in the class, and all derived classes 32 | as well. 33 | .RS 34 | .PP 35 | If an error is encountered while destructing an object, it will 36 | prevent the destruction of the class and any remaining objects. 37 | To destroy the entire class without regard for errors, use the 38 | "\fBdelete namespace\fR" command. 39 | .RE 40 | .TP 41 | \fBdelete object \fIname\fR ?\fIname...\fR? 42 | . 43 | Deletes one or more \fB[incr\ Tcl]\fR objects called \fIname\fR. 44 | An object is deleted by invoking all destructors in its class 45 | hierarchy, in order from most- to least-specific. If all destructors 46 | are successful, data associated with the object is deleted and 47 | the \fIname\fR is removed as a command from the interpreter. 48 | .RS 49 | .PP 50 | If the access command for an object resides in another namespace, 51 | then its qualified name can be used: 52 | .PP 53 | .CS 54 | itcl::delete object foo::bar::x 55 | .CE 56 | .PP 57 | If an error is encountered while destructing an object, the 58 | \fBdelete\fR command is aborted and the object remains alive. 59 | To destroy an object without regard for errors, use the 60 | "\fBrename\fR" command to destroy the object access command. 61 | .RE 62 | .TP 63 | \fBdelete namespace \fIname\fR ?\fIname...\fR? 64 | . 65 | Deletes one or more namespaces called \fIname\fR. This deletes 66 | all commands and variables in the namespace, and deletes all 67 | child namespaces as well. When a namespace is deleted, it is 68 | automatically removed from the import lists of all other namespaces. 69 | 70 | .SH KEYWORDS 71 | namespace, proc, variable, ensemble 72 | -------------------------------------------------------------------------------- /doc/ensemble.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH ensemble n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::ensemble \- create or modify a composite command 13 | .SH SYNOPSIS 14 | .nf 15 | \fBitcl::ensemble \fIensName\fR ?\fIcommand arg arg...\fR? 16 | .fi 17 | or 18 | .nf 19 | \fBensemble \fIensName\fR { 20 | \fBpart \fIpartName args body\fR 21 | \fI...\fR 22 | \fBensemble \fIpartName\fR { 23 | \fBpart \fIsubPartName args body\fR 24 | \fBpart \fIsubPartName args body\fR 25 | \fI...\fR 26 | } 27 | } 28 | .fi 29 | .BE 30 | 31 | .SH DESCRIPTION 32 | .PP 33 | The \fBensemble\fR command is used to create or modify a composite 34 | command. See the section \fBWHAT IS AN ENSEMBLE?\fR below for a 35 | brief overview of ensembles. 36 | .PP 37 | If the \fBensemble\fR command finds an existing ensemble called 38 | \fIensName\fR, it updates that ensemble. Otherwise, it creates an 39 | ensemble called \fIensName\fR. If the \fIensName\fR is a simple name 40 | like "foo", then an ensemble command named "foo" is added to the 41 | current namespace context. If a command named "foo" already exists 42 | in that context, then it is deleted. If the \fIensName\fR contains 43 | namespace qualifiers like "a::b::foo", then the namespace path is 44 | resolved, and the ensemble command is added that namespace context. 45 | Parent namespaces like "a" and "b" are created automatically, as needed. 46 | .PP 47 | If the \fIensName\fR contains spaces like "a::b::foo bar baz", then 48 | additional words like "bar" and "baz" are treated as sub-ensembles. 49 | Sub-ensembles are merely parts within an ensemble; they do not have 50 | a Tcl command associated with them. An ensemble like "foo" can 51 | have a sub-ensemble called "foo bar", which in turn can have a 52 | sub-ensemble called "foo bar baz". In this case, the sub-ensemble 53 | "foo bar" must be created before the sub-ensemble "foo bar baz" 54 | that resides within it. 55 | .PP 56 | If there are any arguments following \fIensName\fR, then they are 57 | treated as commands, and they are executed to update the ensemble. 58 | The following commands are recognized in this context: \fBpart\fR 59 | and \fBensemble\fR. 60 | .PP 61 | The \fBpart\fR command defines a new part for the ensemble. 62 | Its syntax is identical to the usual \fBproc\fR command, but 63 | it defines a part within an ensemble, instead of a Tcl command. 64 | If a part called \fIpartName\fR already exists within the ensemble, 65 | then the \fBpart\fR command returns an error. 66 | .PP 67 | The \fBensemble\fR command can be nested inside another \fBensemble\fR 68 | command to define a sub-ensemble. 69 | 70 | .SH "WHAT IS AN ENSEMBLE?" 71 | .PP 72 | The usual "info" command is a composite command--the command name 73 | \fBinfo\fR must be followed by a sub-command like \fBbody\fR or \fBglobals\fR. 74 | We will refer to a command like \fBinfo\fR as an \fIensemble\fR, and to 75 | sub-commands like \fBbody\fR or \fBglobals\fR as its \fIparts\fR. 76 | .PP 77 | Ensembles can be nested. For example, the \fBinfo\fR command has 78 | an ensemble \fBinfo namespace\fR within it. This ensemble has parts 79 | like \fBinfo namespace all\fR and \fBinfo namespace children\fR. 80 | .PP 81 | With ensembles, composite commands can be created and extended 82 | in an automatic way. Any package can find an existing ensemble 83 | and add new parts to it. So extension writers can add their 84 | own parts, for example, to the \fBinfo\fR command. 85 | .PP 86 | The ensemble facility manages all of the part names and keeps 87 | track of unique abbreviations. Normally, you can abbreviate 88 | \fBinfo complete\fR to \fBinfo comp\fR. But if an extension adds the 89 | part \fBinfo complexity\fR, the minimum abbreviation for \fBinfo complete\fR 90 | becomes \fBinfo complet\fR. 91 | .PP 92 | The ensemble facility not only automates the construction of 93 | composite commands, but it automates the error handling as well. 94 | If you invoke an ensemble command without specifying a part name, 95 | you get an automatically generated error message that summarizes 96 | the usage information. For example, when the \fBinfo\fR command 97 | is invoked without any arguments, it produces the following error 98 | message: 99 | .PP 100 | .CS 101 | wrong # args: should be one of... 102 | info args procname 103 | info body procname 104 | info cmdcount 105 | info commands ?pattern? 106 | info complete command 107 | info context 108 | info default procname arg varname 109 | info exists varName 110 | info globals ?pattern? 111 | info level ?number? 112 | info library 113 | info locals ?pattern? 114 | info namespace option ?arg arg ...? 115 | info patchlevel 116 | info procs ?pattern? 117 | info protection ?-command? ?-variable? name 118 | info script 119 | info tclversion 120 | info vars ?pattern? 121 | info which ?-command? ?-variable? ?-namespace? name 122 | .CE 123 | .PP 124 | You can also customize the way an ensemble responds to errors. 125 | When an ensemble encounters an unspecified or ambiguous part 126 | name, it looks for a part called \fB@error\fR. If it exists, 127 | then it is used to handle the error. This part will receive all 128 | of the arguments on the command line starting with the offending 129 | part name. It can find another way of resolving the command, 130 | or generate its own error message. 131 | 132 | .SH EXAMPLE 133 | .PP 134 | We could use an ensemble to clean up the syntax of the various 135 | "wait" commands in Tcl/Tk. Instead of using a series of 136 | strange commands like this: 137 | .PP 138 | .CS 139 | vwait x 140 | tkwait visibility .top 141 | tkwait window . 142 | .CE 143 | .PP 144 | we could use commands with a uniform syntax, like this: 145 | .PP 146 | .CS 147 | wait variable x 148 | wait visibility .top 149 | wait window . 150 | .CE 151 | .PP 152 | The Tcl package could define the following ensemble: 153 | .PP 154 | .CS 155 | itcl::ensemble wait part variable {name} { 156 | uplevel vwait $name 157 | } 158 | .CE 159 | .PP 160 | The Tk package could add some options to this ensemble, with a 161 | command like this: 162 | .PP 163 | .CS 164 | itcl::ensemble wait { 165 | part visibility {name} { 166 | tkwait visibility $name 167 | } 168 | part window {name} { 169 | tkwait window $name 170 | } 171 | } 172 | .CE 173 | .PP 174 | Other extensions could add their own parts to the \fBwait\fR command 175 | too. 176 | 177 | .SH KEYWORDS 178 | ensemble, part, info 179 | -------------------------------------------------------------------------------- /doc/find.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH find n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::find \- search for classes and objects 13 | .SH SYNOPSIS 14 | \fBitcl::find \fIoption\fR ?\fIarg arg ...\fR? 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBfind\fR command is used to find classes and objects 20 | that are available in the current interpreter. Classes and objects 21 | are reported first in the active namespace, then in all other 22 | namespaces in the interpreter. 23 | .PP 24 | The \fIoption\fR argument determines what action is carried out 25 | by the command. The legal \fIoptions\fR (which may be abbreviated) 26 | are: 27 | .TP 28 | \fBfind classes ?\fIpattern\fR? 29 | . 30 | Returns a list of [incr Tcl] classes. Classes in the current 31 | namespace are listed first, followed by classes in all other 32 | namespaces in the interpreter. If the optional \fIpattern\fR 33 | is specified, then the reported names are compared using the rules 34 | of the "\fBstring match\fR" command, and only matching names are 35 | reported. 36 | .RS 37 | .PP 38 | If a class resides in the current namespace context, this command 39 | reports its simple name--without any qualifiers. However, if the 40 | \fIpattern\fR contains \fB::\fR qualifiers, or if the class resides 41 | in another context, this command reports its fully-qualified name. 42 | Therefore, you can use the following command to obtain a list where 43 | all names are fully-qualified: 44 | .PP 45 | .CS 46 | itcl::find classes ::* 47 | .CE 48 | .RE 49 | .TP 50 | \fBfind objects ?\fIpattern\fR? ?\fB-class \fIclassName\fR? ?\fB-isa \fIclassName\fR? 51 | . 52 | Returns a list of [incr Tcl] objects. Objects in the current 53 | namespace are listed first, followed by objects in all other 54 | namespaces in the interpreter. If the optional \fIpattern\fR is 55 | specified, then the reported names are compared using the rules 56 | of the "\fBstring match\fR" command, and only matching names are 57 | reported. 58 | If the optional "\fB-class\fR" parameter is specified, this list is 59 | restricted to objects whose most-specific class is \fIclassName\fR. 60 | If the optional "\fB-isa\fR" parameter is specified, this list is 61 | further restricted to objects having the given \fIclassName\fR 62 | anywhere in their heritage. 63 | .RS 64 | .PP 65 | If an object resides in the current namespace context, this command 66 | reports its simple name--without any qualifiers. However, if the 67 | \fIpattern\fR contains \fB::\fR qualifiers, or if the object resides 68 | in another context, this command reports its fully-qualified name. 69 | Therefore, you can use the following command to obtain a list where 70 | all names are fully-qualified: 71 | .PP 72 | .CS 73 | itcl::find objects ::* 74 | .CE 75 | .RE 76 | .SH KEYWORDS 77 | class, object, search, import 78 | -------------------------------------------------------------------------------- /doc/is.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH is n 3.3 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::is \- test argument to see if it is a class or an object 13 | .SH SYNOPSIS 14 | \fBitcl::is \fIoption\fR ?\fIarg arg ...\fR? 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBis\fR command is used to check if the argument given is 20 | a class or an object; depending on the option given. If the argument 21 | if a class or object, then 1 is returned. Otherwise, 0 is returned. 22 | The \fBis\fR command also recognizes the commands wrapped in the 23 | itcl \fBcode\fR command. 24 | .PP 25 | The \fIoption\fR argument determines what action is carried out 26 | by the command. The legal \fIoptions\fR (which may be abbreviated) 27 | are: 28 | .TP 29 | \fBis class \fIcommand\fR 30 | . 31 | Returns 1 if command is a class, and returns 0 otherwise. 32 | .RS 33 | .PP 34 | The fully qualified name of the class needs to be given as the \fIcommand\fR 35 | argument. So, if a class resides in a namespace, then the namespace needs to 36 | be specified as well. So, if a class \fBC\fR resides in a namespace \fBN\fR, then 37 | the command should be called like: 38 | .PP 39 | .CS 40 | \fBis N::C\fR 41 | or 42 | \fBis ::N::C\fR 43 | .CE 44 | .RE 45 | .TP 46 | \fBis\fR object ?\fB-class \fIclassName\fR? \fIcommand\fR 47 | . 48 | Returns 1 if \fIcommand\fR is an object, and returns 0 otherwise. 49 | .RS 50 | .PP 51 | If the optional "\fB-class\fR" parameter is specified, then the 52 | \fIcommand\fR will be checked within the context of the class 53 | given. Note that \fIclassName\fR has to exist. If not, then an 54 | error will be given. So, if \fIclassName\fR is uncertain to be 55 | a class, then the programmer will need to check it's existance 56 | beforehand, or wrap it in a catch statement. 57 | .PP 58 | So, if \fBc\fR is an object in the class \fBC\fR, in namespace N then 59 | these are the possibilities (all return 1): 60 | .PP 61 | .CS 62 | set obj [N::C c] 63 | itcl::is object N::c 64 | itcl::is object c 65 | itcl::is object $obj 66 | itcl::is object [itcl::code c] 67 | .CE 68 | .RE 69 | .SH KEYWORDS 70 | class, object 71 | 72 | -------------------------------------------------------------------------------- /doc/itcl.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH itcl n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl \- object-oriented extensions to Tcl 13 | .BE 14 | 15 | .SH DESCRIPTION 16 | .PP 17 | \fB[incr\ Tcl]\fR provides object-oriented extensions to Tcl, much as 18 | C++ provides object-oriented extensions to C. The emphasis of this 19 | work, however, is not to create a whiz-bang object-oriented 20 | programming environment. Rather, it is to support more structured 21 | programming practices in Tcl without changing the flavor of the language. 22 | More than anything else, \fB[incr\ Tcl]\fR provides a means of 23 | encapsulating related procedures together with their shared data 24 | in a namespace that is hidden from the outside world. 25 | It encourages better programming by promoting the object-oriented 26 | "library" mindset. It also allows for code re-use through inheritance. 27 | 28 | .SH CLASSES 29 | .PP 30 | The fundamental construct in \fB[incr\ Tcl]\fR is the class definition. 31 | Each class acts as a template for actual objects that can be created. 32 | Each object has its own unique bundle of data, which contains instances 33 | of the "variables" defined in the class. Special procedures called 34 | "methods" are used to manipulate individual objects. Methods are just 35 | like the operations that are used to manipulate Tk widgets. The 36 | "\fBbutton\fR" widget, for example, has methods such as "flash" and 37 | "invoke" that cause a particular button to blink and invoke its command. 38 | .PP 39 | Within the body of a method, the "variables" defined in the class 40 | are automatically available. They need not be declared with anything 41 | like the \fBglobal\fR command. Within another class method, a method 42 | can be invoked like any other command\-simply by using its name. 43 | From any other context, the method name must be prefaced by an object 44 | name, which provides a context for the data that the method can access. 45 | .PP 46 | Each class has its own namespace containing things that are common 47 | to all objects which belong to the class. For example, "common" data 48 | members are shared by all objects in the class. They are global 49 | variables that exist in the class namespace, but since they are 50 | included in the class definition, they need not be declared using 51 | the \fBglobal\fR command; they are automatically available to any 52 | code executing in the class context. A class can also create 53 | ordinary global variables, but these must be declared using the 54 | \fBglobal\fR command each time they are used. 55 | .PP 56 | Classes can also have ordinary procedures declared as "procs". 57 | Within another class method or proc, a proc can be invoked like 58 | any other command\-simply by using its name. From any other context, 59 | the procedure name should be qualified with the class namespace 60 | like "\fIclassName\fB::\fIproc\fR". Class procs execute in the 61 | class context, and therefore have automatic access to all "common" 62 | data members. However, they cannot access object-specific "variables", 63 | since they are invoked without reference to any specific object. 64 | They are usually used to perform generic operations which affect 65 | all objects belonging to the class. 66 | .PP 67 | Each of the elements in a class can be declared "public", "protected" 68 | or "private". Public elements can be accessed by the class, by 69 | derived classes (other classes that inherit this class), and by 70 | external clients that use the class. Protected elements can be 71 | accessed by the class, and by derived classes. Private elements 72 | are only accessible in the class where they are defined. 73 | .PP 74 | The "public" elements within a class define its interface to the 75 | external world. Public methods define the operations that can 76 | be used to manipulate an object. Public variables are recognized 77 | as configuration options by the "configure" and "cget" methods 78 | that are built into each class. The public interface says 79 | \fIwhat\fR an object will do but not \fIhow\fR it will do it. 80 | Protected and private members, along with the bodies of class 81 | methods and procs, provide the implementation details. Insulating 82 | the application developer from these details leaves the class designer 83 | free to change them at any time, without warning, and without affecting 84 | programs that rely on the class. It is precisely this encapsulation 85 | that makes object-oriented programs easier to understand and maintain. 86 | .PP 87 | The fact that \fB[incr\ Tcl]\fR objects look like Tk widgets is 88 | no accident. \fB[incr\ Tcl]\fR was designed this way, to blend 89 | naturally into a Tcl/Tk application. But \fB[incr\ Tcl]\fR 90 | extends the Tk paradigm from being merely object-based to being 91 | fully object-oriented. An object-oriented system supports 92 | inheritance, allowing classes to share common behaviors by 93 | inheriting them from an ancestor or base class. Having a base 94 | class as a common abstraction allows a programmer to treat 95 | related classes in a similar manner. For example, a toaster 96 | and a blender perform different (specialized) functions, but 97 | both share the abstraction of being appliances. By abstracting 98 | common behaviors into a base class, code can be \fIshared\fR rather 99 | than \fIcopied\fR. The resulting application is easier to 100 | understand and maintain, and derived classes (e.g., specialized 101 | appliances) can be added or removed more easily. 102 | .PP 103 | This description was merely a brief overview of object-oriented 104 | programming and \fB[incr\ Tcl]\fR. A more tutorial introduction is 105 | presented in the paper included with this distribution. See the 106 | \fBclass\fR command for more details on creating and using classes. 107 | 108 | .SH NAMESPACES 109 | .PP 110 | \fB[incr\ Tcl]\fR now includes a complete namespace facility. 111 | A namespace is a collection of commands and global variables that 112 | is kept apart from the usual global scope. This allows Tcl code 113 | libraries to be packaged in a well-defined manner, and prevents 114 | unwanted interactions with other libraries. A namespace can also 115 | have child namespaces within it, so one library can contain its 116 | own private copy of many other libraries. A namespace can also 117 | be used to wrap up a group of related classes. The global scope 118 | (named "\fC::\fR") is the root namespace for an interpreter; all 119 | other namespaces are contained within it. 120 | .PP 121 | See the \fBnamespace\fR command for details on creating and 122 | using namespaces. 123 | 124 | .SH MEGA-WIDGETS 125 | .PP 126 | Mega-widgets are high-level widgets that are constructed using 127 | Tk widgets as component parts, usually without any C code. A 128 | fileselectionbox, for example, may have a few listboxes, some 129 | entry widgets and some control buttons. These individual widgets 130 | are put together in a way that makes them act like one big 131 | widget. 132 | .PP 133 | \fB[incr\ Tk]\fR is a framework for building mega-widgets. It 134 | uses \fB[incr\ Tcl]\fR to support the object paradigm, and adds 135 | base classes which provide default widget behaviors. See the 136 | \fBitk\fR man page for more details. 137 | .PP 138 | \fB[incr\ Widgets]\fR is a library of mega-widgets built using 139 | \fB[incr\ Tk]\fR. It contains more than 30 different widget 140 | classes that can be used right out of the box to build Tcl/Tk 141 | applications. Each widget class has its own man page describing 142 | the features available. 143 | 144 | .SH KEYWORDS 145 | class, object, object-oriented, namespace, mega-widget 146 | -------------------------------------------------------------------------------- /doc/itclcomponent.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 2008 Arnulf Wiedemann 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH component n 4.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::component \- define components for extendedclass, widget or widgetadaptor 13 | .PP 14 | Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical. 15 | .SH WARNING! 16 | This is new functionality in [incr Tcl] where the API can still change!! 17 | .SH SYNOPSIS 18 | .nf 19 | \fBpublic component \fIcomp\fR ?\fB-inherit\fR? 20 | \fBprotected component \fIcomp\fR ?\fB-inherit\fR? 21 | \fBprivate component \fIcomp\fR ?\fB-inherit\fR? 22 | .fi 23 | .BE 24 | 25 | .SH DESCRIPTION 26 | .PP 27 | The \fBcomponent\fR command is used inside an \fB[incr\ Tcl]\fR 28 | extendedclass/widget/widgetadaptor definition to define components. 29 | .PP 30 | Explicitly declares a component called comp, and automatically defines 31 | the component's instance variable. 32 | .PP 33 | If the \fI-inherit\fR option is specified then all unknown methods 34 | and options will be delegated to this component. The name -inherit 35 | implies that instances of this new type inherit, in a sense, 36 | the methods and options of the component. That is, 37 | -inherit yes is equivalent to: 38 | .PP 39 | .CS 40 | component mycomp 41 | delegate option * to mycomp 42 | delegate method * to mycomp 43 | .CE 44 | 45 | .SH KEYWORDS 46 | component, widget, widgetadaptor, extendedclass 47 | -------------------------------------------------------------------------------- /doc/itcldelegate.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 2008 Arnulf Wiedemann 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH delegation n 4.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::delegation \- delegate methods, procs or options to other objects 13 | .PP 14 | Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical. 15 | .SH WARNING! 16 | This is new functionality in [incr Tcl] where the API can still change!! 17 | .SH SYNOPSIS 18 | .nf 19 | \fBdelegate method \fImethodName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR? 20 | \fBdelegate method \fImethodName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR 21 | \fBdelegate method \fI* ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fImethodName methodName ...\fR? 22 | 23 | \fBdelegate proc \fIprocName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR? 24 | \fBdelegate proc \fIprocName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR 25 | \fBdelegate proc \fI*\fR ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fIprocName procName ...\fR? 26 | 27 | \fBdelegate option \fIoptionSpec\fB to \fIcomponentName\fR 28 | \fBdelegate option \fIoptionSpec\fB to \fIcomponentName\fR \fBas \fItargetname\fR? 29 | \fBdelegate option \fI* \fBto \fIcomponentName\fR 30 | \fBdelegate option \fI* \fBto \fIcomponentName\fR \fBexcept \fIoptionName optionname ...\fR 31 | .fi 32 | .BE 33 | 34 | .SH DESCRIPTION 35 | .PP 36 | The \fBdelegate\fR command is used inside an \fB[incr\ Tcl]\fR 37 | extendedclass/widget/widgetadaptor definition to delegate 38 | methods/procs/options to other objects for handling. 39 | .TP 40 | \fBdelegate method \fImethodName\fB to \fIcomponentName\fR ?\fBas \fItargetName\fR? 41 | . 42 | This form of delegate method delegates method methodName to component 43 | componentName. That is, when method methdoNameame is called on an instance of 44 | this type, the method and its arguments will be passed to the named component's 45 | command instead. That is, the following statement 46 | .RS 47 | .PP 48 | .CS 49 | delegate method wag to tail 50 | .CE 51 | .PP 52 | is roughly equivalent to this explicitly defined method: 53 | .PP 54 | .CS 55 | method wag {args} { 56 | uplevel $tail wag $args 57 | } 58 | .CE 59 | .PP 60 | The optional \fBas\fR clause allows you to specify the delegated method 61 | name and possibly add some arguments: 62 | .PP 63 | .CS 64 | delegate method wagtail to tail as "wag briskly" 65 | .CE 66 | .PP 67 | A method cannot be both locally defined and delegated. 68 | .RE 69 | .TP 70 | \fBdelegate method \fImethodName\fR ?\fBto \fIcomponentName\fR? \fBusing \fIpattern\fR 71 | . 72 | In this form of the delegate statement, the \fBusing\fR clause is used to 73 | specify the precise form of the command to which method name name is delegated. 74 | The \fBto\fR clause is optional, since the chosen command might not involve 75 | any particular component. 76 | .RS 77 | .PP 78 | The value of the using clause is a list that may contain any or all of the 79 | following substitution codes; these codes are substituted with the described 80 | value to build the delegated command prefix. Note that the following two 81 | statements are equivalent: 82 | .PP 83 | .CS 84 | delegate method wag to tail 85 | delegate method wag to tail using "%c %m" 86 | .CE 87 | .PP 88 | Each element of the list becomes a single element of the delegated command 89 | --it is never reparsed as a string. 90 | .PP 91 | Substitutions: 92 | .TP 93 | \fB%%\fR 94 | . 95 | This is replaced with a single "%". Thus, to pass the string "%c" to the 96 | command as an argument, you'd write "%%c". 97 | .TP 98 | \fB%c\fR 99 | . 100 | This is replaced with the named component's command. 101 | .TP 102 | \fB%j\fR 103 | . 104 | This is replaced by the method name; if the name consists of multiple tokens, 105 | they are joined by underscores ("_"). 106 | .TP 107 | \fB%m\fR 108 | . 109 | This is replaced with the final token of the method name; if the method name 110 | has one token, this is identical to \fB%M\fR. 111 | .TP 112 | \fB%M\fR 113 | . 114 | This is replaced by the method name; if the name consists of multiple tokens, 115 | they are joined by space characters. 116 | .TP 117 | \fB%n\fR 118 | . 119 | This is replaced with the name of the instance's private namespace. 120 | .TP 121 | \fB%s\fR 122 | . 123 | This is replaced with the name of the instance command. 124 | .TP 125 | \fB%t\fR 126 | . 127 | This is replaced with the fully qualified type name. 128 | .TP 129 | \fB%w\fR 130 | . 131 | This is replaced with the original name of the instance command; for Itcl 132 | widgets and widget adaptors, it will be the Tk window name. It remains 133 | constant, even if the instance command is renamed. 134 | .RE 135 | .TP 136 | \fBdelegate method \fI*\fR ?\fBto \fIcomponentName\fR? ?\fBusing \fIpattern\fR? ?\fBexcept \fImethodName methodName ...\fR? 137 | . 138 | In this form all unknown method names are delegeted to the specified 139 | component. The except clause can be used to specify a list of exceptions, 140 | i.e., method names that will not be so delegated. The using clause 141 | is defined as given above. In this form, the statement must 142 | contain the to clause, the using clause, or both. 143 | .RS 144 | .PP 145 | In fact, the "*" can be a list of two or more tokens whose last element 146 | is "*", as in the following example: 147 | .PP 148 | .CS 149 | delegate method {tail *} to tail 150 | .CE 151 | .PP 152 | This implicitly defines the method tail whose subcommands will be 153 | delegated to the tail component. 154 | .PP 155 | The definitions for \fBdelegate proc\fR ... are the same as for method, 156 | the only difference being, that this is for procs. 157 | .RE 158 | .TP 159 | \fBdelegate option \fInamespec\fB to \fIcomp\fR 160 | .TP 161 | \fBdelegate option namespec to comp as target\fR 162 | .TP 163 | \fBdelegate option * to \fIcomp\fR 164 | .TP 165 | \fBdelegate option * to \fIcomp \fBexcept \fIexceptions\fR 166 | . 167 | Defines a delegated option; the namespec is defined as for the option 168 | statement. When the configure, configurelist, or cget instance method is 169 | used to set or retrieve the option's value, the equivalent configure or 170 | cget command will be applied to the component as though the option was 171 | defined with the following \fB-configuremethod\fR and \fB-cgetmethod\fR: 172 | .RS 173 | .PP 174 | .CS 175 | method ConfigureMethod {option value} { 176 | $comp configure $option $value 177 | } 178 | 179 | method CgetMethod {option} { 180 | return [$comp cget $option] 181 | } 182 | .CE 183 | .PP 184 | Note that delegated options never appear in the \fBitcl_options\fR array. 185 | If the as clause is specified, then the target option name is used in place 186 | of name. 187 | .RE 188 | .TP 189 | \fBdelegate \fIoption\fB *\fR ?\fBexcept\fI optionName optionName ...\fR? 190 | . 191 | This form delegates all unknown options to the specified component. 192 | The except clause can be used to specify a list of exceptions, 193 | i.e., option names that will not be so delegated. 194 | .RS 195 | .PP 196 | \fBWarning:\fR options can only be delegated to a component if it supports the 197 | \fBconfigure\fR and \fBcget\fR instance methods. 198 | .PP 199 | An option cannot be both locally defined and delegated. TBD: Continue from here. 200 | .RE 201 | .SH KEYWORDS 202 | delegation, option, method, proc 203 | -------------------------------------------------------------------------------- /doc/itcloption.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 2008 Arnulf Wiedemann 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH option n 4.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::option \- define options for extendedclass, widget or widgetadaptor 13 | .PP 14 | Parts of this description are "borrowed" from Tcl extension [snit], as the functionality is mostly identical. 15 | .SH WARNING! 16 | This is new functionality in [incr Tcl] where the API can still change!! 17 | .SH SYNOPSIS 18 | .nf 19 | \fBoption \fIoptionSpec\fR ?\fIdefaultValue\fR? 20 | \fBoption \fIoptionSpec\fR ?\fIoptions\fR? 21 | .fi 22 | .BE 23 | 24 | .SH DESCRIPTION 25 | .PP 26 | The \fBoption\fR command is used inside an \fB[incr\ Tcl]\fR 27 | extendedclass/widget/widgetadaptor definition to define options. 28 | .PP 29 | In the first form defines an option for instances of this type, and optionally 30 | gives it an initial value. The initial value defaults to the empty string if 31 | no defaultValue is specified. 32 | .PP 33 | An option defined in this way is said to be locally defined. 34 | The optionSpec is a list defining the option's name, resource name, and class 35 | name, e.g.: 36 | .PP 37 | .CS 38 | option {-font font Font} {Courier 12} 39 | .CE 40 | .PP 41 | The option name must begin with a hyphen, and must not contain any upper case 42 | letters. The resource name and class name are optional; if not specified, 43 | the resource name defaults to the option name, minus the hyphen, and the class 44 | name defaults to the resource name with the first letter capitalized. Thus, the 45 | following statement is equivalent to the previous example: 46 | .PP 47 | .CS 48 | option -font {Courier 12} 49 | .CE 50 | .PP 51 | See The Tk Option Database for more information about resource and class names. 52 | .PP 53 | Options are normally set and retrieved using the standard instance methods 54 | configure and cget; within instance code (method bodies, etc.), option values 55 | are available through the options array: 56 | .PP 57 | .CS 58 | set myfont $itcl_options(-font) 59 | .CE 60 | .PP 61 | In the second form you can define option handlers (e.g., -configuremethod), 62 | then it should probably use configure and cget to access its options to avoid 63 | subtle errors. 64 | .PP 65 | The option statement may include the following options: 66 | .TP 67 | \fB-default\fI defvalue\fR 68 | . 69 | Defines the option's default value; the option's default value will be "" 70 | otherwise. 71 | .TP 72 | \fB-readonly\fR 73 | . 74 | The option is handled read-only -- it can only be set using configure at 75 | creation time, i.e., in the type's constructor. 76 | .TP 77 | \fB-cgetmethod\fI methodName\fR 78 | . 79 | Every locally-defined option may define a -cgetmethod; it is called when the 80 | option's value is retrieved using the cget method. Whatever the method's body 81 | returns will be the return value of the call to cget. 82 | .RS 83 | .PP 84 | The named method must take one argument, the option name. For example, this 85 | code is equivalent to (though slower than) Itcl's default handling of cget: 86 | .PP 87 | .CS 88 | option -font -cgetmethod GetOption 89 | method GetOption {option} { 90 | return $itcl_options($option) 91 | } 92 | .CE 93 | .PP 94 | Note that it's possible for any number of options to share a -cgetmethod. 95 | .RE 96 | .TP 97 | \fB-cgetmethodvar\fI varName\fR 98 | . 99 | That is very similar to -cgetmethod, the only difference is, one can define 100 | a variable, where to find the cgetmethod during runtime. 101 | .TP 102 | \fB-configuremethod\fI methodName\fR 103 | . 104 | Every locally-defined option may define a -configuremethod; it is called 105 | when the option's value is set using the configure or configurelist 106 | methods. It is the named method's responsibility to save the option's 107 | value; in other words, the value will not be saved to the itcl_options() 108 | array unless the method saves it there. 109 | .RS 110 | .PP 111 | The named method must take two arguments, the option name and its new value. 112 | For example, this code is equivalent to (though slower than) Itcl's default 113 | handling of configure: 114 | .PP 115 | .CS 116 | option -font -configuremethod SetOption 117 | method SetOption {option value} { 118 | set itcl_options($option) $value 119 | } 120 | .CE 121 | .PP 122 | Note that it's possible for any number of options to share a single -configuremethod. 123 | .RE 124 | .TP 125 | \fB-configuremethodvar\fI varName\fR 126 | . 127 | That is very similar to -configuremethod, the only difference is, one can define 128 | a variable, where to find the configuremethod during runtime. 129 | .TP 130 | \fB-validatemethod\fI methodName\fR 131 | . 132 | Every locally-defined option may define a -validatemethod; it is called when 133 | the option's value is set using the configure or configurelist methods, just 134 | before the -configuremethod (if any). It is the named method's responsibility 135 | to validate the option's new value, and to throw an error if the value is 136 | invalid. 137 | .RS 138 | .PP 139 | The named method must take two arguments, the option name and its new value. 140 | For example, this code verifies that -flag's value is a valid Boolean value: 141 | .PP 142 | .CS 143 | option -font -validatemethod CheckBoolean 144 | method CheckBoolean {option value} { 145 | if {![string is boolean -strict $value]} { 146 | error "option $option must have a boolean value." 147 | } 148 | } 149 | .CE 150 | .PP 151 | Note that it's possible for any number of options to share a single -validatemethod. 152 | .RE 153 | .TP 154 | \fB-validatemethodvar\fI varName\fR 155 | . 156 | That is very similar to -validatemethod, the only difference is, one can define 157 | a variable, where to find the validatemethod during runtime. 158 | 159 | .SH KEYWORDS 160 | option, widget, widgetadaptor, extendedclass 161 | -------------------------------------------------------------------------------- /doc/itclvars.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH itclvars n 3.0 itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itclvars \- variables used by [incr\ Tcl] 13 | .BE 14 | 15 | .SH DESCRIPTION 16 | .PP 17 | The following global variables are created and managed automatically 18 | by the \fB[incr\ Tcl]\fR library. Except where noted below, these 19 | variables should normally be treated as read-only by application-specific 20 | code and by users. 21 | .TP 22 | \fBitcl::library\fR 23 | . 24 | When an interpreter is created, \fB[incr\ Tcl]\fR initializes this variable 25 | to hold the name of a directory containing the system library of 26 | \fB[incr\ Tcl]\fR scripts. The initial value of \fBitcl::library\fR 27 | is set from the ITCL_LIBRARY environment variable if it exists, 28 | or from a compiled-in value otherwise. 29 | .TP 30 | \fBitcl::patchLevel\fR 31 | . 32 | When an interpreter is created, \fB[incr\ Tcl]\fR initializes this 33 | variable to hold the current patch level for \fB[incr\ Tcl]\fR. 34 | For example, the value "\fB2.0p1\fR" indicates \fB[incr\ Tcl]\fR 35 | version 2.0 with the first set of patches applied. 36 | .TP 37 | \fBitcl::purist\fR 38 | . 39 | When an interpreter is created containing Tcl/Tk and the 40 | \fB[incr\ Tcl]\fR namespace facility, this variable controls 41 | a "backward-compatibility" mode for widget access. 42 | .RS 43 | .PP 44 | In vanilla Tcl/Tk, there is a single pool of commands, so the 45 | access command for a widget is the same as the window name. 46 | When a widget is created within a namespace, however, its access 47 | command is installed in that namespace, and should be accessed 48 | outside of the namespace using a qualified name. For example, 49 | .PP 50 | .CS 51 | namespace foo { 52 | namespace bar { 53 | button .b -text "Testing" 54 | } 55 | } 56 | foo::bar::.b configure -background red 57 | pack .b 58 | .CE 59 | .PP 60 | Note that the window name "\fC.b\fR" is still used in conjunction 61 | with commands like \fBpack\fR and \fBdestroy\fR. However, the 62 | access command for the widget (i.e., name that appears as the 63 | \fIfirst\fR argument on a command line) must be more specific. 64 | .PP 65 | The "\fBwinfo command\fR" command can be used to query the 66 | fully-qualified access command for any widget, so one can write: 67 | .PP 68 | .CS 69 | [winfo command .b] configure -background red 70 | .CE 71 | .PP 72 | and this is good practice when writing library procedures. Also, 73 | in conjunction with the \fBbind\fR command, the "%q" field can be 74 | used in place of "%W" as the access command: 75 | .PP 76 | .CS 77 | bind Button {%q flash; %q invoke} 78 | .CE 79 | .PP 80 | While this behavior makes sense from the standpoint of encapsulation, 81 | it causes problems with existing Tcl/Tk applications. Many existing 82 | applications are written with bindings that use "%W". Many 83 | library procedures assume that the window name is the access 84 | command. 85 | .PP 86 | The \fBitcl::purist\fR variable controls a backward-compatibility 87 | mode. By default, this variable is "0", and the window name 88 | can be used as an access command in any context. Whenever the 89 | \fBunknown\fR procedure stumbles across a widget name, it simply 90 | uses "\fBwinfo command\fR" to determine the appropriate command 91 | name. If this variable is set to "1", this backward-compatibility 92 | mode is disabled. This gives better encapsulation, but using the 93 | window name as the access command may lead to "invalid command" 94 | errors. 95 | .RE 96 | .TP 97 | \fBitcl::version\fR 98 | . 99 | When an interpreter is created, \fB[incr\ Tcl]\fR initializes this 100 | variable to hold the version number of the form \fIx.y\fR. 101 | Changes to \fIx\fR represent major changes with probable 102 | incompatibilities and changes to \fIy\fR represent small enhancements 103 | and bug fixes that retain backward compatibility. 104 | 105 | .SH KEYWORDS 106 | itcl, variables 107 | -------------------------------------------------------------------------------- /doc/license.terms: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------ 2 | >>>>>>>>>>>>>>>>>>>>>>>>>>>>>> [incr Tcl] <<<<<<<<<<<<<<<<<<<<<<<<<<<<<< 3 | 4 | AUTHOR: Michael J. McLennan 5 | Bell Labs Innovations for Lucent Technologies 6 | mmclennan@lucent.com 7 | http://www.tcltk.com/itcl 8 | ======================================================================== 9 | Copyright (c) 1993-1996 Lucent Technologies 10 | ======================================================================== 11 | Permission to use, copy, modify, and distribute this software and its 12 | documentation for any purpose and without fee is hereby granted, 13 | provided that the above copyright notice appear in all copies and that 14 | both that the copyright notice and warranty disclaimer appear in 15 | supporting documentation, and that the names of Lucent Technologies 16 | any of their entities not be used in advertising or publicity 17 | pertaining to distribution of the software without specific, written 18 | prior permission. 19 | 20 | Lucent Technologies disclaims all warranties with regard to this 21 | software, including all implied warranties of merchantability and 22 | fitness. In no event shall Lucent be liable for any special, indirect 23 | or consequential damages or any damages whatsoever resulting from loss 24 | of use, data or profits, whether in an action of contract, negligence 25 | or other tortuous action, arising out of or in connection with the use 26 | or performance of this software. 27 | ======================================================================== 28 | -------------------------------------------------------------------------------- /doc/local.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH local n "" itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::local \- create an object local to a procedure 13 | .SH SYNOPSIS 14 | \fBitcl::local \fIclassName objName\fR ?\fIarg arg ...\fR? 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | The \fBlocal\fR command creates an \fB[incr\ Tcl]\fR object that 20 | is local to the current call frame. When the call frame goes away, 21 | the object is automatically deleted. This command is useful for 22 | creating objects that are local to a procedure. 23 | .PP 24 | As a side effect, this command creates a variable named 25 | "\fBitcl-local-\fIxxx\fR", where \fIxxx\fR is the name of 26 | the object that is created. This variable detects when the 27 | call frame is destroyed and automatically deletes the 28 | associated object. 29 | 30 | .SH EXAMPLE 31 | .PP 32 | In the following example, a simple "counter" object is used 33 | within the procedure "test". The counter is created as a 34 | local object, so it is automatically deleted each time the 35 | procedure exits. The \fBputs\fR statements included in the 36 | constructor/destructor show the object coming and going 37 | as the procedure is called. 38 | .PP 39 | .CS 40 | itcl::class counter { 41 | private variable count 0 42 | constructor {} { 43 | puts "created: $this" 44 | } 45 | destructor { 46 | puts "deleted: $this" 47 | } 48 | 49 | method bump {{by 1}} { 50 | incr count $by 51 | } 52 | method get {} { 53 | return $count 54 | } 55 | } 56 | 57 | proc test {val} { 58 | local counter x 59 | for {set i 0} {$i < $val} {incr i} { 60 | x bump 61 | } 62 | return [x get] 63 | } 64 | 65 | set result [test 5] 66 | puts "test: $result" 67 | 68 | set result [test 10] 69 | puts "test: $result" 70 | 71 | puts "objects: [itcl::find objects *]" 72 | .CE 73 | 74 | .SH KEYWORDS 75 | class, object, procedure 76 | -------------------------------------------------------------------------------- /doc/man.macros: -------------------------------------------------------------------------------- 1 | .\" The -*- nroff -*- definitions below are for supplemental macros used 2 | .\" in Tcl/Tk manual entries. 3 | .\" 4 | .\" .AP type name in/out ?indent? 5 | .\" Start paragraph describing an argument to a library procedure. 6 | .\" type is type of argument (int, etc.), in/out is either "in", "out", 7 | .\" or "in/out" to describe whether procedure reads or modifies arg, 8 | .\" and indent is equivalent to second arg of .IP (shouldn't ever be 9 | .\" needed; use .AS below instead) 10 | .\" 11 | .\" .AS ?type? ?name? 12 | .\" Give maximum sizes of arguments for setting tab stops. Type and 13 | .\" name are examples of largest possible arguments that will be passed 14 | .\" to .AP later. If args are omitted, default tab stops are used. 15 | .\" 16 | .\" .BS 17 | .\" Start box enclosure. From here until next .BE, everything will be 18 | .\" enclosed in one large box. 19 | .\" 20 | .\" .BE 21 | .\" End of box enclosure. 22 | .\" 23 | .\" .CS 24 | .\" Begin code excerpt. 25 | .\" 26 | .\" .CE 27 | .\" End code excerpt. 28 | .\" 29 | .\" .VS ?version? ?br? 30 | .\" Begin vertical sidebar, for use in marking newly-changed parts 31 | .\" of man pages. The first argument is ignored and used for recording 32 | .\" the version when the .VS was added, so that the sidebars can be 33 | .\" found and removed when they reach a certain age. If another argument 34 | .\" is present, then a line break is forced before starting the sidebar. 35 | .\" 36 | .\" .VE 37 | .\" End of vertical sidebar. 38 | .\" 39 | .\" .DS 40 | .\" Begin an indented unfilled display. 41 | .\" 42 | .\" .DE 43 | .\" End of indented unfilled display. 44 | .\" 45 | .\" .SO ?manpage? 46 | .\" Start of list of standard options for a Tk widget. The manpage 47 | .\" argument defines where to look up the standard options; if 48 | .\" omitted, defaults to "options". The options follow on successive 49 | .\" lines, in three columns separated by tabs. 50 | .\" 51 | .\" .SE 52 | .\" End of list of standard options for a Tk widget. 53 | .\" 54 | .\" .OP cmdName dbName dbClass 55 | .\" Start of description of a specific option. cmdName gives the 56 | .\" option's name as specified in the class command, dbName gives 57 | .\" the option's name in the option database, and dbClass gives 58 | .\" the option's class in the option database. 59 | .\" 60 | .\" .UL arg1 arg2 61 | .\" Print arg1 underlined, then print arg2 normally. 62 | .\" 63 | .\" .QW arg1 ?arg2? 64 | .\" Print arg1 in quotes, then arg2 normally (for trailing punctuation). 65 | .\" 66 | .\" .PQ arg1 ?arg2? 67 | .\" Print an open parenthesis, arg1 in quotes, then arg2 normally 68 | .\" (for trailing punctuation) and then a closing parenthesis. 69 | .\" 70 | .\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. 71 | .if t .wh -1.3i ^B 72 | .nr ^l \n(.l 73 | .ad b 74 | .\" # Start an argument description 75 | .de AP 76 | .ie !"\\$4"" .TP \\$4 77 | .el \{\ 78 | . ie !"\\$2"" .TP \\n()Cu 79 | . el .TP 15 80 | .\} 81 | .ta \\n()Au \\n()Bu 82 | .ie !"\\$3"" \{\ 83 | \&\\$1 \\fI\\$2\\fP (\\$3) 84 | .\".b 85 | .\} 86 | .el \{\ 87 | .br 88 | .ie !"\\$2"" \{\ 89 | \&\\$1 \\fI\\$2\\fP 90 | .\} 91 | .el \{\ 92 | \&\\fI\\$1\\fP 93 | .\} 94 | .\} 95 | .. 96 | .\" # define tabbing values for .AP 97 | .de AS 98 | .nr )A 10n 99 | .if !"\\$1"" .nr )A \\w'\\$1'u+3n 100 | .nr )B \\n()Au+15n 101 | .\" 102 | .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n 103 | .nr )C \\n()Bu+\\w'(in/out)'u+2n 104 | .. 105 | .AS Tcl_Interp Tcl_CreateInterp in/out 106 | .\" # BS - start boxed text 107 | .\" # ^y = starting y location 108 | .\" # ^b = 1 109 | .de BS 110 | .br 111 | .mk ^y 112 | .nr ^b 1u 113 | .if n .nf 114 | .if n .ti 0 115 | .if n \l'\\n(.lu\(ul' 116 | .if n .fi 117 | .. 118 | .\" # BE - end boxed text (draw box now) 119 | .de BE 120 | .nf 121 | .ti 0 122 | .mk ^t 123 | .ie n \l'\\n(^lu\(ul' 124 | .el \{\ 125 | .\" Draw four-sided box normally, but don't draw top of 126 | .\" box if the box started on an earlier page. 127 | .ie !\\n(^b-1 \{\ 128 | \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' 129 | .\} 130 | .el \}\ 131 | \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' 132 | .\} 133 | .\} 134 | .fi 135 | .br 136 | .nr ^b 0 137 | .. 138 | .\" # VS - start vertical sidebar 139 | .\" # ^Y = starting y location 140 | .\" # ^v = 1 (for troff; for nroff this doesn't matter) 141 | .de VS 142 | .if !"\\$2"" .br 143 | .mk ^Y 144 | .ie n 'mc \s12\(br\s0 145 | .el .nr ^v 1u 146 | .. 147 | .\" # VE - end of vertical sidebar 148 | .de VE 149 | .ie n 'mc 150 | .el \{\ 151 | .ev 2 152 | .nf 153 | .ti 0 154 | .mk ^t 155 | \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' 156 | .sp -1 157 | .fi 158 | .ev 159 | .\} 160 | .nr ^v 0 161 | .. 162 | .\" # Special macro to handle page bottom: finish off current 163 | .\" # box/sidebar if in box/sidebar mode, then invoked standard 164 | .\" # page bottom macro. 165 | .de ^B 166 | .ev 2 167 | 'ti 0 168 | 'nf 169 | .mk ^t 170 | .if \\n(^b \{\ 171 | .\" Draw three-sided box if this is the box's first page, 172 | .\" draw two sides but no top otherwise. 173 | .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 174 | .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c 175 | .\} 176 | .if \\n(^v \{\ 177 | .nr ^x \\n(^tu+1v-\\n(^Yu 178 | \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c 179 | .\} 180 | .bp 181 | 'fi 182 | .ev 183 | .if \\n(^b \{\ 184 | .mk ^y 185 | .nr ^b 2 186 | .\} 187 | .if \\n(^v \{\ 188 | .mk ^Y 189 | .\} 190 | .. 191 | .\" # DS - begin display 192 | .de DS 193 | .RS 194 | .nf 195 | .sp 196 | .. 197 | .\" # DE - end display 198 | .de DE 199 | .fi 200 | .RE 201 | .sp 202 | .. 203 | .\" # SO - start of list of standard options 204 | .de SO 205 | 'ie '\\$1'' .ds So \\fBoptions\\fR 206 | 'el .ds So \\fB\\$1\\fR 207 | .SH "STANDARD OPTIONS" 208 | .LP 209 | .nf 210 | .ta 5.5c 11c 211 | .ft B 212 | .. 213 | .\" # SE - end of list of standard options 214 | .de SE 215 | .fi 216 | .ft R 217 | .LP 218 | See the \\*(So manual entry for details on the standard options. 219 | .. 220 | .\" # OP - start of full description for a single option 221 | .de OP 222 | .LP 223 | .nf 224 | .ta 4c 225 | Command-Line Name: \\fB\\$1\\fR 226 | Database Name: \\fB\\$2\\fR 227 | Database Class: \\fB\\$3\\fR 228 | .fi 229 | .IP 230 | .. 231 | .\" # CS - begin code excerpt 232 | .de CS 233 | .RS 234 | .nf 235 | .ta .25i .5i .75i 1i 236 | .. 237 | .\" # CE - end code excerpt 238 | .de CE 239 | .fi 240 | .RE 241 | .. 242 | .\" # UL - underline word 243 | .de UL 244 | \\$1\l'|0\(ul'\\$2 245 | .. 246 | .\" # QW - apply quotation marks to word 247 | .de QW 248 | .ie '\\*(lq'"' ``\\$1''\\$2 249 | .\"" fix emacs highlighting 250 | .el \\*(lq\\$1\\*(rq\\$2 251 | .. 252 | .\" # PQ - apply parens and quotation marks to word 253 | .de PQ 254 | .ie '\\*(lq'"' (``\\$1''\\$2)\\$3 255 | .\"" fix emacs highlighting 256 | .el (\\*(lq\\$1\\*(rq\\$2)\\$3 257 | .. 258 | .\" # QR - quoted range 259 | .de QR 260 | .ie '\\*(lq'"' ``\\$1''\\-``\\$2''\\$3 261 | .\"" fix emacs highlighting 262 | .el \\*(lq\\$1\\*(rq\\-\\*(lq\\$2\\*(rq\\$3 263 | .. 264 | .\" # MT - "empty" string 265 | .de MT 266 | .QW "" 267 | .. 268 | -------------------------------------------------------------------------------- /doc/scope.n: -------------------------------------------------------------------------------- 1 | '\" 2 | '\" Copyright (c) 1993-1998 Lucent Technologies, Inc. 3 | '\" 4 | '\" See the file "license.terms" for information on usage and redistribution 5 | '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. 6 | '\" 7 | .TH scope n "" itcl "[incr\ Tcl]" 8 | .so man.macros 9 | .BS 10 | '\" Note: do not modify the .SH NAME line immediately below! 11 | .SH NAME 12 | itcl::scope \- capture the namespace context for a variable 13 | .SH SYNOPSIS 14 | \fBitcl::scope \fIname\fR 15 | .BE 16 | 17 | .SH DESCRIPTION 18 | .PP 19 | Creates a scoped value for the specified \fIname\fR, which must 20 | be a variable name. If the \fIname\fR is an instance variable, 21 | then the scope command returns a name which will resolve in any 22 | context as an instance variable belonging to \fIobject\fR. 23 | The precise format of this name is an internal detail to Itcl. 24 | Use of such a scoped value makes it possible to use 25 | instance variables in conjunction with widgets. For example, if you 26 | have an object with a private variable \fCx\fR, and you can use 27 | \fCx\fR in conjunction with the \fC-textvariable\fR option of an 28 | entry widget. Before itcl3.0, only common variables could be used 29 | in this manner. 30 | .PP 31 | If the \fIname\fR is not an instance variable, then it must be 32 | a common variable or a global variable. In that case, the scope 33 | command returns the fully qualified name of the variable, e.g., 34 | \fC::foo::bar::x\fR. 35 | .PP 36 | If the \fIname\fR is not recognized as a variable, the scope 37 | command returns an error. 38 | .PP 39 | Ordinary variable names refer to variables in the global namespace. 40 | A scoped value captures a variable name together with its namespace 41 | context in a way that allows it to be referenced properly later. 42 | It is needed, for example, to wrap up variable names when a Tk 43 | widget is used within a namespace: 44 | .CS 45 | namespace foo { 46 | private variable mode 1 47 | 48 | radiobutton .rb1 -text "Mode #1" \ 49 | -variable [scope mode] -value 1 50 | pack .rb1 51 | 52 | radiobutton .rb2 -text "Mode #2" \ 53 | -variable [scope mode] -value 2 54 | pack .rb2 55 | } 56 | .CE 57 | Radiobuttons \fC.rb1\fR and \fC.rb2\fR interact via the variable 58 | "mode" contained in the namespace "foo". The \fBscope\fR command 59 | guarantees this by returning the fully qualified variable name 60 | \fC::foo::mode\fR. 61 | .PP 62 | You should never attempt to craft your own scoped variable names, 63 | even if you believe you've flawlessly reverse-engineered the encoding. 64 | Instead, you should always use the scope command to generate the 65 | variable name dynamically. Then, you can pass that name to a widget 66 | or to any other bit of code in your program. 67 | 68 | .SH KEYWORDS 69 | code, namespace, variable 70 | -------------------------------------------------------------------------------- /generic/itcl.h: -------------------------------------------------------------------------------- 1 | /* 2 | * itcl.h -- 3 | * 4 | * This file contains definitions for the C-implemeted part of a Itcl 5 | * this version of [incr Tcl] (Itcl) is a completely new implementation 6 | * based on TclOO extension of Tcl 8.5 7 | * It tries to provide the same interfaces as the original implementation 8 | * of Michael J. McLennan 9 | * Some small pieces of code are taken from that implementation 10 | * 11 | * Copyright (c) 2007 by Arnulf P. Wiedemann 12 | * 13 | * See the file "license.terms" for information on usage and redistribution of 14 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 | */ 16 | 17 | /* 18 | * ------------------------------------------------------------------------ 19 | * PACKAGE: [incr Tcl] 20 | * DESCRIPTION: Object-Oriented Extensions to Tcl 21 | * 22 | * [incr Tcl] provides object-oriented extensions to Tcl, much as 23 | * C++ provides object-oriented extensions to C. It provides a means 24 | * of encapsulating related procedures together with their shared data 25 | * in a local namespace that is hidden from the outside world. It 26 | * promotes code re-use through inheritance. More than anything else, 27 | * it encourages better organization of Tcl applications through the 28 | * object-oriented paradigm, leading to code that is easier to 29 | * understand and maintain. 30 | * 31 | * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: 32 | * 33 | * To add [incr Tcl] facilities to a Tcl application, modify the 34 | * Tcl_AppInit() routine as follows: 35 | * 36 | * 1) Include this header file near the top of the file containing 37 | * Tcl_AppInit(): 38 | * 39 | * #include "itcl.h" 40 | * 41 | * 2) Within the body of Tcl_AppInit(), add the following lines: 42 | * 43 | * if (Itcl_Init(interp) == TCL_ERROR) { 44 | * return TCL_ERROR; 45 | * } 46 | * 47 | * 3) Link your application with libitcl.a 48 | * 49 | * NOTE: An example file "tclAppInit.c" containing the changes shown 50 | * above is included in this distribution. 51 | * 52 | *--------------------------------------------------------------------- 53 | */ 54 | 55 | #ifndef ITCL_H_INCLUDED 56 | #define ITCL_H_INCLUDED 57 | 58 | #include 59 | 60 | #if (TCL_MAJOR_VERSION == 8) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 6) 61 | # error Itcl 4 build requires tcl.h from Tcl 8.6 or later 62 | #endif 63 | 64 | /* 65 | * For C++ compilers, use extern "C" 66 | */ 67 | 68 | #ifdef __cplusplus 69 | extern "C" { 70 | #endif 71 | 72 | #ifndef TCL_ALPHA_RELEASE 73 | # define TCL_ALPHA_RELEASE 0 74 | #endif 75 | #ifndef TCL_BETA_RELEASE 76 | # define TCL_BETA_RELEASE 1 77 | #endif 78 | #ifndef TCL_FINAL_RELEASE 79 | # define TCL_FINAL_RELEASE 2 80 | #endif 81 | 82 | #define ITCL_MAJOR_VERSION 4 83 | #define ITCL_MINOR_VERSION 3 84 | #define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE 85 | #define ITCL_RELEASE_SERIAL 3 86 | 87 | #define ITCL_VERSION "4.3" 88 | #define ITCL_PATCH_LEVEL "4.3.3" 89 | 90 | 91 | /* 92 | * A special definition used to allow this header file to be included from 93 | * windows resource files so that they can obtain version information. 94 | * RC_INVOKED is defined by default by the windows RC tool. 95 | * 96 | * Resource compilers don't like all the C stuff, like typedefs and function 97 | * declarations, that occur below, so block them out. 98 | */ 99 | 100 | #ifndef RC_INVOKED 101 | 102 | #define ITCL_NAMESPACE "::itcl" 103 | 104 | #ifndef ITCLAPI 105 | # if defined(BUILD_itcl) 106 | # define ITCLAPI MODULE_SCOPE 107 | # else 108 | # define ITCLAPI extern 109 | # undef USE_ITCL_STUBS 110 | # define USE_ITCL_STUBS 1 111 | # endif 112 | #endif 113 | 114 | #if defined(BUILD_itcl) && !defined(STATIC_BUILD) 115 | # define ITCL_EXTERN extern DLLEXPORT 116 | #else 117 | # define ITCL_EXTERN extern 118 | #endif 119 | 120 | ITCL_EXTERN int Itcl_Init(Tcl_Interp *interp); 121 | ITCL_EXTERN int Itcl_SafeInit(Tcl_Interp *interp); 122 | 123 | /* 124 | * Protection levels: 125 | * 126 | * ITCL_PUBLIC - accessible from any namespace 127 | * ITCL_PROTECTED - accessible from namespace that imports in "protected" mode 128 | * ITCL_PRIVATE - accessible only within the namespace that contains it 129 | */ 130 | #define ITCL_PUBLIC 1 131 | #define ITCL_PROTECTED 2 132 | #define ITCL_PRIVATE 3 133 | #define ITCL_DEFAULT_PROTECT 4 134 | 135 | #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 7) && !defined(Tcl_Size) 136 | # define Tcl_Size int 137 | #endif 138 | 139 | /* 140 | * Generic stack. 141 | */ 142 | typedef struct Itcl_Stack { 143 | void **values; /* values on stack */ 144 | Tcl_Size len; /* number of values on stack */ 145 | Tcl_Size max; /* maximum size of stack */ 146 | void *space[5]; /* initial space for stack data */ 147 | } Itcl_Stack; 148 | 149 | #define Itcl_GetStackSize(stackPtr) ((stackPtr)->len) 150 | 151 | /* 152 | * Generic linked list. 153 | */ 154 | struct Itcl_List; 155 | typedef struct Itcl_ListElem { 156 | struct Itcl_List* owner; /* list containing this element */ 157 | void *value; /* value associated with this element */ 158 | struct Itcl_ListElem *prev; /* previous element in linked list */ 159 | struct Itcl_ListElem *next; /* next element in linked list */ 160 | } Itcl_ListElem; 161 | 162 | typedef struct Itcl_List { 163 | int validate; /* validation stamp */ 164 | Tcl_Size num; /* number of elements */ 165 | struct Itcl_ListElem *head; /* previous element in linked list */ 166 | struct Itcl_ListElem *tail; /* next element in linked list */ 167 | } Itcl_List; 168 | 169 | #define Itcl_FirstListElem(listPtr) ((listPtr)->head) 170 | #define Itcl_LastListElem(listPtr) ((listPtr)->tail) 171 | #define Itcl_NextListElem(elemPtr) ((elemPtr)->next) 172 | #define Itcl_PrevListElem(elemPtr) ((elemPtr)->prev) 173 | #define Itcl_GetListLength(listPtr) ((listPtr)->num) 174 | #define Itcl_GetListValue(elemPtr) ((elemPtr)->value) 175 | 176 | /* 177 | * Token representing the state of an interpreter. 178 | */ 179 | typedef struct Itcl_InterpState_ *Itcl_InterpState; 180 | 181 | 182 | /* 183 | * Include all the public API, generated from itcl.decls. 184 | */ 185 | 186 | #include "itclDecls.h" 187 | 188 | #endif /* RC_INVOKED */ 189 | 190 | /* 191 | * end block for C++ 192 | */ 193 | 194 | #ifdef __cplusplus 195 | } 196 | #endif 197 | 198 | #endif /* ITCL_H_INCLUDED */ 199 | -------------------------------------------------------------------------------- /generic/itcl2TclOO.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef _TCLINT 3 | typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); 4 | #endif 5 | 6 | #ifndef TCL_OO_INTERNAL_H 7 | typedef int (TclOO_PreCallProc)(void *clientData, Tcl_Interp *interp, 8 | Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished); 9 | typedef int (TclOO_PostCallProc)(void *clientData, Tcl_Interp *interp, 10 | Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result); 11 | #endif 12 | 13 | MODULE_SCOPE int Itcl_NRRunCallbacks(Tcl_Interp *interp, void *rootPtr); 14 | MODULE_SCOPE void * Itcl_GetCurrentCallbackPtr(Tcl_Interp *interp); 15 | MODULE_SCOPE Tcl_Method Itcl_NewProcClassMethod(Tcl_Interp *interp, Tcl_Class clsPtr, 16 | TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, 17 | ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, 18 | Tcl_Obj *argsObj, Tcl_Obj *bodyObj, void **clientData2); 19 | MODULE_SCOPE Tcl_Method Itcl_NewProcMethod(Tcl_Interp *interp, Tcl_Object oPtr, 20 | TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, 21 | ProcErrorProc *errProc, void *clientData, Tcl_Obj *nameObj, 22 | Tcl_Obj *argsObj, Tcl_Obj *bodyObj, void **clientData2); 23 | MODULE_SCOPE int Itcl_PublicObjectCmd(void *clientData, Tcl_Interp *interp, 24 | Tcl_Class clsPtr, Tcl_Size objc, Tcl_Obj *const *objv); 25 | MODULE_SCOPE Tcl_Method Itcl_NewForwardClassMethod(Tcl_Interp *interp, 26 | Tcl_Class clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); 27 | MODULE_SCOPE int Itcl_SelfCmd(void *clientData, Tcl_Interp *interp, 28 | int objc, Tcl_Obj *const *objv); 29 | MODULE_SCOPE int Itcl_IsMethodCallFrame(Tcl_Interp *interp); 30 | MODULE_SCOPE int Itcl_InvokeEnsembleMethod(Tcl_Interp *interp, Tcl_Namespace *nsPtr, 31 | Tcl_Obj *namePtr, Tcl_Proc *procPtr, Tcl_Size objc, Tcl_Obj *const *objv); 32 | MODULE_SCOPE int Itcl_InvokeProcedureMethod(void *clientData, Tcl_Interp *interp, 33 | int objc, Tcl_Obj *const *objv); 34 | -------------------------------------------------------------------------------- /generic/itclMigrate2TclCore.c: -------------------------------------------------------------------------------- 1 | /* 2 | * ------------------------------------------------------------------------ 3 | * PACKAGE: [incr Tcl] 4 | * DESCRIPTION: Object-Oriented Extensions to Tcl 5 | * 6 | * This file contains procedures that belong in the Tcl/Tk core. 7 | * Hopefully, they'll migrate there soon. 8 | * 9 | * ======================================================================== 10 | * AUTHOR: Arnulf Wiedemann 11 | * 12 | * ======================================================================== 13 | * Copyright (c) 1993-1998 Lucent Technologies, Inc. 14 | * ------------------------------------------------------------------------ 15 | * See the file "license.terms" for information on usage and redistribution 16 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17 | */ 18 | #include 19 | #include "itclInt.h" 20 | 21 | int 22 | Itcl_SetCallFrameResolver( 23 | Tcl_Interp *interp, 24 | Tcl_Resolve *resolvePtr) 25 | { 26 | CallFrame *framePtr = ((Interp *)interp)->framePtr; 27 | if (framePtr != NULL) { 28 | #ifdef ITCL_USE_MODIFIED_TCL_H 29 | framePtr->isProcCallFrame |= FRAME_HAS_RESOLVER; 30 | framePtr->resolvePtr = resolvePtr; 31 | #elif defined(__cplusplus) 32 | (void)resolvePtr; 33 | #endif 34 | return TCL_OK; 35 | } 36 | return TCL_ERROR; 37 | } 38 | 39 | int 40 | _Tcl_SetNamespaceResolver( 41 | Tcl_Namespace *nsPtr, 42 | Tcl_Resolve *resolvePtr) 43 | { 44 | if (nsPtr == NULL) { 45 | return TCL_ERROR; 46 | } 47 | #ifdef ITCL_USE_MODIFIED_TCL_H 48 | ((Namespace *)nsPtr)->resolvePtr = resolvePtr; 49 | #elif defined(__cplusplus) 50 | (void)resolvePtr; 51 | #endif 52 | return TCL_OK; 53 | } 54 | 55 | Tcl_Var 56 | Tcl_NewNamespaceVar( 57 | TCL_UNUSED(Tcl_Interp *), 58 | Tcl_Namespace *nsPtr, 59 | const char *varName) 60 | { 61 | Var *varPtr = NULL; 62 | int isNew; 63 | 64 | if ((nsPtr == NULL) || (varName == NULL)) { 65 | return NULL; 66 | } 67 | 68 | varPtr = TclVarHashCreateVar(&((Namespace *)nsPtr)->varTable, 69 | varName, &isNew); 70 | if (varPtr) { 71 | TclSetVarNamespaceVar(varPtr); 72 | } 73 | return (Tcl_Var)varPtr; 74 | } 75 | 76 | void 77 | Itcl_PreserveVar( 78 | Tcl_Var var) 79 | { 80 | Var *varPtr = (Var *)var; 81 | 82 | VarHashRefCount(varPtr)++; 83 | } 84 | 85 | void 86 | Itcl_ReleaseVar( 87 | Tcl_Var var) 88 | { 89 | Var *varPtr = (Var *)var; 90 | 91 | VarHashRefCount(varPtr)--; 92 | TclCleanupVar(varPtr, NULL); 93 | } 94 | 95 | Tcl_CallFrame * 96 | Itcl_GetUplevelCallFrame( 97 | Tcl_Interp *interp, 98 | int level) 99 | { 100 | CallFrame *framePtr; 101 | if (level < 0) { 102 | return NULL; 103 | } 104 | framePtr = ((Interp *)interp)->varFramePtr; 105 | while ((framePtr != NULL) && (level-- > 0)) { 106 | framePtr = framePtr->callerVarPtr; 107 | } 108 | if (framePtr == NULL) { 109 | return NULL; 110 | } 111 | return (Tcl_CallFrame *)framePtr; 112 | } 113 | 114 | Tcl_CallFrame * 115 | Itcl_ActivateCallFrame( 116 | Tcl_Interp *interp, 117 | Tcl_CallFrame *framePtr) 118 | { 119 | Interp *iPtr = (Interp*)interp; 120 | CallFrame *oldFramePtr; 121 | 122 | oldFramePtr = iPtr->varFramePtr; 123 | iPtr->varFramePtr = (CallFrame *) framePtr; 124 | 125 | return (Tcl_CallFrame *) oldFramePtr; 126 | } 127 | 128 | Tcl_Namespace * 129 | Itcl_GetUplevelNamespace( 130 | Tcl_Interp *interp, 131 | int level) 132 | { 133 | CallFrame *framePtr; 134 | if (level < 0) { 135 | return NULL; 136 | } 137 | framePtr = ((Interp *)interp)->framePtr; 138 | while ((framePtr != NULL) && (level-- > 0)) { 139 | framePtr = framePtr->callerVarPtr; 140 | } 141 | if (framePtr == NULL) { 142 | return NULL; 143 | } 144 | return (Tcl_Namespace *)framePtr->nsPtr; 145 | } 146 | 147 | void * 148 | Itcl_GetCallFrameClientData( 149 | Tcl_Interp *interp) 150 | { 151 | /* suggested fix for SF bug #250 use varFramePtr instead of framePtr 152 | * seems to have no side effect concerning test suite, but does NOT fix the bug 153 | */ 154 | CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 155 | if (framePtr == NULL) { 156 | return NULL; 157 | } 158 | return framePtr->clientData; 159 | } 160 | 161 | int 162 | Itcl_SetCallFrameNamespace( 163 | Tcl_Interp *interp, 164 | Tcl_Namespace *nsPtr) 165 | { 166 | CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 167 | if (framePtr == NULL) { 168 | return TCL_ERROR; 169 | } 170 | ((Interp *)interp)->varFramePtr->nsPtr = (Namespace *)nsPtr; 171 | return TCL_OK; 172 | } 173 | 174 | size_t 175 | Itcl_GetCallVarFrameObjc( 176 | Tcl_Interp *interp) 177 | { 178 | CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 179 | if (framePtr == NULL) { 180 | return 0; 181 | } 182 | return framePtr->objc; 183 | } 184 | 185 | Tcl_Obj *const * 186 | Itcl_GetCallVarFrameObjv( 187 | Tcl_Interp *interp) 188 | { 189 | CallFrame *framePtr = ((Interp *)interp)->varFramePtr; 190 | if (framePtr == NULL) { 191 | return NULL; 192 | } 193 | return framePtr->objv; 194 | } 195 | 196 | Tcl_Size 197 | Itcl_GetCallFrameObjc( 198 | Tcl_Interp *interp) 199 | { 200 | CallFrame *framePtr = ((Interp *)interp)->framePtr; 201 | if (framePtr == NULL) { 202 | return 0; 203 | } 204 | return ((Interp *)interp)->framePtr->objc; 205 | } 206 | 207 | Tcl_Obj *const * 208 | Itcl_GetCallFrameObjv( 209 | Tcl_Interp *interp) 210 | { 211 | CallFrame *framePtr = ((Interp *)interp)->framePtr; 212 | if (framePtr == NULL) { 213 | return NULL; 214 | } 215 | return ((Interp *)interp)->framePtr->objv; 216 | } 217 | 218 | int 219 | Itcl_IsCallFrameArgument( 220 | Tcl_Interp *interp, 221 | const char *name) 222 | { 223 | CallFrame *varFramePtr = ((Interp *)interp)->framePtr; 224 | Proc *procPtr; 225 | 226 | if (varFramePtr == NULL) { 227 | return 0; 228 | } 229 | if (!varFramePtr->isProcCallFrame) { 230 | return 0; 231 | } 232 | procPtr = varFramePtr->procPtr; 233 | /* 234 | * Search through compiled locals first... 235 | */ 236 | if (procPtr) { 237 | CompiledLocal *localPtr = procPtr->firstLocalPtr; 238 | int nameLen = strlen(name); 239 | 240 | for (;localPtr != NULL; localPtr = localPtr->nextPtr) { 241 | if (TclIsVarArgument(localPtr)) { 242 | char *localName = localPtr->name; 243 | if ((name[0] == localName[0]) 244 | && (nameLen == localPtr->nameLength) 245 | && (strcmp(name, localName) == 0)) { 246 | return 1; 247 | } 248 | } 249 | } 250 | } 251 | return 0; 252 | } 253 | -------------------------------------------------------------------------------- /generic/itclMigrate2TclCore.h: -------------------------------------------------------------------------------- 1 | #ifndef ITCL_USE_MODIFIED_TCL_H 2 | /* this is just to provide the definition. This struct is only used if 3 | * infoPtr->useOldResolvers == 0 which is not the default 4 | */ 5 | #define FRAME_HAS_RESOLVER 0x100 6 | typedef Tcl_Command (Tcl_CmdAliasProc)(Tcl_Interp *interp, 7 | Tcl_Namespace *nsPtr, const char *cmdName, 8 | void *clientData); 9 | typedef Tcl_Var (Tcl_VarAliasProc)(Tcl_Interp *interp, 10 | Tcl_Namespace *nsPtr, const char *varName, 11 | void *clientData); 12 | 13 | #ifndef _TCL_RESOLVE_DEFINED 14 | typedef struct Tcl_Resolve { 15 | Tcl_VarAliasProc *varProcPtr; 16 | Tcl_CmdAliasProc *cmdProcPtr; 17 | void *clientData; 18 | } Tcl_Resolve; 19 | #define _TCL_RESOLVE_DEFINED 1 20 | #endif 21 | #endif 22 | 23 | #ifndef _TCLINT 24 | struct Tcl_ResolvedVarInfo; 25 | 26 | typedef Tcl_Var (Tcl_ResolveRuntimeVarProc)(Tcl_Interp *interp, 27 | struct Tcl_ResolvedVarInfo *vinfoPtr); 28 | 29 | typedef void (Tcl_ResolveVarDeleteProc)(struct Tcl_ResolvedVarInfo *vinfoPtr); 30 | 31 | /* 32 | * The following structure encapsulates the routines needed to resolve a 33 | * variable reference at runtime. Any variable specific state will typically 34 | * be appended to this structure. 35 | */ 36 | 37 | typedef struct Tcl_ResolvedVarInfo { 38 | Tcl_ResolveRuntimeVarProc *fetchProc; 39 | Tcl_ResolveVarDeleteProc *deleteProc; 40 | } Tcl_ResolvedVarInfo; 41 | 42 | typedef int (Tcl_ResolveCompiledVarProc) (Tcl_Interp *interp, 43 | const char *name, Tcl_Size length, Tcl_Namespace *context, 44 | Tcl_ResolvedVarInfo **rPtr); 45 | 46 | typedef int (Tcl_ResolveVarProc) (Tcl_Interp *interp, const char *name, 47 | Tcl_Namespace *context, int flags, Tcl_Var *rPtr); 48 | 49 | typedef int (Tcl_ResolveCmdProc) (Tcl_Interp *interp, const char *name, 50 | Tcl_Namespace *context, int flags, Tcl_Command *rPtr); 51 | 52 | typedef struct Tcl_ResolverInfo { 53 | Tcl_ResolveCmdProc *cmdResProc; 54 | /* Procedure handling command name 55 | * resolution. */ 56 | Tcl_ResolveVarProc *varResProc; 57 | /* Procedure handling variable name resolution 58 | * for variables that can only be handled at 59 | * runtime. */ 60 | Tcl_ResolveCompiledVarProc *compiledVarResProc; 61 | /* Procedure handling variable name resolution 62 | * at compile time. */ 63 | } Tcl_ResolverInfo; 64 | #endif 65 | 66 | 67 | /* here come the definitions for code which should be migrated to Tcl core */ 68 | /* these functions DO NOT exist and are not published */ 69 | #ifndef _TCL_PROC_DEFINED 70 | typedef struct Tcl_Proc_ *Tcl_Proc; 71 | #define _TCL_PROC_DEFINED 1 72 | #endif 73 | 74 | MODULE_SCOPE Tcl_Var Tcl_NewNamespaceVar(Tcl_Interp *interp, Tcl_Namespace *nsPtr, 75 | const char *varName); 76 | MODULE_SCOPE void Itcl_PreserveVar(Tcl_Var var); 77 | MODULE_SCOPE void Itcl_ReleaseVar(Tcl_Var var); 78 | MODULE_SCOPE int Itcl_IsCallFrameArgument(Tcl_Interp *interp, const char *name); 79 | MODULE_SCOPE size_t Itcl_GetCallVarFrameObjc(Tcl_Interp *interp); 80 | MODULE_SCOPE Tcl_Obj *const * Itcl_GetCallVarFrameObjv(Tcl_Interp *interp); 81 | #define Tcl_SetNamespaceResolver _Tcl_SetNamespaceResolver 82 | MODULE_SCOPE int _Tcl_SetNamespaceResolver(Tcl_Namespace *nsPtr, 83 | struct Tcl_Resolve *resolvePtr); 84 | -------------------------------------------------------------------------------- /generic/itclStubLib.c: -------------------------------------------------------------------------------- 1 | /* 2 | * SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 3 | */ 4 | 5 | #define USE_TCL_STUBS 1 6 | #define USE_ITCL_STUBS 1 7 | #include "itclInt.h" 8 | 9 | #undef Itcl_InitStubs 10 | 11 | MODULE_SCOPE const ItclStubs *itclStubsPtr; 12 | MODULE_SCOPE const ItclIntStubs *itclIntStubsPtr; 13 | 14 | const ItclStubs *itclStubsPtr = NULL; 15 | const ItclIntStubs *itclIntStubsPtr = NULL; 16 | 17 | /* 18 | *---------------------------------------------------------------------- 19 | * 20 | * Itcl_InitStubs -- 21 | * Load the tclOO package, initialize stub table pointer. Do not call 22 | * this function directly, use Itcl_InitStubs() macro instead. 23 | * 24 | * Results: 25 | * The actual version of the package that satisfies the request, or 26 | * NULL to indicate that an error occurred. 27 | * 28 | * Side effects: 29 | * Sets the stub table pointer. 30 | * 31 | */ 32 | 33 | const char * 34 | Itcl_InitStubs( 35 | Tcl_Interp *interp, 36 | const char *version, 37 | int exact) 38 | { 39 | const char *packageName = "itcl"; 40 | const char *errMsg = NULL; 41 | void *clientData = NULL; 42 | const ItclStubs *stubsPtr; 43 | const ItclIntStubs *intStubsPtr; 44 | const char *actualVersion; 45 | 46 | actualVersion = 47 | Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData); 48 | stubsPtr = (const ItclStubs *)clientData; 49 | if ((actualVersion == NULL) || (clientData == NULL)) { 50 | return NULL; 51 | } 52 | intStubsPtr = stubsPtr->hooks ? 53 | stubsPtr->hooks->itclIntStubs : NULL; 54 | 55 | if (!stubsPtr || !intStubsPtr) { 56 | errMsg = "missing stub table pointer"; 57 | goto error; 58 | } 59 | itclStubsPtr = stubsPtr; 60 | itclIntStubsPtr = intStubsPtr; 61 | return actualVersion; 62 | 63 | error: 64 | Tcl_ResetResult(interp); 65 | Tcl_AppendResult(interp, "Error loading ", packageName, " package", 66 | " (requested version '", version, "', loaded version '", 67 | actualVersion, "'): ", errMsg, NULL); 68 | return NULL; 69 | } 70 | -------------------------------------------------------------------------------- /generic/itclTclIntStubsFcn.c: -------------------------------------------------------------------------------- 1 | /* 2 | * ------------------------------------------------------------------------ 3 | * PACKAGE: [incr Tcl] 4 | * DESCRIPTION: Object-Oriented Extensions to Tcl 5 | * 6 | * This file contains procedures that use the internal Tcl core stubs 7 | * entries. 8 | * 9 | * ======================================================================== 10 | * AUTHOR: Arnulf Wiedemann 11 | * 12 | * ------------------------------------------------------------------------ 13 | * See the file "license.terms" for information on usage and redistribution 14 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15 | */ 16 | #include 17 | #include "itclInt.h" 18 | 19 | Tcl_Command 20 | _Tcl_GetOriginalCommand( 21 | Tcl_Command command) 22 | { 23 | return TclGetOriginalCommand(command); 24 | } 25 | 26 | int 27 | _Tcl_CreateProc( 28 | Tcl_Interp *interp, /* Interpreter containing proc. */ 29 | Tcl_Namespace *nsPtr, /* Namespace containing this proc. */ 30 | const char *procName, /* Unqualified name of this proc. */ 31 | Tcl_Obj *argsPtr, /* Description of arguments. */ 32 | Tcl_Obj *bodyPtr, /* Command body. */ 33 | Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */ 34 | { 35 | int code = TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr, 36 | bodyPtr, (Proc **)procPtrPtr); 37 | (*(Proc **)procPtrPtr)->cmdPtr = NULL; 38 | return code; 39 | } 40 | 41 | Tcl_ObjCmdProc * 42 | _Tcl_GetObjInterpProc( 43 | void) 44 | { 45 | return TclGetObjInterpProc(); 46 | } 47 | 48 | void 49 | _Tcl_ProcDeleteProc( 50 | void *clientData) 51 | { 52 | TclProcDeleteProc(clientData); 53 | } 54 | 55 | int 56 | Itcl_RenameCommand( 57 | Tcl_Interp *interp, 58 | const char *oldName, 59 | const char *newName) 60 | { 61 | return TclRenameCommand(interp, oldName, newName); 62 | } 63 | 64 | int 65 | Itcl_PushCallFrame( 66 | Tcl_Interp * interp, 67 | Tcl_CallFrame * framePtr, 68 | Tcl_Namespace * nsPtr, 69 | int isProcCallFrame) 70 | { 71 | return Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame); 72 | } 73 | 74 | void 75 | Itcl_PopCallFrame( 76 | Tcl_Interp * interp) 77 | { 78 | Tcl_PopCallFrame(interp); 79 | } 80 | 81 | void 82 | Itcl_GetVariableFullName( 83 | Tcl_Interp * interp, 84 | Tcl_Var variable, 85 | Tcl_Obj * objPtr) 86 | { 87 | Tcl_GetVariableFullName(interp, variable, objPtr); 88 | } 89 | 90 | Tcl_Var 91 | Itcl_FindNamespaceVar( 92 | Tcl_Interp * interp, 93 | const char * name, 94 | Tcl_Namespace * contextNsPtr, 95 | int flags) 96 | { 97 | return Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags); 98 | } 99 | 100 | void 101 | Itcl_SetNamespaceResolvers ( 102 | Tcl_Namespace * namespacePtr, 103 | Tcl_ResolveCmdProc * cmdProc, 104 | Tcl_ResolveVarProc * varProc, 105 | Tcl_ResolveCompiledVarProc * compiledVarProc) 106 | { 107 | Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc); 108 | } 109 | 110 | Tcl_HashTable * 111 | Itcl_GetNamespaceCommandTable( 112 | Tcl_Namespace *nsPtr) 113 | { 114 | return TclGetNamespaceCommandTable(nsPtr); 115 | } 116 | 117 | Tcl_HashTable * 118 | Itcl_GetNamespaceChildTable( 119 | Tcl_Namespace *nsPtr) 120 | { 121 | return TclGetNamespaceChildTable(nsPtr); 122 | } 123 | 124 | int 125 | Itcl_InitRewriteEnsemble( 126 | Tcl_Interp *interp, 127 | size_t numRemoved, 128 | size_t numInserted, 129 | TCL_UNUSED(size_t) /* objc */, 130 | Tcl_Obj *const *objv) 131 | { 132 | return TclInitRewriteEnsemble(interp, numRemoved, numInserted, objv); 133 | } 134 | 135 | void 136 | Itcl_ResetRewriteEnsemble( 137 | Tcl_Interp *interp, 138 | int isRootEnsemble) 139 | { 140 | TclResetRewriteEnsemble(interp, isRootEnsemble); 141 | } 142 | 143 | 144 | -------------------------------------------------------------------------------- /generic/itclTclIntStubsFcn.h: -------------------------------------------------------------------------------- 1 | /* these functions are Tcl internal stubs so make an Itcl_* wrapper */ 2 | MODULE_SCOPE void Itcl_GetVariableFullName (Tcl_Interp * interp, 3 | Tcl_Var variable, Tcl_Obj * objPtr); 4 | MODULE_SCOPE Tcl_Var Itcl_FindNamespaceVar (Tcl_Interp * interp, 5 | const char * name, Tcl_Namespace * contextNsPtr, int flags); 6 | MODULE_SCOPE void Itcl_SetNamespaceResolvers (Tcl_Namespace * namespacePtr, 7 | Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, 8 | Tcl_ResolveCompiledVarProc * compiledVarProc); 9 | 10 | #ifndef _TCL_PROC_DEFINED 11 | typedef struct Tcl_Proc_ *Tcl_Proc; 12 | #define _TCL_PROC_DEFINED 1 13 | #endif 14 | #ifndef _TCL_RESOLVE_DEFINED 15 | struct Tcl_Resolve; 16 | #endif 17 | 18 | #define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand 19 | #define Tcl_CreateProc _Tcl_CreateProc 20 | #define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc 21 | #define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc 22 | 23 | MODULE_SCOPE Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command); 24 | MODULE_SCOPE int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr, 25 | const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, 26 | Tcl_Proc *procPtrPtr); 27 | MODULE_SCOPE void _Tcl_ProcDeleteProc(void *clientData); 28 | MODULE_SCOPE Tcl_ObjCmdProc *_Tcl_GetObjInterpProc(void); 29 | MODULE_SCOPE int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName, 30 | const char *newName); 31 | MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr); 32 | MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr); 33 | MODULE_SCOPE int Itcl_InitRewriteEnsemble(Tcl_Interp *interp, size_t numRemoved, 34 | size_t numInserted, size_t objc, Tcl_Obj *const *objv); 35 | MODULE_SCOPE void Itcl_ResetRewriteEnsemble(Tcl_Interp *interp, 36 | int isRootEnsemble); 37 | 38 | 39 | -------------------------------------------------------------------------------- /generic/itclTestRegisterC.c: -------------------------------------------------------------------------------- 1 | /* 2 | * ------------------------------------------------------------------------ 3 | * PACKAGE: [incr Tcl] 4 | * DESCRIPTION: Object-Oriented Extensions to Tcl 5 | * 6 | * [incr Tcl] provides object-oriented extensions to Tcl, much as 7 | * C++ provides object-oriented extensions to C. It provides a means 8 | * of encapsulating related procedures together with their shared data 9 | * in a local namespace that is hidden from the outside world. It 10 | * promotes code re-use through inheritance. More than anything else, 11 | * it encourages better organization of Tcl applications through the 12 | * object-oriented paradigm, leading to code that is easier to 13 | * understand and maintain. 14 | * 15 | * This part adds a mechanism for integrating C procedures into 16 | * [incr Tcl] classes as methods and procs. Each C procedure must 17 | * either be declared via Itcl_RegisterC() or dynamically loaded. 18 | * 19 | * ======================================================================== 20 | * AUTHOR: Arnulf Wiedemann 21 | * ======================================================================== 22 | * Copyright (c) Arnulf Wiedemann 23 | * ------------------------------------------------------------------------ 24 | * See the file "license.terms" for information on usage and redistribution 25 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 26 | */ 27 | #ifdef ITCL_DEBUG_C_INTERFACE 28 | 29 | #include 30 | #include "itclInt.h" 31 | 32 | Tcl_CmdProc cArgFunc; 33 | Tcl_ObjCmdProc cObjFunc; 34 | 35 | int 36 | cArgFunc( 37 | void *clientData, 38 | Tcl_Interp *interp, 39 | int argc, 40 | const char **argv) 41 | { 42 | int result; 43 | ItclObjectInfo * infoPtr = NULL; 44 | ItclClass *iclsPtr = NULL; 45 | ItclClass * classPtr; 46 | ItclObject * rioPtr = (ItclObject *)1; 47 | Tcl_Obj * objv[4]; 48 | FOREACH_HASH_DECLS; 49 | 50 | //fprintf(stderr, "argc: %d\n", argc); 51 | if (argc != 4) { 52 | Tcl_AppendResult(interp, "wrong #args: should be ::itcl::parser::handleClass className className objectName", NULL); 53 | return TCL_ERROR; 54 | } 55 | objv[0] = Tcl_NewStringObj(argv[0], TCL_INDEX_NONE); 56 | objv[1] = Tcl_NewStringObj(argv[1], TCL_INDEX_NONE); /* class name */ 57 | objv[2] = Tcl_NewStringObj(argv[2], TCL_INDEX_NONE); /* full class name */ 58 | objv[3] = Tcl_NewStringObj(argv[3], TCL_INDEX_NONE); /* object name */ 59 | Tcl_IncrRefCount(objv[0]); 60 | Tcl_IncrRefCount(objv[1]); 61 | Tcl_IncrRefCount(objv[2]); 62 | Tcl_IncrRefCount(objv[3]); 63 | infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); 64 | FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { 65 | if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || 66 | strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { 67 | iclsPtr = classPtr; 68 | break; 69 | } 70 | } 71 | if (iclsPtr == NULL) { 72 | Tcl_AppendResult(interp, "no such class: ", Tcl_GetString(objv[2]), NULL); 73 | return TCL_ERROR; 74 | } 75 | 76 | /* try to create an object for a class as a test for calling a C function from 77 | * an Itcl class. See file CreateItclObjectWithC_example.tcl in library directory 78 | */ 79 | result = Itcl_CreateObject(interp, Tcl_GetString(objv[3]), iclsPtr, 4, objv, &rioPtr); 80 | return result; 81 | } 82 | 83 | int 84 | cObjFunc( 85 | void *clientData, 86 | Tcl_Interp *interp, 87 | int objc, 88 | Tcl_Obj *const *objv) 89 | { 90 | Tcl_Namespace *nsPtr; 91 | ItclObjectInfo * infoPtr = NULL; 92 | ItclClass *iclsPtr = NULL; 93 | ItclClass * classPtr; 94 | FOREACH_HASH_DECLS; 95 | int i; 96 | 97 | ItclShowArgs(0, "cObjFunc called", objc, objv); 98 | fprintf(stderr, "objv: %d %p\n", objc, objv); 99 | for(i = 0; ifullName); 104 | infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); 105 | FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { 106 | if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || 107 | strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { 108 | iclsPtr = classPtr; 109 | break; 110 | } 111 | } 112 | fprintf(stderr, "IP2:%p %p %p\n",interp, clientData, iclsPtr); 113 | return TCL_OK; 114 | } 115 | 116 | 117 | void 118 | RegisterDebugCFunctions(Tcl_Interp *interp) 119 | { 120 | int result; 121 | 122 | /* args: interp, name, c-function, clientdata, deleteproc */ 123 | result = Itcl_RegisterC(interp, "cArgFunc", cArgFunc, NULL, NULL); 124 | result = Itcl_RegisterObjC(interp, "cObjFunc", cObjFunc, NULL, NULL); 125 | if (result != 0) { 126 | } 127 | } 128 | #endif 129 | -------------------------------------------------------------------------------- /itclConfig.sh.in: -------------------------------------------------------------------------------- 1 | # itclConfig.sh -- 2 | # 3 | # This shell script (for sh) is generated automatically by Itcl's 4 | # configure script. It will create shell variables for most of 5 | # the configuration options discovered by the configure script. 6 | # This script is intended to be included by the configure scripts 7 | # for Itcl extensions so that they don't have to figure this all 8 | # out for themselves. This file does not duplicate information 9 | # already provided by tclConfig.sh, so you may need to use that 10 | # file in addition to this one. 11 | # 12 | # The information in this file is specific to a single platform. 13 | 14 | # Itcl's version number. 15 | itcl_VERSION='@PACKAGE_VERSION@' 16 | ITCL_VERSION='@PACKAGE_VERSION@' 17 | 18 | # The name of the Itcl library (may be either a .a file or a shared library): 19 | itcl_LIB_FILE=@PKG_LIB_FILE@ 20 | ITCL_LIB_FILE=@PKG_LIB_FILE@ 21 | 22 | # String to pass to linker to pick up the Itcl library from its 23 | # build directory. 24 | itcl_BUILD_LIB_SPEC='@itcl_BUILD_LIB_SPEC@' 25 | ITCL_BUILD_LIB_SPEC='@itcl_BUILD_LIB_SPEC@' 26 | 27 | # String to pass to linker to pick up the Itcl library from its 28 | # installed directory. 29 | itcl_LIB_SPEC='@itcl_LIB_SPEC@' 30 | ITCL_LIB_SPEC='@itcl_LIB_SPEC@' 31 | 32 | # The name of the Itcl stub library (a .a file): 33 | itcl_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@ 34 | ITCL_STUB_LIB_FILE=@PKG_STUB_LIB_FILE@ 35 | 36 | # String to pass to linker to pick up the Itcl stub library from its 37 | # build directory. 38 | itcl_BUILD_STUB_LIB_SPEC='@itcl_BUILD_STUB_LIB_SPEC@' 39 | ITCL_BUILD_STUB_LIB_SPEC='@itcl_BUILD_STUB_LIB_SPEC@' 40 | 41 | # String to pass to linker to pick up the Itcl stub library from its 42 | # installed directory. 43 | itcl_STUB_LIB_SPEC='@itcl_STUB_LIB_SPEC@' 44 | ITCL_STUB_LIB_SPEC='@itcl_STUB_LIB_SPEC@' 45 | 46 | # String to pass to linker to pick up the Itcl stub library from its 47 | # build directory. 48 | itcl_BUILD_STUB_LIB_PATH='@itcl_BUILD_STUB_LIB_PATH@' 49 | ITCL_BUILD_STUB_LIB_PATH='@itcl_BUILD_STUB_LIB_PATH@' 50 | 51 | # String to pass to linker to pick up the Itcl stub library from its 52 | # installed directory. 53 | itcl_STUB_LIB_PATH='@itcl_STUB_LIB_PATH@' 54 | ITCL_STUB_LIB_PATH='@itcl_STUB_LIB_PATH@' 55 | 56 | # Location of the top-level source directories from which [incr Tcl] 57 | # was built. This is the directory that contains generic, unix, etc. 58 | # If [incr Tcl] was compiled in a different place than the directory 59 | # containing the source files, this points to the location of the sources, 60 | # not the location where [incr Tcl] was compiled. 61 | itcl_SRC_DIR='@itcl_SRC_DIR@' 62 | ITCL_SRC_DIR='@itcl_SRC_DIR@' 63 | 64 | # String to pass to the compiler so that an extension can 65 | # find installed Itcl headers. 66 | itcl_INCLUDE_SPEC='@itcl_INCLUDE_SPEC@' 67 | ITCL_INCLUDE_SPEC='@itcl_INCLUDE_SPEC@' 68 | -------------------------------------------------------------------------------- /itclWidget/aclocal.m4: -------------------------------------------------------------------------------- 1 | # 2 | # Include the TEA standard macro set 3 | # 4 | 5 | builtin(include,tclconfig/tcl.m4) 6 | 7 | # 8 | # Add here whatever m4 macros you want to define for your package 9 | # 10 | -------------------------------------------------------------------------------- /itclWidget/configure.ac: -------------------------------------------------------------------------------- 1 | #!/bin/bash -norc 2 | #-------------------------------------------------------------------- 3 | # Sample configure.ac for Tcl Extensions. The only places you should 4 | # need to modify this file are marked by the string __CHANGE__ 5 | #-------------------------------------------------------------------- 6 | 7 | #----------------------------------------------------------------------- 8 | # This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION 9 | # set as provided. These will also be added as -D defs in your Makefile 10 | # so you can encode the package version directly into the source files. 11 | #----------------------------------------------------------------------- 12 | 13 | AC_INIT([itclwidget],[4.3.3]) 14 | 15 | #-------------------------------------------------------------------- 16 | # Call TEA_INIT as the first TEA_ macro to set up initial vars. 17 | # This will define a ${TEA_PLATFORM} variable == "unix" or "windows" 18 | # as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE. 19 | #-------------------------------------------------------------------- 20 | 21 | TEA_INIT([3.9]) 22 | 23 | AC_PROG_LN_S 24 | CONFIG_CLEAN_FILES= 25 | if test ! -d $srcdir/tclconfig ; then 26 | if test -d $srcdir/../tclconfig ; then 27 | $LN_S $srcdir/../tclconfig tclconfig 28 | CONFIG_CLEAN_FILES=tclconfig 29 | fi 30 | fi 31 | AC_SUBST(CONFIG_CLEAN_FILES) 32 | 33 | AC_CONFIG_AUX_DIR(tclconfig) 34 | 35 | #-------------------------------------------------------------------- 36 | # Load the tclConfig.sh, tkConfig.sh and itclConfig.sh file 37 | #-------------------------------------------------------------------- 38 | 39 | TEA_PATH_TCLCONFIG 40 | TEA_LOAD_TCLCONFIG 41 | TEA_PATH_TKCONFIG 42 | TEA_LOAD_TKCONFIG 43 | 44 | TEA_PATH_CONFIG(itcl) 45 | TEA_LOAD_CONFIG(itcl) 46 | 47 | #----------------------------------------------------------------------- 48 | # Handle the --prefix=... option by defaulting to what Tcl gave. 49 | # Must be called after TEA_LOAD_TCLCONFIG and before TEA_SETUP_COMPILER. 50 | #----------------------------------------------------------------------- 51 | 52 | TEA_PREFIX 53 | 54 | #----------------------------------------------------------------------- 55 | # Standard compiler checks. 56 | # This sets up CC by using the CC env var, or looks for gcc otherwise. 57 | # This also calls AC_PROG_CC and a few others to create the basic setup 58 | # necessary to compile executables. 59 | #----------------------------------------------------------------------- 60 | 61 | TEA_SETUP_COMPILER 62 | 63 | #----------------------------------------------------------------------- 64 | # __CHANGE__ 65 | # Specify the C source files to compile in TEA_ADD_SOURCES, 66 | # public headers that need to be installed in TEA_ADD_HEADERS, 67 | # stub library C source files to compile in TEA_ADD_STUB_SOURCES, 68 | # and runtime Tcl library files in TEA_ADD_TCL_SOURCES. 69 | # This defines PKG(_STUB)_SOURCES, PKG(_STUB)_OBJECTS, PKG_HEADERS 70 | # and PKG_TCL_SOURCES. 71 | #----------------------------------------------------------------------- 72 | 73 | 74 | TEA_ADD_SOURCES([ 75 | itclWidgetBase.c 76 | itclWidgetBuiltin.c 77 | itclWidgetCmd.c 78 | itclWidgetInfo.c 79 | itclWidgetObject.c 80 | itclWidgetParse.c 81 | itclWidgetStubInit.c 82 | ]) 83 | TEA_ADD_HEADERS([ 84 | generic/itclWidgetInt.h 85 | ]) 86 | TEA_ADD_INCLUDES([-I. -I\"`${CYGPATH} ${srcdir}/generic`\"]) 87 | TEA_ADD_LIBS([]) 88 | TEA_ADD_CFLAGS([-I${itcl_INCLUDE_SPEC}]) 89 | TEA_ADD_STUB_SOURCES(itclWidgetStubLib.c) 90 | TEA_ADD_TCL_SOURCES([]) 91 | 92 | #-------------------------------------------------------------------- 93 | # __CHANGE__ 94 | # A few miscellaneous platform-specific items: 95 | # 96 | # Define any extra compiler flags in the PACKAGE_CFLAGS variable. 97 | # These will be appended to the current set of compiler flags for 98 | # your system. 99 | #-------------------------------------------------------------------- 100 | 101 | if test "${TEA_PLATFORM}" = "windows" ; then 102 | TEA_ADD_SOURCES([dllEntryPoint.c]) 103 | fi 104 | 105 | #-------------------------------------------------------------------- 106 | # __CHANGE__ 107 | # Choose which headers you need. Extension authors should try very 108 | # hard to only rely on the Tcl public header files. Internal headers 109 | # contain private data structures and are subject to change without 110 | # notice. 111 | # This must be done AFTER calling TEA_PATH_TCLCONFIG/TEA_LOAD_TCLCONFIG 112 | # so that we can extract TCL_SRC_DIR from the config file (in the case 113 | # of private headers 114 | #-------------------------------------------------------------------- 115 | 116 | #TEA_PUBLIC_TCL_HEADERS 117 | TEA_PRIVATE_TCL_HEADERS 118 | TEA_PUBLIC_TK_HEADERS 119 | TEA_PRIVATE_ITCL_HEADERS 120 | 121 | #-------------------------------------------------------------------- 122 | # Check whether --enable-threads or --disable-threads was given. 123 | # This auto-enables if Tcl was compiled threaded. 124 | #-------------------------------------------------------------------- 125 | 126 | TEA_ENABLE_THREADS 127 | 128 | #-------------------------------------------------------------------- 129 | # The statement below defines a collection of symbols related to 130 | # building as a shared library instead of a static library. 131 | #-------------------------------------------------------------------- 132 | 133 | TEA_ENABLE_SHARED 134 | 135 | #-------------------------------------------------------------------- 136 | # This macro figures out what flags to use with the compiler/linker 137 | # when building shared/static debug/optimized objects. This information 138 | # can be taken from the tclConfig.sh file, but this figures it all out. 139 | #-------------------------------------------------------------------- 140 | 141 | TEA_CONFIG_CFLAGS 142 | 143 | #-------------------------------------------------------------------- 144 | # Set the default compiler switches based on the --enable-symbols option. 145 | #-------------------------------------------------------------------- 146 | 147 | TEA_ENABLE_SYMBOLS 148 | 149 | #-------------------------------------------------------------------- 150 | # Everyone should be linking against the Tcl stub library. If you 151 | # can't for some reason, remove this definition. If you aren't using 152 | # stubs, you also need to modify the SHLIB_LD_LIBS setting below to 153 | # link against the non-stubbed Tcl library. 154 | #-------------------------------------------------------------------- 155 | 156 | AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs]) 157 | AC_DEFINE(USE_TCLOO_STUBS, 1, [Use TclOO stubs]) 158 | 159 | #-------------------------------------------------------------------- 160 | # This macro generates a line to use when building a library. It 161 | # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS, 162 | # and TEA_LOAD_TCLCONFIG macros above. 163 | #-------------------------------------------------------------------- 164 | 165 | TEA_MAKE_LIB 166 | 167 | #-------------------------------------------------------------------- 168 | # Find tclsh so that we can run pkg_mkIndex to generate the pkgIndex.tcl 169 | # file during the install process. Don't run the TCLSH_PROG through 170 | # ${CYGPATH} because it's being used directly by make. 171 | # Require that we use a tclsh shell version 8.2 or later since earlier 172 | # versions have bugs in the pkg_mkIndex routine. 173 | #-------------------------------------------------------------------- 174 | 175 | TEA_PROG_TCLSH 176 | 177 | #-------------------------------------------------------------------- 178 | # Finally, substitute all of the various values into the Makefile. 179 | #-------------------------------------------------------------------- 180 | 181 | AC_CONFIG_FILES([Makefile pkgIndex.tcl]) 182 | AC_OUTPUT 183 | -------------------------------------------------------------------------------- /itclWidget/doc/itclWidget.n: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/itclWidget/doc/itclWidget.n -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetBase.c: -------------------------------------------------------------------------------- 1 | /* 2 | * itclWidgetBase.c -- 3 | * 4 | * This file contains the C-implemeted part of a 5 | * Itcl implemenatation for package ItclWidget 6 | * 7 | * This implementation is based mostly on the ideas of snit 8 | * whose author is William Duquette. 9 | * 10 | * Copyright (c) 2007 by Arnulf P. Wiedemann 11 | * 12 | * See the file "license.terms" for information on usage and redistribution of 13 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 | */ 15 | 16 | #include 17 | #include "itclWidgetInt.h" 18 | #include 19 | 20 | static int Initialize(Tcl_Interp *interp); 21 | 22 | /* 23 | * ------------------------------------------------------------------------ 24 | * Initialize() 25 | * 26 | * that is the starting point when loading the library 27 | * it initializes all internal stuff 28 | * 29 | * ------------------------------------------------------------------------ 30 | */ 31 | 32 | static int 33 | Initialize ( 34 | Tcl_Interp *interp) 35 | { 36 | Tcl_Namespace *nsPtr; 37 | ItclObjectInfo *infoPtr; 38 | 39 | if (Tcl_InitStubs(interp, "8.6-", 0) == NULL) { 40 | return TCL_ERROR; 41 | } 42 | if (Tk_InitStubs(interp, "8.6-", 0) == NULL) { 43 | return TCL_ERROR; 44 | } 45 | if (Itcl_InitStubs(interp, "4.0.0", 0) == NULL) { 46 | return TCL_ERROR; 47 | } 48 | 49 | infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, 50 | ITCL_INTERP_DATA, NULL); 51 | nsPtr = Tcl_CreateNamespace(interp, "::itcl::widget", NULL, NULL); 52 | if (nsPtr == NULL) { 53 | Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", "::itcl::widget"); 54 | } 55 | nsPtr = Tcl_CreateNamespace(interp, ITCL_WIDGETS_NAMESPACE, NULL, NULL); 56 | if (nsPtr == NULL) { 57 | Tcl_Panic("Itcl: cannot create namespace: \"%s\" \n", 58 | "::itcl::widget::internal"); 59 | } 60 | 61 | #if 0 /* This doesn't compile ???? */ 62 | infoPtr->windgetInfoPtr = (ItclWidgetInfo *)ckalloc(sizeof(ItclWidgetInfo)); 63 | infoPtr->windgetInfoPtr->initObjectOpts = ItclWidgetInitObjectOptions; 64 | infoPtr->windgetInfoPtr->hullAndOptsInst = HullAndOptionsInstall; 65 | infoPtr->windgetInfoPtr->delegationInst = DelegationInstall; 66 | infoPtr->windgetInfoPtr->componentInst = InstallComponent; 67 | #endif 68 | 69 | /* 70 | * Create "itcl::builtin" namespace for commands that 71 | * are automatically built into class definitions. 72 | */ 73 | if (Itcl_WidgetBiInit(interp, infoPtr) != TCL_OK) { 74 | return TCL_ERROR; 75 | } 76 | 77 | if (ItclWidgetInfoInit(interp, infoPtr) != TCL_OK) { 78 | return TCL_ERROR; 79 | } 80 | 81 | /* 82 | * Set up the variables containing version info. 83 | */ 84 | 85 | Tcl_SetVar2(interp, "::itcl::widget::version", NULL, ITCL_VERSION, TCL_NAMESPACE_ONLY); 86 | Tcl_SetVar2(interp, "::itcl::widget::patchLevel", NULL, ITCL_PATCH_LEVEL, 87 | TCL_NAMESPACE_ONLY); 88 | 89 | 90 | /* 91 | * Package is now loaded. 92 | */ 93 | 94 | return Tcl_PkgProvideEx(interp, "itclwidget", ITCL_PATCH_LEVEL, NULL); 95 | } 96 | 97 | /* 98 | * ------------------------------------------------------------------------ 99 | * ItclWidget_Init() 100 | * 101 | * Invoked whenever a new INTERPRETER is created to install the 102 | * [incr Tcl] package. Usually invoked within Tcl_AppInit() at 103 | * the start of execution. 104 | * 105 | * Creates the "::itcl" namespace and installs access commands for 106 | * creating classes and querying info. 107 | * 108 | * Returns TCL_OK on success, or TCL_ERROR (along with an error 109 | * message in the interpreter) if anything goes wrong. 110 | * ------------------------------------------------------------------------ 111 | */ 112 | 113 | int 114 | Itclwidget_Init ( 115 | Tcl_Interp *interp) 116 | { 117 | if (Initialize(interp) != TCL_OK) { 118 | return TCL_ERROR; 119 | } 120 | 121 | return TCL_OK; 122 | } 123 | 124 | /* 125 | * ------------------------------------------------------------------------ 126 | * ItclWidget_SafeInit() 127 | * 128 | * Invoked whenever a new SAFE INTERPRETER is created to install 129 | * the [incr Tcl] package. 130 | * 131 | * Creates the "::itcl" namespace and installs access commands for 132 | * creating classes and querying info. 133 | * 134 | * Returns TCL_OK on success, or TCL_ERROR (along with an error 135 | * message in the interpreter) if anything goes wrong. 136 | * ------------------------------------------------------------------------ 137 | */ 138 | 139 | int 140 | Itclwidget_SafeInit ( 141 | Tcl_Interp *interp) 142 | { 143 | if (Initialize(interp) != TCL_OK) { 144 | return TCL_ERROR; 145 | } 146 | return TCL_OK; 147 | } 148 | 149 | -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetCmd.c: -------------------------------------------------------------------------------- 1 | /* 2 | * ------------------------------------------------------------------------ 3 | * PACKAGE: [incr Tcl] 4 | * DESCRIPTION: Object-Oriented Extensions to Tcl 5 | * 6 | * Implementation of commands for package ItclWidget 7 | * 8 | * This implementation is based mostly on the ideas of snit 9 | * whose author is William Duquette. 10 | * 11 | * ======================================================================== 12 | * Author: Arnulf Wiedemann 13 | * 14 | * ======================================================================== 15 | * Copyright (c) 2007 Arnulf Wiedemann 16 | * ------------------------------------------------------------------------ 17 | * See the file "license.terms" for information on usage and redistribution 18 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 19 | */ 20 | #include "itclWidgetInt.h" 21 | 22 | 23 | /* 24 | * ------------------------------------------------------------------------ 25 | * Itcl_WidgetCmd() 26 | * 27 | * Used to build an [incr Tcl] widget 28 | * 29 | * Returns TCL_OK/TCL_ERROR to indicate success/failure. 30 | * ------------------------------------------------------------------------ 31 | */ 32 | 33 | int 34 | _Itcl_WidgetCmd( 35 | void *clientData, /* infoPtr */ 36 | Tcl_Interp *interp, /* current interpreter */ 37 | int objc, /* number of arguments */ 38 | Tcl_Obj *const objv[]) /* argument objects */ 39 | { 40 | Tcl_Obj *objPtr; 41 | ItclClass *iclsPtr; 42 | int result; 43 | 44 | ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv); 45 | result = ItclClassBaseCmd(clientData, interp, ITCL_WIDGET, objc, objv, 46 | &iclsPtr); 47 | if (result != TCL_OK) { 48 | return result; 49 | } 50 | 51 | /* we handle create by owerselfs !! allow classunknown to handle that */ 52 | objPtr = Tcl_NewStringObj("oo::objdefine ", TCL_INDEX_NONE); 53 | Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); 54 | Tcl_AppendToObj(objPtr, " unexport create", TCL_INDEX_NONE); 55 | Tcl_IncrRefCount(objPtr); 56 | result = Tcl_EvalObjEx(interp, objPtr, 0); 57 | Tcl_DecrRefCount(objPtr); 58 | objPtr = Tcl_GetObjResult(interp); 59 | Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); 60 | Tcl_SetObjResult(interp, objPtr); 61 | return result; 62 | } 63 | 64 | 65 | /* 66 | * ------------------------------------------------------------------------ 67 | * Itcl_WidgetAdaptorCmd() 68 | * 69 | * Used to an [incr Tcl] widgetadaptor 70 | * 71 | * Returns TCL_OK/TCL_ERROR to indicate success/failure. 72 | * ------------------------------------------------------------------------ 73 | */ 74 | 75 | int 76 | _Itcl_WidgetAdaptorCmd( 77 | void *clientData, /* infoPtr */ 78 | Tcl_Interp *interp, /* current interpreter */ 79 | int objc, /* number of arguments */ 80 | Tcl_Obj *const objv[]) /* argument objects */ 81 | { 82 | Tcl_Obj *namePtr; 83 | Tcl_Obj *objPtr; 84 | ItclClass *iclsPtr; 85 | ItclComponent *icPtr; 86 | int result; 87 | 88 | ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv); 89 | result = ItclClassBaseCmd(clientData, interp, ITCL_WIDGETADAPTOR, 90 | objc, objv, &iclsPtr); 91 | if (result != TCL_OK) { 92 | return result; 93 | } 94 | /* create the itcl_hull variable */ 95 | namePtr = Tcl_NewStringObj("itcl_hull", TCL_INDEX_NONE); 96 | if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON, &icPtr) != 97 | TCL_OK) { 98 | return TCL_ERROR; 99 | } 100 | iclsPtr->numVariables++; 101 | Itcl_BuildVirtualTables(iclsPtr); 102 | 103 | /* we handle create by owerselfs !! allow classunknown to handle that */ 104 | objPtr = Tcl_NewStringObj("oo::objdefine ", TCL_INDEX_NONE); 105 | Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); 106 | Tcl_AppendToObj(objPtr, " unexport create", TCL_INDEX_NONE); 107 | Tcl_IncrRefCount(objPtr); 108 | result = Tcl_EvalObjEx(interp, objPtr, 0); 109 | Tcl_DecrRefCount(objPtr); 110 | objPtr = Tcl_GetObjResult(interp); 111 | Tcl_AppendToObj(objPtr, iclsPtr->nsPtr->fullName, TCL_INDEX_NONE); 112 | Tcl_SetObjResult(interp, objPtr); 113 | return result; 114 | } 115 | -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetInt.h: -------------------------------------------------------------------------------- 1 | /* 2 | * itclInt.h -- 3 | * 4 | * This file contains internal definitions for the C-implemented part of a 5 | * Itcl 6 | * 7 | * Copyright (c) 2007 by Arnulf P. Wiedemann 8 | * 9 | * See the file "license.terms" for information on usage and redistribution of 10 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 | */ 12 | 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | 19 | #define ITCL_WIDGETS_NAMESPACE "::itcl::internal::widgets" 20 | 21 | typedef int (*HullAndOptionsInst)(Tcl_Interp *interp, 22 | struct ItclObject *ioPtr, struct ItclClass *iclsPtr, int objc, 23 | Tcl_Obj *const *objv, int *newObjc, Tcl_Obj **newObjv); 24 | typedef int (*InitObjectOptions)(Tcl_Interp *interp, 25 | struct ItclObject *ioPtr, struct ItclClass *iclsPtr, const char *name); 26 | typedef int (*DelegationInst)(Tcl_Interp *interp, 27 | struct ItclObject *ioPtr, struct ItclClass *iclsPtr); 28 | 29 | 30 | typedef struct ItclWidgetInfo { 31 | InitObjectOptions initObjectOpts; 32 | HullAndOptionsInst hullAndOptsInst; 33 | DelegationInst delegationInst; 34 | Tcl_ObjCmdProc *widgetConfigure; 35 | Tcl_ObjCmdProc *widgetCget; 36 | } ItclWidgetInfo; 37 | 38 | 39 | MODULE_SCOPE int HullAndOptionsInstall(Tcl_Interp *interp, ItclObject *ioPtr, 40 | ItclClass *iclsPtr, int objc, Tcl_Obj * const objv[], 41 | int *newObjc, Tcl_Obj **newObjv); 42 | MODULE_SCOPE int InstallComponent(Tcl_Interp *interp, ItclObject *ioPtr, 43 | ItclClass *iclsPtr, int objc, Tcl_Obj * const objv[]); 44 | MODULE_SCOPE int Itcl_BiInstallHullCmd (void *clientData, 45 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 46 | MODULE_SCOPE int ItclWidgetConfigure(void *clientData, Tcl_Interp *interp, 47 | int objc, Tcl_Obj *const objv[]); 48 | MODULE_SCOPE int ItclWidgetCget(void *clientData, Tcl_Interp *interp, 49 | int objc, Tcl_Obj *const objv[]); 50 | MODULE_SCOPE int Itcl_WidgetParseInit(Tcl_Interp *interp, 51 | ItclObjectInfo *infoPtr); 52 | MODULE_SCOPE int Itcl_WidgetBiInit(Tcl_Interp *interp, ItclObjectInfo *infoPtr); 53 | MODULE_SCOPE int ItclWidgetInfoInit(Tcl_Interp *interp, 54 | ItclObjectInfo *infoPtr); 55 | MODULE_SCOPE int ItclWidgetInitObjectOptions(Tcl_Interp *interp, 56 | ItclObject *ioPtr, ItclClass *iclsPtr, const char *name); 57 | -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetParse.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/itclWidget/generic/itclWidgetParse.c -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetStubInit.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/itclWidget/generic/itclWidgetStubInit.c -------------------------------------------------------------------------------- /itclWidget/generic/itclWidgetStubLib.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/itclWidget/generic/itclWidgetStubLib.c -------------------------------------------------------------------------------- /itclWidget/license.terms: -------------------------------------------------------------------------------- 1 | This software is copyrighted by Lucent Technologies, Inc., and other 2 | parties. The following terms apply to all files associated with the 3 | software unless explicitly disclaimed in individual files. 4 | 5 | The authors hereby grant permission to use, copy, modify, distribute, 6 | and license this software and its documentation for any purpose, provided 7 | that existing copyright notices are retained in all copies and that this 8 | notice is included verbatim in any distributions. No written agreement, 9 | license, or royalty fee is required for any of the authorized uses. 10 | Modifications to this software may be copyrighted by their authors 11 | and need not follow the licensing terms described here, provided that 12 | the new terms are clearly indicated on the first page of each file where 13 | they apply. 14 | 15 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 16 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 17 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 18 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 19 | POSSIBILITY OF SUCH DAMAGE. 20 | 21 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 22 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 23 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 24 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 25 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 26 | MODIFICATIONS. 27 | 28 | GOVERNMENT USE: If you are acquiring this software on behalf of the 29 | U.S. government, the Government shall have only "Restricted Rights" 30 | in the software and related documentation as defined in the Federal 31 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 32 | are acquiring the software on behalf of the Department of Defense, the 33 | software shall be classified as "Commercial Computer Software" and the 34 | Government shall have only "Restricted Rights" as defined in Clause 35 | 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 36 | authors grant the U.S. Government and others acting in its behalf 37 | permission to use and distribute the software in accordance with the 38 | terms specified in this license. 39 | -------------------------------------------------------------------------------- /itclWidget/pkgIndex.tcl.in: -------------------------------------------------------------------------------- 1 | # -*- tcl -*- 2 | # Tcl package index file, version 1.1 3 | # 4 | 5 | if {![package vsatisfies [package provide Tcl] 8.6-]} {return} 6 | 7 | if {[package vsatisfies [package provide Tcl] 9.0-]} { 8 | package ifneeded itclwidget @PACKAGE_VERSION@ \ 9 | [list package require itcl 4.0.0] \ 10 | [list package require Tk 8.6-] \ 11 | [list load [file join $dir @PKG_LIB_FILE9@] Itclwidget] 12 | } else { 13 | package ifneeded itclwidget @PACKAGE_VERSION@ \ 14 | [list package require itcl 4.0.0] \ 15 | [list package require Tk 8.6-] \ 16 | [list load [file join $dir @PKG_LIB_FILE8@] Itclwidget] 17 | } 18 | -------------------------------------------------------------------------------- /itclWidget/tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-2000 by Ajuba Solutions 8 | # All rights reserved. 9 | 10 | package require tcltest 2.1 11 | 12 | tcltest::testsDirectory [file dir [info script]] 13 | tcltest::runAllTests 14 | 15 | return 16 | -------------------------------------------------------------------------------- /itclWidget/tests/itclwidget.test: -------------------------------------------------------------------------------- 1 | #--------------------------------------------------------------------- 2 | # TITLE: 3 | # itclwidget.test 4 | # 5 | # AUTHOR: 6 | # Arnulf Wiedemann with a lot of code form the snit tests by 7 | # Will Duquette 8 | # 9 | # DESCRIPTION: 10 | # Test cases for ::itcl::widget command. Uses the ::tcltest:: harness. 11 | # 12 | # There is at least Tcl 8.6a3 needed 13 | # 14 | # The tests assume tcltest 2.2 15 | #----------------------------------------------------------------------- 16 | 17 | # ### ### ### ######### ######### ######### 18 | ## Declare the minimal version of Tcl required to run the package 19 | ## tested by this testsuite, and its dependencies. 20 | 21 | proc testsNeedTcl {version} { 22 | # This command ensures that a minimum version of Tcl is used to 23 | # run the tests in the calling testsuite. If the minimum is not 24 | # met by the active interpreter we forcibly bail out of the 25 | # testsuite calling the command. The command has to be called 26 | # immediately after loading the utilities. 27 | 28 | if {[package vsatisfies [package provide Tcl] ${version}-]} return 29 | 30 | puts " Aborting the tests found in \"[file tail [info script]]\"" 31 | puts " Requiring at least Tcl $version, have [package provide Tcl]." 32 | 33 | # This causes a 'return' in the calling scope. 34 | return -code return 35 | } 36 | 37 | # ### ### ### ######### ######### ######### 38 | ## Declare the minimum version of Tcltest required to run the 39 | ## testsuite. 40 | 41 | proc testsNeedTcltest {version} { 42 | # This command ensure that a minimum version of the Tcltest 43 | # support package is used to run the tests in the calling 44 | # testsuite. If the minimum is not met by the loaded package we 45 | # forcibly bail out of the testsuite calling the command. The 46 | # command has to be called after loading the utilities. The only 47 | # command allowed to come before it is 'textNeedTcl' above. 48 | 49 | # Note that this command will try to load a suitable version of 50 | # Tcltest if the package has not been loaded yet. 51 | 52 | if {[lsearch [namespace children] ::tcltest] == -1} { 53 | if {![catch { 54 | package require tcltest $version 55 | }]} { 56 | namespace import -force ::tcltest::* 57 | return 58 | } 59 | } elseif {[package vcompare [package present tcltest] $version] >= 0} { 60 | return 61 | } 62 | 63 | puts " Aborting the tests found in [file tail [info script]]." 64 | puts " Requiring at least tcltest $version, have [package present tcltest]" 65 | 66 | # This causes a 'return' in the calling scope. 67 | return -code return 68 | } 69 | 70 | 71 | testsNeedTcl 8.6 72 | testsNeedTcltest 2.2 73 | 74 | #--------------------------------------------------------------------- 75 | # Set up a number of constraints. 76 | 77 | # Marks tests which are only for Tk. 78 | tcltest::testConstraint tk [info exists tk_version] 79 | 80 | # If Tk is available, require BWidget 81 | tcltest::testConstraint bwidget [expr { 82 | [tcltest::testConstraint tk] && 83 | ![catch {package require BWidget}] 84 | }] 85 | 86 | # Set up for Tk tests: Repeat background errors 87 | proc bgerror {msg} { 88 | global errorInfo 89 | set ::bideError $msg 90 | set ::bideErrorInfo $errorInfo 91 | } 92 | 93 | # Set up for Tk tests: enter the event loop long enough to catch 94 | # any bgerrors. 95 | proc tkbide {{msg "tkbide"} {msec 500}} { 96 | set ::bideVar 0 97 | set ::bideError "" 98 | set ::bideErrorInfo "" 99 | # It looks like update idletasks does the job. 100 | if {0} { 101 | after $msec {set ::bideVar 1} 102 | tkwait variable ::bideVar 103 | } 104 | update idletasks 105 | if {"" != $::bideError} { 106 | error "$msg: $::bideError" $::bideErrorInfo 107 | } 108 | } 109 | 110 | 111 | -------------------------------------------------------------------------------- /library/itcl.tcl: -------------------------------------------------------------------------------- 1 | # 2 | # itcl.tcl 3 | # ---------------------------------------------------------------------- 4 | # Invoked automatically upon startup to customize the interpreter 5 | # for [incr Tcl]. 6 | # ---------------------------------------------------------------------- 7 | # AUTHOR: Michael J. McLennan 8 | # Bell Labs Innovations for Lucent Technologies 9 | # mmclennan@lucent.com 10 | # http://www.tcltk.com/itcl 11 | # ---------------------------------------------------------------------- 12 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 13 | # ====================================================================== 14 | # See the file "license.terms" for information on usage and 15 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 | 17 | proc ::itcl::delete_helper { name args } { 18 | ::itcl::delete object $name 19 | } 20 | 21 | # ---------------------------------------------------------------------- 22 | # USAGE: local ? ...? 23 | # 24 | # Creates a new object called in class , passing 25 | # the remaining 's to the constructor. Unlike the usual 26 | # [incr Tcl] objects, however, an object created by this procedure 27 | # will be automatically deleted when the local call frame is destroyed. 28 | # This command is useful for creating objects that should only remain 29 | # alive until a procedure exits. 30 | # ---------------------------------------------------------------------- 31 | proc ::itcl::local {class name args} { 32 | set ptr [uplevel [list $class $name] $args] 33 | uplevel [list set itcl-local-$ptr $ptr] 34 | set cmd [uplevel namespace which -command $ptr] 35 | uplevel [list trace add variable itcl-local-$ptr unset \ 36 | "::itcl::delete_helper $cmd"] 37 | return $ptr 38 | } 39 | 40 | # ---------------------------------------------------------------------- 41 | # auto_mkindex 42 | # ---------------------------------------------------------------------- 43 | # Define Itcl commands that will be recognized by the auto_mkindex 44 | # parser in Tcl... 45 | # 46 | 47 | # 48 | # USAGE: itcl::class name body 49 | # Adds an entry for the given class declaration. 50 | # 51 | foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} { 52 | auto_mkindex_parser::command $__cmd {name body} { 53 | variable index 54 | variable scriptFile 55 | append index "set [list auto_index([fullname $name])]" 56 | append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n" 57 | 58 | variable parser 59 | variable contextStack 60 | set contextStack [linsert $contextStack 0 $name] 61 | $parser eval $body 62 | set contextStack [lrange $contextStack 1 end] 63 | } 64 | } 65 | 66 | # 67 | # USAGE: itcl::body name arglist body 68 | # Adds an entry for the given method/proc body. 69 | # 70 | foreach __cmd {itcl::body body} { 71 | auto_mkindex_parser::command $__cmd {name arglist body} { 72 | variable index 73 | variable scriptFile 74 | append index "set [list auto_index([fullname $name])]" 75 | append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n" 76 | } 77 | } 78 | 79 | # 80 | # USAGE: itcl::configbody name arglist body 81 | # Adds an entry for the given method/proc body. 82 | # 83 | foreach __cmd {itcl::configbody configbody} { 84 | auto_mkindex_parser::command $__cmd {name body} { 85 | variable index 86 | variable scriptFile 87 | append index "set [list auto_index([fullname $name])]" 88 | append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n" 89 | } 90 | } 91 | 92 | # 93 | # USAGE: ensemble name ?body? 94 | # Adds an entry to the auto index list for the given ensemble name. 95 | # 96 | foreach __cmd {itcl::ensemble ensemble} { 97 | auto_mkindex_parser::command $__cmd {name {body ""}} { 98 | variable index 99 | variable scriptFile 100 | append index "set [list auto_index([fullname $name])]" 101 | append index " \[list source -encoding utf-8 \[file join \$dir [list $scriptFile]\]\]\n" 102 | } 103 | } 104 | 105 | # 106 | # USAGE: public arg ?arg arg...? 107 | # protected arg ?arg arg...? 108 | # private arg ?arg arg...? 109 | # 110 | # Evaluates the arguments as commands, so we can recognize proc 111 | # declarations within classes. 112 | # 113 | foreach __cmd {public protected private} { 114 | auto_mkindex_parser::command $__cmd {args} { 115 | variable parser 116 | $parser eval $args 117 | } 118 | } 119 | 120 | # SF bug #246 unset variable __cmd to avoid problems in user programs!! 121 | unset __cmd 122 | 123 | # ---------------------------------------------------------------------- 124 | # auto_import 125 | # ---------------------------------------------------------------------- 126 | # This procedure overrides the usual "auto_import" function in the 127 | # Tcl library. It is invoked during "namespace import" to make see 128 | # if the imported commands reside in an autoloaded library. If so, 129 | # stubs are created to represent the commands. Executing a stub 130 | # later on causes the real implementation to be autoloaded. 131 | # 132 | # Arguments - 133 | # pattern The pattern of commands being imported (like "foo::*") 134 | # a canonical namespace as returned by [namespace current] 135 | 136 | proc auto_import {pattern} { 137 | global auto_index 138 | 139 | set ns [uplevel namespace current] 140 | set patternList [auto_qualify $pattern $ns] 141 | 142 | auto_load_index 143 | 144 | foreach pattern $patternList { 145 | foreach name [array names auto_index $pattern] { 146 | if {"" == [info commands $name]} { 147 | ::itcl::import::stub create $name 148 | } 149 | } 150 | } 151 | } 152 | -------------------------------------------------------------------------------- /library/test_Itcl_CreateObject.tcl: -------------------------------------------------------------------------------- 1 | # this is a program for testing the stubs interface ItclCreateObject. 2 | # it uses itclTestRegisterC.c with the call C function functionality, 3 | # so it also tests that feature. 4 | # you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE 5 | # for makeing that work. 6 | package require itcl 7 | 8 | ::itcl::class ::c1 { 9 | public method c0 {args} @cArgFunc 10 | public method m1 { args } { puts "Hello Tcl $args" } 11 | } 12 | 13 | set obj1 [::c1 #auto ] 14 | $obj1 m1 World 15 | 16 | # C method cargFunc implements a call to Itcl_CreateObject! 17 | # 18 | # args for method c0 of class ::c1 19 | # arg1 does not matter 20 | # arg2 is the class name 21 | # arg3 is the full class name (full path name) 22 | # arg4 is the object name of the created Itcl object 23 | set obj2 [$obj1 c0 ::itcl::parser::handleClass ::c1 ::c1 ::c1::c11] 24 | # test, if it is working! 25 | $obj2 m1 Folks 26 | 27 | -------------------------------------------------------------------------------- /license.terms: -------------------------------------------------------------------------------- 1 | This is a mostly rewritten version of [incr Tcl], which is copyrighted 2 | by Arnulf P. Wiedemann (c) Copyright 2008. It is derived from a version 3 | written by Lucent Technologies, Inc., and other parties see that copyright 4 | below. 5 | 6 | The rewritten version is copyrighted with BSD license or Public Domain at 7 | your choice. 8 | 9 | The original version of this software is copyrighted by Lucent Technologies, 10 | Inc., and other parties. The following terms apply to all files associated 11 | with the software unless explicitly disclaimed in individual files. 12 | 13 | The authors hereby grant permission to use, copy, modify, distribute, 14 | and license this software and its documentation for any purpose, provided 15 | that existing copyright notices are retained in all copies and that this 16 | notice is included verbatim in any distributions. No written agreement, 17 | license, or royalty fee is required for any of the authorized uses. 18 | Modifications to this software may be copyrighted by their authors 19 | and need not follow the licensing terms described here, provided that 20 | the new terms are clearly indicated on the first page of each file where 21 | they apply. 22 | 23 | IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY 24 | FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES 25 | ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY 26 | DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE 27 | POSSIBILITY OF SUCH DAMAGE. 28 | 29 | THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, 30 | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, 31 | FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE 32 | IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE 33 | NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR 34 | MODIFICATIONS. 35 | 36 | GOVERNMENT USE: If you are acquiring this software on behalf of the 37 | U.S. government, the Government shall have only "Restricted Rights" 38 | in the software and related documentation as defined in the Federal 39 | Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you 40 | are acquiring the software on behalf of the Department of Defense, the 41 | software shall be classified as "Commercial Computer Software" and the 42 | Government shall have only "Restricted Rights" as defined in Clause 43 | 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the 44 | authors grant the U.S. Government and others acting in its behalf 45 | permission to use and distribute the software in accordance with the 46 | terms specified in this license. 47 | -------------------------------------------------------------------------------- /pkgIndex.tcl.in: -------------------------------------------------------------------------------- 1 | # -*- tcl -*- 2 | # Tcl package index file, version 1.1 3 | # 4 | 5 | if {![package vsatisfies [package provide Tcl] 8.6-]} {return} 6 | 7 | if {[package vsatisfies [package provide Tcl] 9.0-]} { 8 | package ifneeded itcl @PACKAGE_VERSION@ \ 9 | [list load [file join $dir @PKG_LIB_FILE9@] Itcl] 10 | } else { 11 | package ifneeded itcl @PACKAGE_VERSION@ \ 12 | [list load [file join $dir @PKG_LIB_FILE8@] Itcl] 13 | } 14 | package ifneeded Itcl @PACKAGE_VERSION@ [list package require -exact itcl @PACKAGE_VERSION@] 15 | -------------------------------------------------------------------------------- /releasenotes.txt: -------------------------------------------------------------------------------- 1 | This is the release 4.3.3 of Itcl. 2 | 3 | It is intended to be script compatible with Itcl 4.0.* and Itcl 3.4.* . 4 | It very likely presents the same public C interface as Itcl 4.0.* . 5 | It includes incompatible changes to internal structs when compared 6 | with Itcl 4.0.* . Unfortunately, the extension Itk 4.0.* intrudes 7 | in those internals and will notice and break in the presence of Itcl 4.1.* . 8 | When you upgrade to Itcl 4.1 , you must also upgrade to Itk 4.1 . It 9 | is possible you will find other extensions and applications repeating Itk's 10 | error. 11 | 12 | Notes of past releases follow below 13 | ----------------------------------- 14 | 15 | Starting with release 4.3.*, Itcl attempts to support multi-thread operations 16 | 17 | The difference to 4.0.*: in this release there are only bug fixes from SF and the fossil bug tracker for itcl. 18 | 19 | This is the first stable release of Itcl 4.0. 20 | It is a new major release of Itcl. 21 | 22 | The difference to 4.0b7: Tighter control on the set of exported functions. 23 | 24 | The difference to 4.0b6: Updated TEA system and related build system changes. 25 | 26 | The difference to 4.0b5: in this release there are only bug fixes from SF 27 | tracker and updates for using Tcl 8.6 version from fossil repo trunk 28 | 29 | The difference to 4.0b4: in this release there are only bug fixes from SF 30 | tracker and updates to TEA 3.9. 31 | 32 | The difference to 4.0b3: in this release there are only bug fixes from SF 33 | tracker and some fixes to run on OSX and Windows platform. 34 | 35 | There is no known incompatibility. 36 | -------------------------------------------------------------------------------- /tests-perf/itcl-basic.perf.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/tclsh 2 | 3 | # ------------------------------------------------------------------------ 4 | # 5 | # itcl-basic.perf.tcl -- 6 | # 7 | # This file provides performance tests for comparison of basic itcl-speed. 8 | # 9 | # ------------------------------------------------------------------------ 10 | # 11 | # Copyright (c) 2019 Serg G. Brester (aka sebres) 12 | # 13 | # See the file "license.terms" for information on usage and redistribution 14 | # of this file. 15 | # 16 | 17 | 18 | if {![namespace exists ::tclTestPerf]} { 19 | source -encoding utf-8 [file join [file dirname [info library]] tests-perf test-performance.tcl] 20 | } 21 | 22 | namespace eval ::itclTestPerf-Basic { 23 | 24 | namespace path {::tclTestPerf} 25 | 26 | 27 | ## test cases covering regression on class count (memory preserve/release): 28 | proc test-cls-init {{reptime {3000 1000}}} { 29 | set reptime [_adjust_maxcount $reptime 1000] 30 | _test_run $reptime { 31 | setup {set i 0; set k 0} 32 | ## 1) create up-to 1000 classes (with 100 vars): 33 | {itcl::class timeClass[incr i] { for {set j 0} {$j<100} {incr j} { public variable d$j } }} 34 | ## 2) create up-to 1000 classes (with 100 vars): 35 | {itcl::class finiClass[incr k] { for {set j 0} {$j<100} {incr j} { public variable d$j } }} 36 | ## 2) delete up-to 1000 classes: 37 | {itcl::delete class finiClass$k; if {[incr k -1] <= 0} break} 38 | cleanup {while {$k > 0} {itcl::delete class finiClass$k; incr k -1}} 39 | ## 1) delete up-to 1000 classes: 40 | {itcl::delete class timeClass$i; if {[incr i -1] <= 0} break} 41 | cleanup {while {$i > 0} {itcl::delete class timeClass$i; incr i -1}} 42 | } 43 | } 44 | 45 | ## test cases covering run-time dependency to variable count of class with nested 46 | ## namespaces and class inheritances... 47 | ## original itcl-resolver (due to completely rebuild) has the complexity ca. O(nn**2,2**vn) here, 48 | ## so the deeper a class/inheritance and expecially the more variables it has, 49 | ## the worse the performance of class creation or modification. 50 | 51 | proc test-var-create {{reptime {3000 10000}}} { 52 | upvar maxv maxv 53 | foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { 54 | incr n 55 | if {$ns ne {}} { namespace eval $ns {} } 56 | _test_start $reptime 57 | foreach clsi {0 1 2} { 58 | if {$clsi} { 59 | set inh ${ns}::timeClass[expr {$clsi-1}] 60 | } else { 61 | set inh {} 62 | } 63 | set cls ${ns}::timeClass$clsi 64 | puts "== ${n}.$clsi) class : $cls == [expr {$inh ne "" ? "inherite $inh" : ""}]" 65 | if {[info command $cls] ne ""} { 66 | itcl::delete class $cls 67 | } 68 | itcl::class $cls [string map [list \$reptime [list $reptime] \$in_inh [list $inh] \$clsi $clsi] { 69 | set j 0 70 | set inh $in_inh 71 | if {$inh ne ""} { 72 | puts "% inherit $inh" 73 | ::tclTestPerf::_test_iter 2 [timerate { 74 | inherit $inh 75 | } 1 1] 76 | } 77 | puts "% declare vars ..." 78 | ::tclTestPerf::_test_iter 2 [timerate { 79 | public variable pub[incr j] 0 80 | protected variable pro$j 1 81 | private variable pri$j 2 82 | # 10K commons is too slow in Itcl original edition (time grows on each iter), so 1K enough: 83 | if {$j <= 1000} { 84 | public common com$j "" 85 | } 86 | } {*}$reptime] 87 | public method getv {vn} {set $vn} 88 | public method getpub1 {} {set pro1} 89 | public method getpro1 {} {set pro1} 90 | public method getpri1 {} {set pri1} 91 | public method getunknown {} {catch {set novarinthisclass}} 92 | # Itcl original edition may be too slow (time grows on each inheritance), so save real max-iters (<= 10K): 93 | uplevel [list set j $j] 94 | }] 95 | set maxv($clsi,$ns) $j 96 | } 97 | } 98 | _test_out_total 99 | } 100 | 101 | # access variable: 102 | proc test-access {{reptime 1000}} { 103 | upvar maxv maxv 104 | _test_start $reptime 105 | foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { 106 | set reptm [_adjust_maxcount $reptime $maxv(0,$ns)] 107 | incr n 108 | set cls ${ns}::timeClass0 109 | puts "== ${n}) class : $cls ==" 110 | set mp [list \ 111 | \$cls $cls \$n $n \ 112 | \$maxc0 [expr {min(1000,$maxv(0,$ns))}] 113 | ] 114 | _test_run $reptm [string map $mp { 115 | # $n) obj-var resolve/get 116 | setup {$cls o; set j 0} 117 | {o getv pub[incr j]} 118 | # $n) obj-var get (resolved) 119 | setup {set j 0} 120 | {o getv pub[incr j]} 121 | # $n) obj-var resolved 122 | setup {set j 0} 123 | {o getv pub1} 124 | # $n) obj-var in method compiled (public) 125 | {o getpub1} 126 | # $n) obj-var in method compiled (protected) 127 | {o getpro1} 128 | # $n) obj-var in method compiled (private) 129 | {o getpri1} 130 | # $n) obj-var in method unknown 131 | {o getunknown} 132 | cleanup {itcl::delete object o} 133 | 134 | # $n) obj-var resolve/cget 135 | setup {$cls o; set j 0} 136 | {o cget -pub[incr j]} 137 | # $n) obj-var cget (resolved): 138 | setup {set j 0} 139 | {o cget -pub[incr j]} 140 | 141 | # $n) obj-var cfg/cget 142 | {o configure -pub1} 143 | {o cget -pub1} 144 | 145 | # $n) cls-com resolve 146 | setup {set j 0} 147 | {o getv com[incr j]; if {$j >= $maxc0} {set j 0}} 148 | 149 | # $n) cls-com resolved 150 | {o getv com1} 151 | cleanup {itcl::delete object o} 152 | }] 153 | } 154 | _test_out_total 155 | } 156 | 157 | # ------------------------------------------------------------------------ 158 | 159 | # create/delete object: 160 | proc test-obj-instance {{reptime 1000}} { 161 | _test_start $reptime 162 | set n 0 163 | foreach ns {{} ::test-itcl-ns1 ::test-itcl-ns1::test-itcl-ns2} { 164 | incr n 165 | set cls ${ns}::timeClass0 166 | puts "== ${n}) class : $cls ==" 167 | _test_run $reptime [string map [list \$cls $cls \$n $n] { 168 | setup {set i 0} 169 | # $n) create : 170 | {$cls o[incr i]} 171 | # $n) delete: 172 | {itcl::delete object o$i; if {[incr i -1] <= 0} break} 173 | cleanup {while {$i > 0} {itcl::delete object o$i; incr i -1}} 174 | # $n) create + delete: 175 | {$cls o; itcl::delete object o} 176 | }] 177 | } 178 | _test_out_total 179 | } 180 | 181 | # ------------------------------------------------------------------------ 182 | 183 | proc test {{reptime 1000}} { 184 | set reptm $reptime 185 | lset reptm 0 [expr {[lindex $reptm 0] * 10}] 186 | if {[llength $reptm] == 1} { 187 | lappend reptm 10000 188 | } 189 | puts "==== initialization (preserve/release) ====\n" 190 | test-cls-init $reptm 191 | puts "==== class/var creation ====\n" 192 | test-var-create $reptm 193 | puts "==== var access ====\n" 194 | test-access $reptime 195 | puts "==== object instance ====\n" 196 | test-obj-instance $reptime 197 | 198 | puts \n**OK** 199 | } 200 | 201 | }; # end of ::tclTestPerf-Timer-Event 202 | 203 | # ------------------------------------------------------------------------ 204 | 205 | # if calling direct: 206 | if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { 207 | array set in {-time 500 -lib {} -load {}} 208 | array set in $argv 209 | if {$in(-load) ne ""} { 210 | eval $in(-load) 211 | } 212 | if {![namespace exists ::itcl]} { 213 | if {$in(-lib) eq ""} { 214 | set in(-lib) "itcl412" 215 | } 216 | puts "testing with $in(-lib)" 217 | load $in(-lib) itcl 218 | } 219 | 220 | ::itclTestPerf-Basic::test $in(-time) 221 | } 222 | -------------------------------------------------------------------------------- /tests/all.tcl: -------------------------------------------------------------------------------- 1 | # all.tcl -- 2 | # 3 | # This file contains a top-level script to run all of the Tcl 4 | # tests. Execute it by invoking "source all.test" when running tcltest 5 | # in this directory. 6 | # 7 | # Copyright (c) 1998-2000 by Ajuba Solutions 8 | # All rights reserved. 9 | 10 | if {"-testdir" ni $argv} { 11 | lappend argv -testdir [file dir [info script]] 12 | } 13 | 14 | if {[namespace which -command memory] ne "" && "-loadfile" ni $argv} { 15 | puts "Tests running in sub-interpreters of leaktest circuit" 16 | # -loadfile overwrites -load, so save it for helper in ::env(TESTFLAGS): 17 | if {![info exists ::env(TESTFLAGS)] && [llength $argv]} { 18 | set ::env(TESTFLAGS) $argv 19 | } 20 | lappend argv -loadfile [file join [file dirname [info script]] helpers.tcl] 21 | } 22 | 23 | package prefer latest 24 | 25 | package require Tcl 8.6- 26 | package require tcltest 2.2 27 | 28 | tcltest::configure {*}$argv 29 | tcltest::runAllTests 30 | 31 | return 32 | -------------------------------------------------------------------------------- /tests/chain.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for chaining methods and procs 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.1 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | 19 | # ---------------------------------------------------------------------- 20 | # Chaining methods and procs 21 | # ---------------------------------------------------------------------- 22 | test chain-1.1 {define simple classes with inheritance} { 23 | itcl::class test_chain_a { 24 | constructor {args} { 25 | # 26 | eval chain $args 27 | } { 28 | global ::test_chain_status 29 | lappend test_chain_status "a::constructor $args" 30 | } 31 | method show {mesg} { 32 | chain $mesg 33 | global ::test_chain_status 34 | lappend test_chain_status "a::show $mesg" 35 | } 36 | proc tell {mesg} { 37 | global ::test_chain_status 38 | lappend test_chain_status "a::tell $mesg" 39 | chain $mesg 40 | } 41 | } 42 | itcl::class test_chain_b { 43 | constructor {args} { 44 | # 45 | eval chain $args 46 | } { 47 | global ::test_chain_status 48 | lappend test_chain_status "b::constructor $args" 49 | } 50 | method show {mesg} { 51 | chain $mesg 52 | global ::test_chain_status 53 | lappend test_chain_status "b::show $mesg" 54 | } 55 | proc tell {mesg} { 56 | global ::test_chain_status 57 | lappend test_chain_status "b::tell $mesg" 58 | chain $mesg 59 | } 60 | } 61 | itcl::class test_chain_c { 62 | inherit test_chain_a test_chain_b 63 | constructor {args} { 64 | eval chain $args 65 | } { 66 | global ::test_chain_status 67 | lappend test_chain_status "c::constructor $args" 68 | } 69 | proc tell {mesg} { 70 | global ::test_chain_status 71 | lappend test_chain_status "c::tell $mesg" 72 | chain $mesg 73 | } 74 | } 75 | itcl::class test_chain_d { 76 | inherit test_chain_c 77 | constructor {args} { 78 | eval chain $args 79 | } { 80 | global ::test_chain_status 81 | lappend test_chain_status "d::constructor $args" 82 | } 83 | method show {mesg} { 84 | chain $mesg 85 | global ::test_chain_status 86 | lappend test_chain_status "d::show $mesg" 87 | } 88 | proc tell {mesg} { 89 | global ::test_chain_status 90 | lappend test_chain_status "d::tell $mesg" 91 | chain $mesg 92 | } 93 | } 94 | } "" 95 | 96 | test chain-1.2 {create a test object} { 97 | set test_chain_status "" 98 | set testobj [test_chain_d #auto 1 2 3] 99 | set test_chain_status 100 | } {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}} 101 | 102 | test chain-1.3 {invoke a chained method} { 103 | set test_chain_status "" 104 | $testobj show "hello there" 105 | set test_chain_status 106 | } {{b::show hello there} {a::show hello there} {d::show hello there}} 107 | 108 | test chain-1.4 {invoke a chained method with a specific name} { 109 | set test_chain_status "" 110 | $testobj test_chain_d::show "hello there" 111 | set test_chain_status 112 | } {{b::show hello there} {a::show hello there} {d::show hello there}} 113 | 114 | test chain-1.5 {chained methods can cross multiple-inheritance branches} { 115 | set test_chain_status "" 116 | $testobj test_chain_a::show "hello there" 117 | set test_chain_status 118 | } {{b::show hello there} {a::show hello there}} 119 | 120 | test chain-1.6 {invoke a chained proc} { 121 | set test_chain_status "" 122 | test_chain_d::tell "testing 1 2 3" 123 | set test_chain_status 124 | } {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}} 125 | 126 | test chain-1.7 {invoke a chained proc} { 127 | set test_chain_status "" 128 | test_chain_c::tell "testing 1 2 3" 129 | set test_chain_status 130 | } {{c::tell testing 1 2 3} {a::tell testing 1 2 3}} 131 | 132 | test chain-2.1 {create a test object in a base class} { 133 | set test_chain_status "" 134 | set testobj [test_chain_c #auto 4 5 6] 135 | set test_chain_status 136 | } {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}} 137 | 138 | test chain-2.2 {invoke a chained method} { 139 | set test_chain_status "" 140 | $testobj show "hello there" 141 | set test_chain_status 142 | } {{b::show hello there} {a::show hello there}} 143 | 144 | test chain-3.0 {invoke "chain" outside of a class} { 145 | list [catch {itcl::builtin::chain 1 2 3} err] $err 146 | } {1 {cannot chain functions outside of a class context}} 147 | 148 | test chain-4.0 {[35a5baca67]} -setup { 149 | unset -nocomplain ::answer 150 | itcl::class B {method act args {lappend ::answer B}} 151 | itcl::class D {inherit B; method act args {lappend ::answer D; chain}} 152 | } -body { 153 | [D d] act Now! 154 | set ::answer 155 | } -cleanup { 156 | itcl::delete class B 157 | unset -nocomplain ::answer 158 | } -result {D B} 159 | 160 | # ---------------------------------------------------------------------- 161 | # Clean up 162 | # ---------------------------------------------------------------------- 163 | itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a 164 | 165 | ::tcltest::cleanupTests 166 | return 167 | -------------------------------------------------------------------------------- /tests/helpers.tcl: -------------------------------------------------------------------------------- 1 | # helpers.tcl -- 2 | # 3 | # This file contains helper scripts for all tests, like a mem-leak checker, etc. 4 | 5 | # -loadfile overwrites -load, so restore it from ::env(TESTFLAGS): 6 | if {[info exists ::env(TESTFLAGS)]} { 7 | array set testargs $::env(TESTFLAGS) 8 | if {[info exists ::testargs(-load)]} { 9 | eval $::testargs(-load) 10 | } 11 | unset testargs 12 | } 13 | 14 | package require itcl 15 | 16 | if {[namespace which -command memory] ne "" && ( 17 | ![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test 18 | ) 19 | } { 20 | proc getbytes {} {lindex [split [memory info] \n] 3 3} 21 | proc leaktest {script {iterations 3}} { 22 | set end [getbytes] 23 | for {set i 0} {$i < $iterations} {incr i} { 24 | uplevel 1 $script 25 | set tmp $end 26 | set end [getbytes] 27 | } 28 | return [expr {$end - $tmp}] 29 | } 30 | proc itcl_leaktest {testfile} { 31 | set leak [leaktest [string map [list \ 32 | @test@ $testfile \ 33 | @testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}] 34 | ] { 35 | interp create i 36 | load {} Itcl i 37 | i eval {set ::tcl::inl_mem_test 0} 38 | i eval {package require tcltest; @testargv@} 39 | i eval [list source -encoding utf-8 @test@] 40 | interp delete i 41 | }]] 42 | if {$leak} { 43 | puts "LEAKED: $leak bytes" 44 | } 45 | } 46 | itcl_leaktest [info script] 47 | return -code return 48 | } 49 | -------------------------------------------------------------------------------- /tests/import.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for "auto_import" and autoloading facility 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.2 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | set ::itcllib [lindex [lsearch -exact -index 1 -inline [info loaded] Itcl] 0] 19 | 20 | # ---------------------------------------------------------------------- 21 | # Test "itcl::import::stub" command 22 | # ---------------------------------------------------------------------- 23 | test import-1.1 {basic syntax for "stub" command} { 24 | list [catch {itcl::import::stub} result] $result 25 | } {1 {wrong # args: should be "itcl::import::stub subcommand ?arg ...?"}} 26 | 27 | test import-1.1a {basic syntax for "stub" command 28 | } -body { 29 | list [catch {itcl::import::stub} result] $result 30 | } -constraints { 31 | needs_frq_1773103 32 | } -result {1 {wrong # args: should be one of... 33 | stub create name 34 | stub exists name}} 35 | 36 | test import-1.2 {"stub create" requires one argument} { 37 | list [catch {itcl::import::stub create} result] $result \ 38 | [catch {itcl::import::stub create x y} result] $result 39 | } {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}} 40 | 41 | test import-1.3 {"stub exists" requires one argument} { 42 | list [catch {itcl::import::stub exists} result] $result \ 43 | [catch {itcl::import::stub exists x y} result] $result 44 | } {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}} 45 | 46 | set interp [interp create] 47 | $interp eval {set ::tcl::inl_mem_test 0} 48 | $interp eval " 49 | [list ::load $::itcllib Itcl] 50 | [::tcltest::configure -load] 51 | proc auto_load {cmd {namespace {}}} { 52 | global debug 53 | proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\] 54 | append debug \"(auto_load: \$cmd)\" 55 | return 1 56 | } 57 | " 58 | 59 | test import-1.4 {"stub create" creates a stub that triggers autoloading} { 60 | $interp eval { 61 | set debug "" 62 | list [itcl::import::stub create foo::bar::test] \ 63 | [info commands ::foo::bar::test] \ 64 | [::foo::bar::test 1 2 3] \ 65 | $debug 66 | } 67 | } {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}} 68 | 69 | test import-1.5 {"stub exists" recognizes stubs created by "stub create"} { 70 | $interp eval { 71 | set debug "" 72 | itcl::import::stub create foo::bar::stub1 73 | proc foo::bar::proc1 {{args {}}} {return "proc1: $args"} 74 | list [itcl::import::stub exists foo::bar::stub1] \ 75 | [itcl::import::stub exists foo::bar::proc1] 76 | } 77 | } {1 0} 78 | 79 | test import-1.6 {stubs can be autoloaded and replaced} { 80 | $interp eval { 81 | set debug "" 82 | itcl::import::stub create foo::bar::stub2 83 | list [itcl::import::stub exists foo::bar::stub2] \ 84 | [::foo::bar::stub2 a b c] \ 85 | [itcl::import::stub exists foo::bar::stub2] \ 86 | [::foo::bar::stub2 a b c] \ 87 | $debug 88 | } 89 | } {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}} 90 | 91 | catch {interp delete $interp} 92 | 93 | # ---------------------------------------------------------------------- 94 | # Test "itcl::import::stub" command 95 | # ---------------------------------------------------------------------- 96 | set interp [interp create] 97 | $interp eval {set ::tcl::inl_mem_test 0} 98 | $interp eval " 99 | [list ::load $::itcllib Itcl] 100 | [::tcltest::configure -load] 101 | proc auto_load {cmd {namespace {}}} { 102 | proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\] 103 | return 1 104 | } 105 | " 106 | 107 | test import-2.1 {initialize some commands for autoloading} { 108 | $interp eval { 109 | namespace eval test { 110 | namespace export foo* 111 | } 112 | itcl::import::stub create ::test::foo1 113 | itcl::import::stub create ::test::foo2 114 | lsort [info commands ::test::*] 115 | } 116 | } {::test::foo1 ::test::foo2} 117 | 118 | test import-2.2 {stubs can be imported into other namespaces} { 119 | $interp eval { 120 | namespace eval user1 { namespace import ::test::* } 121 | namespace eval user2 { namespace import ::test::* } 122 | namespace eval user3 { namespace import ::test::* } 123 | list [lsort [info commands ::user1::*]] \ 124 | [namespace origin ::user1::foo1] \ 125 | [namespace origin ::user1::foo2] 126 | } 127 | } {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2} 128 | 129 | test import-2.3 {stubs can be autoloaded and imported links remain} { 130 | $interp eval { 131 | list [::user1::foo1 1 2 3 4] \ 132 | [namespace origin ::user1::foo1] \ 133 | [namespace origin ::user2::foo1] \ 134 | [namespace origin ::user3::foo1] \ 135 | [itcl::import::stub exists ::test::foo1] 136 | } 137 | } {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0} 138 | 139 | test import-2.4 {itcl::class handles stubs correctly 140 | } -body { 141 | $interp eval { 142 | proc auto_load {cmd {namespace {}}} { 143 | itcl::class $cmd { } 144 | return 1 145 | } 146 | list [::user2::foo2 x] \ 147 | [x info class] \ 148 | [namespace origin ::user1::foo2] \ 149 | [namespace origin ::user2::foo2] \ 150 | [namespace origin ::user3::foo2] \ 151 | [itcl::import::stub exists ::test::foo2] 152 | } 153 | } -constraints { 154 | only_working_in_itcl3.4 155 | } -result {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0} 156 | 157 | test import-2.5 {itcl::class will overwrite stubs in an existing namespace} { 158 | $interp eval { 159 | proc auto_load {cmd {namespace {}}} { 160 | itcl::class $cmd { } 161 | return 1 162 | } 163 | namespace eval test::buried { } 164 | itcl::import::stub create ::test::buried 165 | itcl::import::stub create ::test::buried::stub 166 | list [catch {::test::buried xx} result] $result [xx info class] 167 | } 168 | } {0 xx ::test::buried} 169 | 170 | test import-2.6 {itcl::class will overwrite stubs} { 171 | $interp eval { 172 | proc auto_load {cmd {namespace {}}} { 173 | itcl::class $cmd { } 174 | return 1 175 | } 176 | itcl::import::stub create ::test::zonk 177 | list [catch {::test::zonk yy} result] $result [yy info class] 178 | } 179 | } {0 yy ::test::zonk} 180 | 181 | catch {interp delete $interp} 182 | 183 | ::tcltest::cleanupTests 184 | return 185 | -------------------------------------------------------------------------------- /tests/interp.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for using [incr Tcl] in child interpreters 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.1 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | 19 | # ---------------------------------------------------------------------- 20 | # Make sure that child interpreters can be created and loaded 21 | # with [incr Tcl]... 22 | # ---------------------------------------------------------------------- 23 | test interp-1.1 {create a child interp with [incr Tcl]} { 24 | interp create child 25 | load "" Itcl child 26 | list [child eval "namespace children :: itcl"] [interp delete child] 27 | } {::itcl {}} 28 | 29 | test interp-1.2 {create a safe child interp with [incr Tcl]} { 30 | interp create -safe child 31 | load "" Itcl child 32 | list [child eval "namespace children :: itcl"] [interp delete child] 33 | } {::itcl {}} 34 | 35 | test interp-1.3 {errors are okay when child interp is deleted} { 36 | catch {interp delete child} 37 | interp create child 38 | load "" Itcl child 39 | child eval { 40 | itcl::class Troublemaker { 41 | destructor { error "cannot delete this object" } 42 | } 43 | itcl::class Foo { 44 | variable obj "" 45 | constructor {} { 46 | set obj [Troublemaker #auto] 47 | } 48 | destructor { 49 | delete object $obj 50 | } 51 | } 52 | Foo f 53 | } 54 | interp delete child 55 | } {} 56 | 57 | test interp-1.4 {one namespace can cause another to be destroyed} { 58 | interp create child 59 | load "" Itcl child 60 | child eval { 61 | namespace eval group { 62 | itcl::class base1 {} 63 | itcl::class base2 {} 64 | } 65 | itcl::class TroubleMaker { 66 | inherit group::base1 group::base2 67 | } 68 | } 69 | interp delete child 70 | } {} 71 | 72 | test interp-1.5 {cleanup interp object list, this should not 73 | include an object that deletes itself in ctor} { 74 | interp create child 75 | load "" Itcl child 76 | child eval { 77 | itcl::class DeleteSelf { 78 | constructor {} { 79 | itcl::delete object $this 80 | } 81 | } 82 | DeleteSelf ds 83 | } 84 | interp delete child 85 | } {} 86 | 87 | ::tcltest::cleanupTests 88 | return 89 | -------------------------------------------------------------------------------- /tests/local.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for "local" command for creating objects local to a proc 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.1 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | 19 | # ---------------------------------------------------------------------- 20 | # Test "local" to create objects that only exist within a proc 21 | # ---------------------------------------------------------------------- 22 | test local-1.1 {define a class to use for testing} { 23 | itcl::class test_local { 24 | common status "" 25 | constructor {} { 26 | lappend status "created $this" 27 | } 28 | destructor { 29 | lappend status "deleted $this" 30 | } 31 | proc clear {} { 32 | set status "" 33 | } 34 | proc check {} { 35 | return $status 36 | } 37 | proc test {} { 38 | itcl::local test_local #auto 39 | lappend status "processing" 40 | } 41 | proc test2 {} { 42 | itcl::local test_local #auto 43 | lappend status "call test..." 44 | test 45 | lappend status "...back" 46 | } 47 | } 48 | test_local #auto 49 | } {test_local0} 50 | 51 | test local-1.2 {} { 52 | test_local::clear 53 | test_local::test 54 | test_local::check 55 | } {{created ::test_local::test_local1} processing {deleted ::test_local::test_local1}} 56 | 57 | test local-1.3 {} { 58 | test_local::clear 59 | test_local::test2 60 | test_local::check 61 | } {{created ::test_local::test_local2} {call test...} {created ::test_local::test_local3} processing {deleted ::test_local::test_local3} ...back {deleted ::test_local::test_local2}} 62 | 63 | test local-1.4 {} { 64 | itcl::find objects -isa test_local 65 | } {test_local0} 66 | 67 | itcl::delete class test_local 68 | 69 | ::tcltest::cleanupTests 70 | return 71 | -------------------------------------------------------------------------------- /tests/methods.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for argument lists and method execution 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.1 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | 19 | # ---------------------------------------------------------------------- 20 | # Methods with various argument lists 21 | # ---------------------------------------------------------------------- 22 | test methods-1.1 {define a class with lots of methods and arg lists} { 23 | itcl::class test_args { 24 | method none {} { 25 | return "none" 26 | } 27 | method two {x y} { 28 | return "two: $x $y" 29 | } 30 | method defvals {x {y def1} {z def2}} { 31 | return "defvals: $x $y $z" 32 | } 33 | method varargs {x {y def1} args} { 34 | return "varargs: $x $y ($args)" 35 | } 36 | method nomagic {args x} { 37 | return "nomagic: $args $x" 38 | } 39 | method clash {x bang boom} { 40 | return "clash: $x $bang $boom" 41 | } 42 | method clash_time {x bang boom} { 43 | time {set result "clash_time: $x $bang $boom"} 1 44 | return $result 45 | } 46 | proc crash {x bang boom} { 47 | return "crash: $x $bang $boom" 48 | } 49 | proc crash_time {x bang boom} { 50 | time {set result "crash_time: $x $bang $boom"} 1 51 | return $result 52 | } 53 | variable bang "ok" 54 | common boom "no-problem" 55 | } 56 | } "" 57 | 58 | test methods-1.2 {create an object to execute tests} { 59 | test_args ta 60 | } {ta} 61 | 62 | test methods-1.3 {argument checking: not enough args} { 63 | list [catch {ta two 1} msg] $msg 64 | } {1 {wrong # args: should be "ta two x y"}} 65 | 66 | test methods-1.4a {argument checking: too many args} { 67 | list [catch {ta two 1 2 3} msg] $msg 68 | } {1 {wrong # args: should be "ta two x y"}} 69 | 70 | test methods-1.4b {argument checking: too many args} { 71 | list [catch {ta none 1 2 3} msg] $msg 72 | } {1 {wrong # args: should be "ta none"}} 73 | 74 | test methods-1.5a {argument checking: just right} { 75 | list [catch {ta two 1 2} msg] $msg 76 | } {0 {two: 1 2}} 77 | 78 | test methods-1.5b {argument checking: just right} { 79 | list [catch {ta none} msg] $msg 80 | } {0 none} 81 | 82 | test methods-1.6a {default arguments: not enough args} { 83 | list [catch {ta defvals} msg] $msg 84 | } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} 85 | 86 | test methods-1.6b {default arguments: missing arguments supplied} { 87 | list [catch {ta defvals 1} msg] $msg 88 | } {0 {defvals: 1 def1 def2}} 89 | 90 | test methods-1.6c {default arguments: missing arguments supplied} { 91 | list [catch {ta defvals 1 2} msg] $msg 92 | } {0 {defvals: 1 2 def2}} 93 | 94 | test methods-1.6d {default arguments: all arguments assigned} { 95 | list [catch {ta defvals 1 2 3} msg] $msg 96 | } {0 {defvals: 1 2 3}} 97 | 98 | test methods-1.6e {default arguments: too many args} { 99 | list [catch {ta defvals 1 2 3 4} msg] $msg 100 | } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} 101 | 102 | test methods-1.7a {variable arguments: not enough args} { 103 | list [catch {ta varargs} msg] $msg 104 | } {1 {wrong # args: should be "ta varargs x ?y? ?arg arg ...?"}} 105 | 106 | test methods-1.7b {variable arguments: empty} { 107 | list [catch {ta varargs 1 2} msg] $msg 108 | } {0 {varargs: 1 2 ()}} 109 | 110 | test methods-1.7c {variable arguments: one} { 111 | list [catch {ta varargs 1 2 one} msg] $msg 112 | } {0 {varargs: 1 2 (one)}} 113 | 114 | test methods-1.7d {variable arguments: two} { 115 | list [catch {ta varargs 1 2 one two} msg] $msg 116 | } {0 {varargs: 1 2 (one two)}} 117 | 118 | test methods-1.8 {magic "args" argument has no magic unless at end of list} { 119 | list [catch {ta nomagic 1 2 3 4} msg] $msg 120 | } {1 {wrong # args: should be "ta nomagic args x"}} 121 | 122 | test methods-1.9 {formal args don't clobber class members} { 123 | list [catch {ta clash 1 2 3} msg] $msg \ 124 | [ta info variable bang -value] \ 125 | [ta info variable boom -value] 126 | } {0 {clash: 1 2 3} ok no-problem} 127 | 128 | test methods-1.10 {formal args don't clobber class members} { 129 | list [catch {test_args::crash 4 5 6} msg] $msg \ 130 | [ta info variable bang -value] \ 131 | [ta info variable boom -value] 132 | } {0 {crash: 4 5 6} ok no-problem} 133 | 134 | test methods-1.11 {formal args don't clobber class members, even in "time"} { 135 | list [catch {ta clash_time 7 8 9} msg] $msg \ 136 | [ta info variable bang -value] \ 137 | [ta info variable boom -value] 138 | } {0 {clash_time: 7 8 9} ok no-problem} 139 | 140 | test methods-1.12 {formal args don't clobber class members, even in "time"} { 141 | list [catch {test_args::crash_time a b c} msg] $msg \ 142 | [ta info variable bang -value] \ 143 | [ta info variable boom -value] 144 | } {0 {crash_time: a b c} ok no-problem} 145 | 146 | test methods-2.1 {covers leak condition test for compiled locals, no args} { 147 | for {set i 0} {$i < 100} {incr i} { 148 | ::itcl::class LeakClass { 149 | proc leakProc {} { set n 1 } 150 | } 151 | LeakClass::leakProc 152 | ::itcl::delete class LeakClass 153 | } 154 | list 0 155 | } 0 156 | test methods-2.2 {covers leak condition test for nested methods calls within eval, bug [8e632ce049]} -setup { 157 | itcl::class C1 { 158 | proc factory {} { 159 | set obj [C1 #auto] 160 | $obj myeval [list $obj read] 161 | itcl::delete object $obj 162 | } 163 | method myeval {script} { eval $script } 164 | method read {} { myeval {} } 165 | } 166 | } -body { 167 | time { C1::factory } 50 168 | list 0 169 | } -result 0 -cleanup { 170 | itcl::delete class C1 171 | } 172 | test methods-2.3 {call of method after object is destroyed inside other methods, SF-bug [c1289b1c32]} -setup { 173 | proc c1test {} { 174 | return c1test 175 | } 176 | itcl::class C1 { 177 | public method m1 {} { 178 | itcl::delete object $this 179 | c1test 180 | } 181 | public method m2 {} { 182 | rename $this {} 183 | c1test 184 | } 185 | public method c1test {} { 186 | return C1::c1test 187 | } 188 | } 189 | } -body { 190 | set result {} 191 | set obj [C1 #auto] 192 | lappend result [catch {$obj m1} v] $v [namespace which -command $obj] 193 | set obj [C1 #auto] 194 | lappend result [catch {$obj m2} v] $v [namespace which -command $obj] 195 | } -match glob -result {1 * {} 1 * {}} -cleanup { 196 | itcl::delete class C1 197 | rename c1test {} 198 | } 199 | 200 | # ---------------------------------------------------------------------- 201 | # Clean up 202 | # ---------------------------------------------------------------------- 203 | itcl::delete class test_args 204 | 205 | ::tcltest::cleanupTests 206 | return 207 | -------------------------------------------------------------------------------- /tests/mkindex.itcl: -------------------------------------------------------------------------------- 1 | # Test file for: 2 | # auto_mkindex 3 | # 4 | # This file provides example cases for testing the Tcl autoloading 5 | # facility. Things are much more complicated with namespaces and classes. 6 | # The "auto_mkindex" facility can no longer be built on top of a simple 7 | # regular expression parser. It must recognize constructs like this: 8 | # 9 | # namespace eval foo { 10 | # class Internal { ... } 11 | # body Internal::func {x y} { ... } 12 | # namespace eval bar { 13 | # class Another { ... } 14 | # } 15 | # } 16 | # 17 | # Note that class definitions can be nested inside of namespaces. 18 | # 19 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 20 | 21 | # 22 | # Should be able to handle simple class definitions, even if 23 | # they are prefaced with white space. 24 | # 25 | namespace import itcl::* 26 | 27 | class Simple1 { 28 | variable x 0 29 | public method bump {} {incr x} 30 | } 31 | itcl::class Simple2 { 32 | variable x 0 33 | public variable by 1 34 | public method bump {} 35 | } 36 | 37 | itcl::ensemble ens { 38 | part one {x} {} 39 | part two {x y} {} 40 | part three {x y z} {} 41 | } 42 | 43 | # 44 | # Should be able to handle "body" and "configbody" declarations. 45 | # 46 | body Simple2::bump {} {incr x $by} 47 | configbody Simple2::by {if {$by <= 0} {error "bad increment"}} 48 | 49 | # 50 | # Should be able to handle class declarations within namespaces, 51 | # even if they have explicit namespace paths. 52 | # 53 | namespace eval buried { 54 | class inside { 55 | variable x 0 56 | public variable by 1 57 | public method bump {} 58 | method skip {x y z} {} 59 | proc find {args} {} 60 | } 61 | body inside::bump {} {incr x $by} 62 | configbody inside::by {if {$by <= 0} {error "bad increment"}} 63 | 64 | class ::top { 65 | method skip {x y z} {} 66 | method ignore {} {} 67 | public proc find {args} {} 68 | protected proc notice {args} {} 69 | } 70 | 71 | ensemble ens { 72 | part one {x} {} 73 | part two {x y} {} 74 | part three {x y z} {} 75 | } 76 | 77 | namespace eval under { 78 | itcl::class neath { } 79 | } 80 | namespace eval deep { 81 | ::itcl::class within { } 82 | } 83 | } 84 | -------------------------------------------------------------------------------- /tests/mkindex.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for "auto_mkindex" and autoloading facility 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.1 15 | namespace import ::tcltest::test 16 | set ::tcl::inl_mem_test 0 17 | ::tcltest::loadTestedCommands 18 | package require itcl 19 | 20 | # ---------------------------------------------------------------------- 21 | # Test "auto_mkindex" in the presence of class definitions 22 | # ---------------------------------------------------------------------- 23 | test mkindex-1.1 {remove any existing tclIndex file} { 24 | file delete tclIndex 25 | file exists tclIndex 26 | } {0} 27 | 28 | test mkindex-1.2 {build tclIndex based on a test file} { 29 | if {[pwd] != $::tcltest::testsDirectory} { 30 | file copy -force [file join $::tcltest::testsDirectory mkindex.itcl] \ 31 | ./mkindex.itcl 32 | } 33 | auto_mkindex . mkindex.itcl 34 | if {[pwd] != $::tcltest::testsDirectory} { 35 | file delete -force ./mkindex.itcl 36 | } 37 | file exists tclIndex 38 | } {1} 39 | 40 | set element "{source *[file join . mkindex.itcl]}" 41 | 42 | test mkindex-1.3 {examine tclIndex} -body { 43 | namespace eval itcl_mkindex_tmp { 44 | set dir "." 45 | variable auto_index 46 | source -encoding utf-8 tclIndex 47 | set result "" 48 | foreach elem [lsort [array names auto_index]] { 49 | lappend result [list $elem $auto_index($elem)] 50 | } 51 | set result 52 | } 53 | } -match glob -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}" 54 | 55 | file delete tclIndex 56 | ::tcltest::cleanupTests 57 | return 58 | -------------------------------------------------------------------------------- /tests/namespace.test: -------------------------------------------------------------------------------- 1 | # 2 | # Tests for classes within namespaces 3 | # ---------------------------------------------------------------------- 4 | # AUTHOR: Michael J. McLennan 5 | # Bell Labs Innovations for Lucent Technologies 6 | # mmclennan@lucent.com 7 | # http://www.tcltk.com/itcl 8 | # ---------------------------------------------------------------------- 9 | # Copyright (c) 1993-1998 Lucent Technologies, Inc. 10 | # ====================================================================== 11 | # See the file "license.terms" for information on usage and 12 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 | 14 | package require tcltest 2.2 15 | namespace import ::tcltest::test 16 | ::tcltest::loadTestedCommands 17 | package require itcl 18 | 19 | # ---------------------------------------------------------------------- 20 | # Classes within namespaces 21 | # ---------------------------------------------------------------------- 22 | test namespace-1.1 {same class name can be used in different namespaces 23 | } -body { 24 | namespace eval test_ns_1 { 25 | itcl::class Counter { 26 | variable num 0 27 | method ++ {{by 1}} { 28 | incr num $by 29 | } 30 | method do {args} { 31 | return [eval $args] 32 | } 33 | common tag 1 34 | } 35 | proc exists {} { return "don't clobber me!" } 36 | } 37 | namespace eval test_ns_2 { 38 | itcl::class Counter { 39 | variable num 0 40 | method ++ {{by 2}} { 41 | if {$num == 0} { 42 | set num 1 43 | } else { 44 | set num [expr {$num*$by}] 45 | } 46 | } 47 | method do {args} { 48 | return [eval $args] 49 | } 50 | common tag 2 51 | } 52 | } 53 | } -result {} 54 | 55 | test namespace-1.2 {classes in different namespaces are different 56 | } -body { 57 | list [namespace eval test_ns_1::Counter {info variable tag}] \ 58 | [namespace eval test_ns_2::Counter {info variable tag}] \ 59 | } -result {{protected common ::test_ns_1::Counter::tag 1 1} {protected common ::test_ns_2::Counter::tag 2 2}} 60 | 61 | test namespace-1.3 {create an object in one namespace 62 | } -body { 63 | namespace eval test_ns_1 { 64 | list [Counter c] [c ++] [c ++] [c ++] [c ++] 65 | } 66 | } -result {c 1 2 3 4} 67 | 68 | test namespace-1.4 {create an object in another namespace 69 | } -body { 70 | namespace eval test_ns_2 { 71 | list [Counter c] [c ++] [c ++] [c ++] [c ++] 72 | } 73 | } -cleanup { 74 | namespace delete ::itcl::internal::variables::test_ns_2 75 | namespace delete test_ns_2 76 | } -result {c 1 2 4 8} 77 | 78 | test namespace-1.5 {can find classes wrapped in a namespace 79 | } -body { 80 | list [catch {test_ns_1::c do itcl::find objects -isa Counter} msg] $msg \ 81 | [catch {test_ns_1::c do itcl::find objects -class Counter} msg] $msg 82 | } -result {0 ::test_ns_1::c 0 ::test_ns_1::c} 83 | 84 | test namespace-1.6 {can't create an object that clobbers a command in this namespace 85 | } -body { 86 | list [catch {namespace eval test_ns_1 {Counter exists}} msg] $msg 87 | } -result {1 {command "exists" already exists in namespace "::test_ns_1"}} 88 | 89 | test namespace-1.7 {can create an object that shadows a command in the global namespace 90 | } -body { 91 | list [catch {namespace eval test_ns_1 {Counter lreplace}} msg] $msg \ 92 | [catch {itcl::find objects *lreplace} msg] $msg \ 93 | [namespace eval test_ns_1 {namespace which lreplace}] 94 | } -cleanup { 95 | namespace delete ::itcl::internal::variables::test_ns_1 96 | namespace delete test_ns_1 97 | } -result {0 lreplace 0 ::test_ns_1::lreplace ::test_ns_1::lreplace} 98 | 99 | ::tcltest::cleanupTests 100 | return 101 | -------------------------------------------------------------------------------- /tests/tclIndex: -------------------------------------------------------------------------------- 1 | # Tcl autoload index file, version 2.0 2 | # This file is generated by the "auto_mkindex" command 3 | # and sourced to set up indexing information for one or 4 | # more commands. Typically each line is a command that 5 | # sets an element in the auto_index array, where the 6 | # element name is the name of a command and the value is 7 | # a script that loads the command. 8 | 9 | set auto_index(Simple1) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 10 | set auto_index(Simple2) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 11 | set auto_index(ens) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 12 | set auto_index(::Simple2::bump) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 13 | set auto_index(::Simple2::by) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 14 | set auto_index(::buried::inside) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 15 | set auto_index(::buried::inside::find) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 16 | set auto_index(::buried::inside::bump) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 17 | set auto_index(::buried::inside::by) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 18 | set auto_index(top) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 19 | set auto_index(::top::find) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 20 | set auto_index(::top::notice) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 21 | set auto_index(::buried::ens) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 22 | set auto_index(::buried::under::neath) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 23 | set auto_index(::buried::deep::within) [list source -encoding utf-8 [file join $dir mkindex.itcl]] 24 | -------------------------------------------------------------------------------- /win/dllEntryPoint.c: -------------------------------------------------------------------------------- 1 | /* 2 | * dllEntryPoint.c -- 3 | * 4 | * This file implements the Dll entry point as needed by Windows. 5 | */ 6 | 7 | #define WIN32_LEAN_AND_MEAN 8 | #include 9 | 10 | #ifdef _MSC_VER 11 | /* Only do this when MSVC++ is compiling us. */ 12 | # define DllEntryPoint DllMain 13 | # if defined(USE_TCL_STUBS) && (!defined(_MT) || !defined(_DLL) || defined(_DEBUG)) 14 | /* 15 | * This fixes a bug with how the Stubs library was compiled. 16 | * The requirement for msvcrt.lib from tclstubXX.lib should 17 | * be removed. 18 | */ 19 | # pragma comment(linker, "-nodefaultlib:msvcrt.lib") 20 | # endif 21 | #endif 22 | 23 | /* 24 | *---------------------------------------------------------------------- 25 | * 26 | * DllEntryPoint -- 27 | * 28 | * This wrapper function is used by Windows to invoke the 29 | * initialization code for the DLL. If we are compiling 30 | * with Visual C++, this routine will be renamed to DllMain. 31 | * 32 | * Results: 33 | * Returns TRUE; 34 | * 35 | * Side effects: 36 | * None. 37 | * 38 | *---------------------------------------------------------------------- 39 | */ 40 | 41 | #ifndef STATIC_BUILD 42 | 43 | BOOL APIENTRY 44 | DllEntryPoint(hInst, reason, reserved) 45 | HINSTANCE hInst; /* Library instance handle. */ 46 | DWORD reason; /* Reason this function is being called. */ 47 | LPVOID reserved; /* Not used. */ 48 | { 49 | return TRUE; 50 | } 51 | 52 | #endif 53 | -------------------------------------------------------------------------------- /win/gitmanifest.in: -------------------------------------------------------------------------------- 1 | git- -------------------------------------------------------------------------------- /win/itcl.rc: -------------------------------------------------------------------------------- 1 | // 2 | // Version resource script. 3 | // 4 | 5 | #include 6 | #include 7 | 8 | // 9 | // build-up the name suffix that defines the type of build this is. 10 | // 11 | #if DEBUG && !UNCHECKED 12 | #define SUFFIX_DEBUG "g" 13 | #else 14 | #define SUFFIX_DEBUG "" 15 | #endif 16 | 17 | #define SUFFIX SUFFIX_DEBUG 18 | 19 | 20 | VS_VERSION_INFO VERSIONINFO 21 | FILEVERSION ITCL_MAJOR_VERSION,ITCL_MINOR_VERSION,ITCL_RELEASE_LEVEL,ITCL_RELEASE_SERIAL 22 | PRODUCTVERSION ITCL_MAJOR_VERSION,ITCL_MINOR_VERSION,ITCL_RELEASE_LEVEL,ITCL_RELEASE_SERIAL 23 | FILEFLAGSMASK 0x3fL 24 | #ifdef DEBUG 25 | FILEFLAGS VS_FF_DEBUG 26 | #else 27 | FILEFLAGS 0x0L 28 | #endif 29 | FILEOS VOS__WINDOWS32 30 | FILETYPE VFT_DLL 31 | FILESUBTYPE 0x0L 32 | BEGIN 33 | BLOCK "StringFileInfo" 34 | BEGIN 35 | BLOCK "040904b0" 36 | BEGIN 37 | VALUE "FileDescription", "Itcl language extension for Tcl\0" 38 | VALUE "Authors", "Michael McLennan, Arnulf Wiedemann, David Gravereaux, Chad Smith, Mark Harrison, Daniel A. Steffen, and many others\0" 39 | VALUE "OriginalFilename", "itcl" STRINGIFY(ITCL_MAJOR_VERSION) STRINGIFY(ITCL_MINOR_VERSION) SUFFIX ".dll\0" 40 | VALUE "CompanyName", "Bell Labs Innovations for Lucent Technologies\0" 41 | VALUE "FileVersion", ITCL_PATCH_LEVEL 42 | VALUE "LegalCopyright", "Copyright \251 1993-2009\0" 43 | VALUE "ProductName", "[Incr Tcl] " ITCL_VERSION " for Windows\0" 44 | VALUE "ProductVersion", ITCL_PATCH_LEVEL 45 | END 46 | END 47 | BLOCK "VarFileInfo" 48 | BEGIN 49 | VALUE "Translation", 0x409, 1200 50 | END 51 | END 52 | 53 | 54 | 55 | 56 | -------------------------------------------------------------------------------- /win/itclUuid.h.in: -------------------------------------------------------------------------------- 1 | #define ITCL_VERSION_UUID \ 2 | -------------------------------------------------------------------------------- /win/makefile.vc: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------- -*- makefile -*- 2 | # 3 | # Makefile for ITcl 4 | # 5 | # Basic build, test and install 6 | # nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source 7 | # nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source test 8 | # nmake /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source install 9 | # 10 | # For other build options (debug, static etc.), 11 | # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for 12 | # detailed documentation. 13 | # 14 | # See the file "license.terms" for information on usage and redistribution 15 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16 | # 17 | #------------------------------------------------------------------------------ 18 | 19 | PROJECT = itcl 20 | NEED_TCL_SOURCE = 1 21 | RCFILE = itcl.rc 22 | 23 | PRJ_DEFINES = $(PRJ_DEFINES) 24 | PRJ_DEFINES = $(PRJ_DEFINES) -I$(TMP_DIR) 25 | 26 | !include "rules-ext.vc" 27 | 28 | PRJ_OBJS = \ 29 | $(TMP_DIR)\itcl2TclOO.obj \ 30 | $(TMP_DIR)\itclBase.obj \ 31 | $(TMP_DIR)\itclBuiltin.obj \ 32 | $(TMP_DIR)\itclClass.obj \ 33 | $(TMP_DIR)\itclCmd.obj \ 34 | $(TMP_DIR)\itclEnsemble.obj \ 35 | $(TMP_DIR)\itclHelpers.obj \ 36 | $(TMP_DIR)\itclInfo.obj \ 37 | $(TMP_DIR)\itclLinkage.obj \ 38 | $(TMP_DIR)\itclMethod.obj \ 39 | $(TMP_DIR)\itclMigrate2TclCore.obj \ 40 | $(TMP_DIR)\itclObject.obj \ 41 | $(TMP_DIR)\itclParse.obj \ 42 | $(TMP_DIR)\itclResolve.obj \ 43 | $(TMP_DIR)\itclStubs.obj \ 44 | $(TMP_DIR)\itclStubInit.obj \ 45 | $(TMP_DIR)\itclTclIntStubsFcn.obj \ 46 | $(TMP_DIR)\itclUtil.obj \ 47 | !if !$(STATIC_BUILD) 48 | $(TMP_DIR)\dllEntryPoint.obj \ 49 | !endif 50 | 51 | PRJ_STUBOBJS = $(TMP_DIR)\itclStubLib.obj 52 | 53 | PRJ_DEFINES = $(PRJ_DEFINES) /D_CRT_SECURE_NO_WARNINGS 54 | !if $(DEBUG) 55 | PRJ_DEFINES = $(PRJ_DEFINES) /DITCL_DEBUG 56 | !endif 57 | 58 | PRJ_HEADERS_PUBLIC = \ 59 | $(GENERICDIR)\itcl.h \ 60 | $(GENERICDIR)\itclDecls.h 61 | 62 | (ROOT)\manifest.uuid: 63 | copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid 64 | git rev-parse HEAD >>$(ROOT)\manifest.uuid 65 | 66 | $(TMP_DIR)\itclUuid.h: $(ROOT)\manifest.uuid 67 | copy $(WIN_DIR)\itclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\itclUuid.h 68 | 69 | (TMP_DIR)\itclBase.obj: $(TMP_DIR)\itclUuid.h 70 | 71 | # Define the standard targets except we have a custom test target 72 | DISABLE_TARGET_test = 1 73 | !include "$(_RULESDIR)\targets.vc" 74 | 75 | pkgindex: $(OUT_DIR)\pkgIndex.tcl 76 | $(OUT_DIR)\pkgIndex.tcl: 77 | @$(COPY) << "$(OUT_DIR)\pkgIndex.tcl" 78 | # -*- tcl -*- 79 | # Tcl package index file, version 1.1 80 | # 81 | 82 | if {![package vsatisfies [package provide Tcl] 8.6-]} {return} 83 | 84 | if {[package vsatisfies [package provide Tcl] 9.0-]} { 85 | package ifneeded itcl $(DOTVERSION) \ 86 | [list load [file join $$dir tcl9itcl$(VERSION).dll] Itcl] 87 | } else { 88 | package ifneeded itcl $(DOTVERSION) \ 89 | [list load [file join $$dir itcl$(VERSION)$(SUFX).dll] Itcl] 90 | } 91 | package ifneeded Itcl $(DOTVERSION) [list package require -exact itcl $(DOTVERSION)] 92 | << 93 | 94 | !if $(STATIC_BUILD) 95 | test : 96 | @echo test target not supported for a static library. 97 | !else 98 | test : setup $(PROJECT) 99 | $(TCLSH) ..\tests\all.tcl $(TESTFLAGS) -loadfile << 100 | set env(ITCL_LIBRARY) [file normalize [file join $(MAKEDIR:\=/) .. library]] 101 | package ifneeded $(PROJECT) $(DOTVERSION) [list load [file normalize [file join $(MAKEDIR:\=/) $(PRJLIB:\=/)]]] 102 | << 103 | !endif 104 | 105 | genstubs: 106 | !if $(TCLINSTALL) 107 | @echo Need the source distribution to regenerate the Stubs table. 108 | !else 109 | $(TCLSH) $(TOOLSDIR)\genStubs.tcl $(GENERICDIR) \ 110 | $(GENERICDIR)\$(PROJECT).decls $(GENERICDIR)\$(PROJECT)Int.decls 111 | !endif 112 | 113 | # Explicit dependency rules 114 | $(GENERICDIR)\itclBase.c : $(GENERICDIR)\itclInt.h $(TMP_DIR)\itclUuid.h 115 | -------------------------------------------------------------------------------- /win/rules-ext.vc: -------------------------------------------------------------------------------- 1 | # This file should only be included in makefiles for Tcl extensions, 2 | # NOT in the makefile for Tcl itself. 3 | 4 | !ifndef _RULES_EXT_VC 5 | 6 | # We need to run from the directory the parent makefile is located in. 7 | # nmake does not tell us what makefile was used to invoke it so parent 8 | # makefile has to set the MAKEFILEVC macro or we just make a guess and 9 | # warn if we think that is not the case. 10 | !if "$(MAKEFILEVC)" == "" 11 | 12 | !if exist("$(PROJECT).vc") 13 | MAKEFILEVC = $(PROJECT).vc 14 | !elseif exist("makefile.vc") 15 | MAKEFILEVC = makefile.vc 16 | !endif 17 | !endif # "$(MAKEFILEVC)" == "" 18 | 19 | !if !exist("$(MAKEFILEVC)") 20 | MSG = ^ 21 | You must run nmake from the directory containing the project makefile.^ 22 | If you are doing that and getting this message, set the MAKEFILEVC^ 23 | macro to the name of the project makefile. 24 | !message WARNING: $(MSG) 25 | !endif 26 | 27 | !if "$(PROJECT)" == "tcl" 28 | !error The rules-ext.vc file is not intended for Tcl itself. 29 | !endif 30 | 31 | # We extract version numbers using the nmakehlp program. For now use 32 | # the local copy of nmakehlp. Once we locate Tcl, we will use that 33 | # one if it is newer. 34 | !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" 35 | !if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] 36 | !endif 37 | !else 38 | !if [copy x86_64-w64-mingw32-nmakehlp.exe nmakehlp.exe >NUL] 39 | !endif 40 | !endif 41 | 42 | # First locate the Tcl directory that we are working with. 43 | !if "$(TCLDIR)" != "" 44 | 45 | _RULESDIR = $(TCLDIR:/=\) 46 | 47 | !else 48 | 49 | # If an installation path is specified, that is also the Tcl directory. 50 | # Also Tk never builds against an installed Tcl, it needs Tcl sources 51 | !if defined(INSTALLDIR) && "$(PROJECT)" != "tk" 52 | _RULESDIR=$(INSTALLDIR:/=\) 53 | !else 54 | # Locate Tcl sources 55 | !if [echo _RULESDIR = \> nmakehlp.out] \ 56 | || [nmakehlp -L generic\tcl.h >> nmakehlp.out] 57 | _RULESDIR = ..\..\tcl 58 | !else 59 | !include nmakehlp.out 60 | !endif 61 | 62 | !endif # defined(INSTALLDIR).... 63 | 64 | !endif # ifndef TCLDIR 65 | 66 | # Now look for the targets.vc file under the Tcl root. Note we check this 67 | # file and not rules.vc because the latter also exists on older systems. 68 | !if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl 69 | _RULESDIR = $(_RULESDIR)\lib\nmake 70 | !elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources 71 | _RULESDIR = $(_RULESDIR)\win 72 | !else 73 | # If we have not located Tcl's targets file, most likely we are compiling 74 | # against an older version of Tcl and so must use our own support files. 75 | _RULESDIR = . 76 | !endif 77 | 78 | !if "$(_RULESDIR)" != "." 79 | # Potentially using Tcl's support files. If this extension has its own 80 | # nmake support files, need to compare the versions and pick newer. 81 | 82 | !if exist("rules.vc") # The extension has its own copy 83 | 84 | !if [echo TCL_RULES_MAJOR = \> versions.vc] \ 85 | && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] 86 | !endif 87 | !if [echo TCL_RULES_MINOR = \>> versions.vc] \ 88 | && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] 89 | !endif 90 | 91 | !if [echo OUR_RULES_MAJOR = \>> versions.vc] \ 92 | && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] 93 | !endif 94 | !if [echo OUR_RULES_MINOR = \>> versions.vc] \ 95 | && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] 96 | !endif 97 | !include versions.vc 98 | # We have a newer version of the support files, use them 99 | !if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) 100 | _RULESDIR = . 101 | !endif 102 | 103 | !endif # if exist("rules.vc") 104 | 105 | !endif # if $(_RULESDIR) != "." 106 | 107 | # Let rules.vc know what copy of nmakehlp.c to use. 108 | NMAKEHLPC = $(_RULESDIR)\nmakehlp.c 109 | 110 | # Get rid of our internal defines before calling rules.vc 111 | !undef TCL_RULES_MAJOR 112 | !undef TCL_RULES_MINOR 113 | !undef OUR_RULES_MAJOR 114 | !undef OUR_RULES_MINOR 115 | 116 | !if exist("$(_RULESDIR)\rules.vc") 117 | !message *** Using $(_RULESDIR)\rules.vc 118 | !include "$(_RULESDIR)\rules.vc" 119 | !else 120 | !error *** Could not locate rules.vc in $(_RULESDIR) 121 | !endif 122 | 123 | !endif # _RULES_EXT_VC -------------------------------------------------------------------------------- /win/svnmanifest.in: -------------------------------------------------------------------------------- 1 | svn-r -------------------------------------------------------------------------------- /win/targets.vc: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------- -*- makefile -*- 2 | # targets.vc -- 3 | # 4 | # Part of the nmake based build system for Tcl and its extensions. 5 | # This file defines some standard targets for the convenience of extensions 6 | # and can be optionally included by the extension makefile. 7 | # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. 8 | 9 | $(PROJECT): setup pkgindex $(PRJLIB) 10 | 11 | !ifdef PRJ_STUBOBJS 12 | $(PROJECT): $(PRJSTUBLIB) 13 | $(PRJSTUBLIB): $(PRJ_STUBOBJS) 14 | $(LIBCMD) $** 15 | 16 | $(PRJ_STUBOBJS): 17 | $(CCSTUBSCMD) %s 18 | !endif # PRJ_STUBOBJS 19 | 20 | !ifdef PRJ_MANIFEST 21 | $(PROJECT): $(PRJLIB).manifest 22 | $(PRJLIB).manifest: $(PRJ_MANIFEST) 23 | @nmakehlp -s << $** >$@ 24 | @MACHINE@ $(MACHINE:IX86=X86) 25 | << 26 | !endif 27 | 28 | !if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk" 29 | $(PRJLIB): $(PRJ_OBJS) $(RESFILE) 30 | !if $(STATIC_BUILD) 31 | $(LIBCMD) $** 32 | !else 33 | $(DLLCMD) $** 34 | $(_VC_MANIFEST_EMBED_DLL) 35 | !endif 36 | -@del $*.exp 37 | !endif 38 | 39 | !if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != "" 40 | $(PRJ_OBJS): $(PRJ_HEADERS) 41 | !endif 42 | 43 | # If parent makefile has defined stub objects, add their installation 44 | # to the default install 45 | !if "$(PRJ_STUBOBJS)" != "" 46 | default-install: default-install-stubs 47 | !endif 48 | 49 | # Unlike the other default targets, these cannot be in rules.vc because 50 | # the executed command depends on existence of macro PRJ_HEADERS_PUBLIC 51 | # that the parent makefile will not define until after including rules-ext.vc 52 | !if "$(PRJ_HEADERS_PUBLIC)" != "" 53 | default-install: default-install-headers 54 | default-install-headers: 55 | @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' 56 | @if not exist "$(INCLUDE_INSTALL_DIR)" $(MKDIR) "$(INCLUDE_INSTALL_DIR)" 57 | @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" 58 | !endif 59 | 60 | !if "$(DISABLE_STANDARD_TARGETS)" == "" 61 | DISABLE_STANDARD_TARGETS = 0 62 | !endif 63 | 64 | !if "$(DISABLE_TARGET_setup)" == "" 65 | DISABLE_TARGET_setup = 0 66 | !endif 67 | !if "$(DISABLE_TARGET_install)" == "" 68 | DISABLE_TARGET_install = 0 69 | !endif 70 | !if "$(DISABLE_TARGET_clean)" == "" 71 | DISABLE_TARGET_clean = 0 72 | !endif 73 | !if "$(DISABLE_TARGET_test)" == "" 74 | DISABLE_TARGET_test = 0 75 | !endif 76 | !if "$(DISABLE_TARGET_shell)" == "" 77 | DISABLE_TARGET_shell = 0 78 | !endif 79 | 80 | !if !$(DISABLE_STANDARD_TARGETS) 81 | !if !$(DISABLE_TARGET_setup) 82 | setup: default-setup 83 | !endif 84 | !if !$(DISABLE_TARGET_install) 85 | install: default-install 86 | !endif 87 | !if !$(DISABLE_TARGET_clean) 88 | clean: default-clean 89 | realclean: hose 90 | hose: default-hose 91 | distclean: realclean default-distclean 92 | !endif 93 | !if !$(DISABLE_TARGET_test) 94 | test: default-test 95 | !endif 96 | !if !$(DISABLE_TARGET_shell) 97 | shell: default-shell 98 | !endif 99 | !endif # DISABLE_STANDARD_TARGETS 100 | -------------------------------------------------------------------------------- /win/toaster.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/win/toaster.bmp -------------------------------------------------------------------------------- /win/x86_64-w64-mingw32-nmakehlp.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tcltk/itcl/684e30a16b95d3d0ce679f86adc0cf4daaf4bed4/win/x86_64-w64-mingw32-nmakehlp.exe --------------------------------------------------------------------------------