itcl4.2.2/0000755003604700454610000000000014140773323010774 5ustar dgp771divitcl4.2.2/win/0000755003604700454610000000000014140773324011572 5ustar dgp771divitcl4.2.2/win/toaster.bmp0000644003604700454610000000606614137636151013765 0ustar dgp771divBM6 6(  ÄÄÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆ„‚„„„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿ„„„„‚„„‚„„‚„„„„„„‚„„‚„ÿÿÿÿÿÿÿÿÿ„‚„„„„‚„„‚„„‚„„„„‚„„„„‚„ÿÿÿÿÿÿÿÿÿ„„„‚„„‚„„‚„„‚„„„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„‚„„‚„„‚„„‚„„‚„„„„‚„„‚„„‚„„‚„„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„‚„„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„‚„„‚„ÆÃÆ„‚„„„„‚„„‚„„‚„„‚„„‚„„‚„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„ÆÃÆ„‚„„‚„„‚„„‚„„‚„ÆÃÆ„‚„„‚„„‚„ÿÿÿÿÿÿÿÿÿÿÿ„ÆÃÆ„‚„„‚„ÆÃÆÆÃÆ„‚„ÆÃÆÆÃÆÆÃÆ„‚„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿ„„‚„„‚„„„‚„ÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆ„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„‚„ÆÃÆÆÃÆÆÃÆÿÿÿÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆ„‚„ÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„„‚„„‚„ÆÃÆÆÃÆÆÃÆÿÿÿÿÿÿÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÿÿÿÆÃÆÆÃÆÆÃÆ„ÿÿÿÿÿÿÿÿÿÿÿ„‚„ÆÃÆÆÃÆÆÃÆÆÃÆÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆÆÃÆÿÿÿÆÃÆÆÃÆÿÿÿÆÃÆÿÿÿÆÃÆÆÃÆ„ÿÿÿÿÿÿÿÿÿÿ„ÆÃÆÆÃÆ„‚„ÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆÿÿÿÿÿÿÆÃÆÆÃÆÿÿÿÆÃÆÿÿÿÆÃÆÆÃÆ„‚„„‚„ÿÿÿÿÿÿÿÿ„‚„„‚„ÆÃÆÆÃÆÆÃÆÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆ„ÿÿÿÿÿÿÿÿ„‚„„‚„ÆÃÆÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆÿÿÿÿÿÿÿ„‚„ÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆ„‚„„ÿÿÿÿÿ„„‚„ÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆ„„ÿÿ„‚„ÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„ÿÿÿ„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„ÿÿÿÿÿÿÿÿÿ„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿ„‚„ÿÿÿÿÿ„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆÿÿÿÿÿÿ„‚„ÿÿÿÿÿÿÿÿÿ„ÿÿÿÿÿÿÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„ÆÃÆÿÿÿÿÿÿ„‚„ÿÿÿÿÿÿ„ÿÿÿÿÿÿÿÿÆÃÆ„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„ÿÿÿÿÿÿ„‚„„„‚„ÿÿÿ„ÿÿÿÿÿÿÿÿÿÿÿ„ÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„„‚„ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ„‚„ÿÿÿ„‚„„ÆÃÆÆÃÆÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÆÃÆ„‚„„„‚„„„„„ÆÃÆÿÿÿÿÿÿÿÿÿitcl4.2.2/win/targets.vc0000644003604700454610000000505614137636151013605 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) $(PRJSTUBLIB): $(PRJ_STUBOBJS) $(LIBCMD) $** $(PRJ_STUBOBJS): $(CCSTUBSCMD) %s !endif # PRJ_STUBOBJS !ifdef PRJ_MANIFEST $(PROJECT): $(PRJLIB).manifest $(PRJLIB).manifest: $(PRJ_MANIFEST) @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) << !endif !if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk" $(PRJLIB): $(PRJ_OBJS) $(RESFILE) !if $(STATIC_BUILD) $(LIBCMD) $** !else $(DLLCMD) $** $(_VC_MANIFEST_EMBED_DLL) !endif -@del $*.exp !endif !if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != "" $(PRJ_OBJS): $(PRJ_HEADERS) !endif # If parent makefile has defined stub objects, add their installation # to the default install !if "$(PRJ_STUBOBJS)" != "" default-install: default-install-stubs !endif # Unlike the other default targets, these cannot be in rules.vc because # the executed command depends on existence of macro PRJ_HEADERS_PUBLIC # that the parent makefile will not define until after including rules-ext.vc !if "$(PRJ_HEADERS_PUBLIC)" != "" default-install: default-install-headers default-install-headers: @echo Installing headers to '$(INCLUDE_INSTALL_DIR)' @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)" !endif !if "$(DISABLE_STANDARD_TARGETS)" == "" DISABLE_STANDARD_TARGETS = 0 !endif !if "$(DISABLE_TARGET_setup)" == "" DISABLE_TARGET_setup = 0 !endif !if "$(DISABLE_TARGET_install)" == "" DISABLE_TARGET_install = 0 !endif !if "$(DISABLE_TARGET_clean)" == "" DISABLE_TARGET_clean = 0 !endif !if "$(DISABLE_TARGET_test)" == "" DISABLE_TARGET_test = 0 !endif !if "$(DISABLE_TARGET_shell)" == "" DISABLE_TARGET_shell = 0 !endif !if !$(DISABLE_STANDARD_TARGETS) !if !$(DISABLE_TARGET_setup) setup: default-setup !endif !if !$(DISABLE_TARGET_install) install: default-install !endif !if !$(DISABLE_TARGET_clean) clean: default-clean realclean: hose hose: default-hose distclean: realclean default-distclean !endif !if !$(DISABLE_TARGET_test) test: default-test !endif !if !$(DISABLE_TARGET_shell) shell: default-shell !endif !endif # DISABLE_STANDARD_TARGETS itcl4.2.2/win/rules.vc0000644003604700454610000017114614137636232013272 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/main/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 9 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" PRJ_PACKAGE_TCLNAME = $(PROJECT) !endif # Also special case Tcl and Tk to save some typing later DOING_TCL = 0 DOING_TK = 0 !if "$(PROJECT)" == "tcl" DOING_TCL = 1 !elseif "$(PROJECT)" == "tk" DOING_TK = 1 !endif !ifndef NEED_TK # Backwards compatibility !ifdef PROJECT_REQUIRES_TK NEED_TK = $(PROJECT_REQUIRES_TK) !else NEED_TK = 0 !endif !endif !ifndef NEED_TCL_SOURCE NEED_TCL_SOURCE = 0 !endif !ifdef NEED_TK_SOURCE !if $(NEED_TK_SOURCE) NEED_TK = 1 !endif !else NEED_TK_SOURCE = 0 !endif ################################################################ # Nmake is a pretty weak environment in syntax and capabilities # so this file is necessarily verbose. It's broken down into # the following parts. # # 0. Sanity check that compiler environment is set up and initialize # any built-in settings from the parent makefile # 1. First define the external tools used for compiling, copying etc. # as this is independent of everything else. # 2. Figure out our build structure in terms of the directory, whether # we are building Tcl or an extension, etc. # 3. Determine the compiler and linker versions # 4. Build the nmakehlp helper application # 5. Determine the supported compiler options and features # 6. Parse the OPTS macro value for user-specified build configuration # 7. Parse the STATS macro value for statistics instrumentation # 8. Parse the CHECKS macro for additional compilation checks # 9. Extract Tcl, and possibly Tk, version numbers from the headers # 10. Based on this selected configuration, construct the output # directory and file paths # 11. Construct the paths where the package is to be installed # 12. Set up the actual options passed to compiler and linker based # on the information gathered above. # 13. Define some standard build targets and implicit rules. These may # be optionally disabled by the parent makefile. # 14. (For extensions only.) Compare the configuration of the target # Tcl and the extensions and warn against discrepancies. # # One final note about the macro names used. They are as they are # for historical reasons. We would like legacy extensions to # continue to work with this make include file so be wary of # changing them for consistency or clarity. # 0. Sanity check compiler environment # Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or # VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) MSG = ^ Visual C++ compiler environment not initialized. !error $(MSG) !endif # We need to run from the directory the parent makefile is located in. # nmake does not tell us what makefile was used to invoke it so parent # makefile has to set the MAKEFILEVC macro or we just make a guess and # warn if we think that is not the case. !if "$(MAKEFILEVC)" == "" !if exist("$(PROJECT).vc") MAKEFILEVC = $(PROJECT).vc !elseif exist("makefile.vc") MAKEFILEVC = makefile.vc !endif !endif # "$(MAKEFILEVC)" == "" !if !exist("$(MAKEFILEVC)") MSG = ^ You must run nmake from the directory containing the project makefile.^ If you are doing that and getting this message, set the MAKEFILEVC^ macro to the name of the project makefile. !message WARNING: $(MSG) !endif ################################################################ # 1. Define external programs being used #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right # "delete all" method. #---------------------------------------------------------- RMDIR = rmdir /S /Q CPY = xcopy /i /y >NUL CPYDIR = xcopy /e /i /y >NUL COPY = copy /y >NUL MKDIR = mkdir ###################################################################### # 2. Figure out our build environment in terms of what we're building. # # (a) Tcl itself # (b) Tk # (c) a Tcl extension using libraries/includes from an *installed* Tcl # (d) a Tcl extension using libraries/includes from Tcl source directory # # This last is needed because some extensions still need # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory # WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set # when building Tcl itself. # _INSTALLDIR - native form of the installation path. For Tcl # this will be the root of the Tcl installation. For extensions # this will be the lib directory under the root. # TCLINSTALL - set to 1 if _TCLDIR refers to # headers and libraries from an installed Tcl, and 0 if built against # Tcl sources. Not set when building Tcl itself. Yes, not very well # named. # _TCL_H - native path to the tcl.h file # # If Tk is involved, also sets the following # _TKDIR - native form Tk installation OR Tk source. Not set if building # Tk itself. # TKINSTALL - set 1 if _TKDIR refers to installed Tk and 0 if Tk sources # _TK_H - native path to the tk.h file # Root directory for sources and assumed subdirectories ROOT = $(MAKEDIR)\.. # The following paths CANNOT have spaces in them as they appear on the # left side of implicit rules. !ifndef COMPATDIR COMPATDIR = $(ROOT)\compat !endif !ifndef DOCDIR DOCDIR = $(ROOT)\doc !endif !ifndef GENERICDIR GENERICDIR = $(ROOT)\generic !endif !ifndef TOOLSDIR TOOLSDIR = $(ROOT)\tools !endif !ifndef TESTDIR TESTDIR = $(ROOT)\tests !endif !ifndef LIBDIR !if exist("$(ROOT)\library") LIBDIR = $(ROOT)\library !else LIBDIR = $(ROOT)\lib !endif !endif !ifndef DEMODIR !if exist("$(LIBDIR)\demos") DEMODIR = $(LIBDIR)\demos !else DEMODIR = $(ROOT)\demos !endif !endif # ifndef DEMODIR # Do NOT use WINDIR because it is Windows internal environment # variable to point to c:\windows! WIN_DIR = $(ROOT)\win !ifndef RCDIR !if exist("$(WIN_DIR)\rc") RCDIR = $(WIN_DIR)\rc !else RCDIR = $(WIN_DIR) !endif !endif RCDIR = $(RCDIR:/=\) # The target directory where the built packages and binaries will be installed. # INSTALLDIR is the (optional) path specified by the user. # _INSTALLDIR is INSTALLDIR using the backslash separator syntax !ifdef INSTALLDIR ### Fix the path separators. _INSTALLDIR = $(INSTALLDIR:/=\) !else ### Assume the normal default. _INSTALLDIR = $(HOMEDRIVE)\Tcl !endif !if $(DOING_TCL) # BEGIN Case 2(a) - Building Tcl itself # Only need to define _TCL_H _TCL_H = ..\generic\tcl.h # END Case 2(a) - Building Tcl itself !elseif $(DOING_TK) # BEGIN Case 2(b) - Building Tk TCLINSTALL = 0 # Tk always builds against Tcl source, not an installed Tcl !if "$(TCLDIR)" == "" !if [echo TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out !endif # TCLDIR == "" _TCLDIR = $(TCLDIR:/=\) _TCL_H = $(_TCLDIR)\generic\tcl.h !if !exist("$(_TCL_H)") !error Could not locate tcl.h. Please set the TCLDIR macro to point to the Tcl *source* directory. !endif _TK_H = ..\generic\tk.h # END Case 2(b) - Building Tk !else # BEGIN Case 2(c) or (d) - Building an extension other than Tk # If command line has specified Tcl location through TCLDIR, use it # else default to the INSTALLDIR setting !if "$(TCLDIR)" != "" _TCLDIR = $(TCLDIR:/=\) !if exist("$(_TCLDIR)\include\tcl.h") # Case 2(c) with TCLDIR defined TCLINSTALL = 1 _TCL_H = $(_TCLDIR)\include\tcl.h !elseif exist("$(_TCLDIR)\generic\tcl.h") # Case 2(d) with TCLDIR defined TCLINSTALL = 0 _TCL_H = $(_TCLDIR)\generic\tcl.h !endif !else # # Case 2(c) for extensions with TCLDIR undefined # Need to locate Tcl depending on whether it needs Tcl source or not. # If we don't, check the INSTALLDIR for an installed Tcl first !if exist("$(_INSTALLDIR)\include\tcl.h") && !$(NEED_TCL_SOURCE) TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h !else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h !endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. !error $(MSG) !endif # Now do the same to locate Tk headers and libs if project requires Tk !if $(NEED_TK) !if "$(TKDIR)" != "" _TKDIR = $(TKDIR:/=\) !if exist("$(_TKDIR)\include\tk.h") TKINSTALL = 1 _TK_H = $(_TKDIR)\include\tk.h !elseif exist("$(_TKDIR)\generic\tk.h") TKINSTALL = 0 _TK_H = $(_TKDIR)\generic\tk.h !endif !else # TKDIR not defined # Need to locate Tcl depending on whether it needs Tcl source or not. # If we don't, check the INSTALLDIR for an installed Tcl first !if exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) TKINSTALL = 1 # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TKDIR = $(_INSTALLDIR)\.. _TK_H = $(_TKDIR)\include\tk.h TKDIR = $(_TKDIR) !else # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) !if [echo _TKDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tk.h >> nmakehlp.out] !error *** Could not locate Tk source directory. !endif !include nmakehlp.out TKINSTALL = 0 TKDIR = $(_TKDIR) _TK_H = $(_TKDIR)\generic\tk.h !endif # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE) !endif # TKDIR !ifndef _TK_H MSG =^ Failed to find tk.h. The TKDIR macro is set incorrectly or is not set and default path does not contain tk.h. !error $(MSG) !endif !endif # NEED_TK !if $(NEED_TCL_SOURCE) && $(TCLINSTALL) MSG = ^ *** Warning: This extension requires the source distribution of Tcl.^ *** Please set the TCLDIR macro to point to the Tcl sources. !error $(MSG) !endif !if $(NEED_TK_SOURCE) !if $(TKINSTALL) MSG = ^ *** Warning: This extension requires the source distribution of Tk.^ *** Please set the TKDIR macro to point to the Tk sources. !error $(MSG) !endif !endif # If INSTALLDIR set to Tcl installation root dir then reset to the # lib dir for installing extensions !if exist("$(_INSTALLDIR)\include\tcl.h") _INSTALLDIR=$(_INSTALLDIR)\lib !endif # END Case 2(c) or (d) - Building an extension !endif # if $(DOING_TCL) ################################################################ # 3. Determine compiler version and architecture # In this section, we figure out the compiler version and the # architecture for which we are building. This sets the # following macros: # VCVERSION - the internal compiler version as 1200, 1400, 1910 etc. # This is also printed by the compiler in dotted form 19.10 etc. # VCVER - the "marketing version", for example Visual C++ 6 for internal # compiler version 1200. This is kept only for legacy reasons as it # does not make sense for recent Microsoft compilers. Only used for # output directory names. # ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target # NATIVE_ARCH - set to IX86 or AMD64 for the host machine # MACHINE - same as $(ARCH) - legacy # _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed cc32 = $(CC) # built-in default. link32 = link lib32 = lib rc32 = $(RC) # built-in default. #---------------------------------------------------------------- # Figure out the compiler architecture and version by writing # the C macros to a file, preprocessing them with the C # preprocessor and reading back the created file _HASH=^# _VC_MANIFEST_EMBED_EXE= _VC_MANIFEST_EMBED_DLL= VCVER=0 !if ![echo VCVERSION=_MSC_VER > vercl.x] \ && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \ && ![echo ARCH=IX86 >> vercl.x] \ && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \ && ![echo ARCH=AMD64 >> vercl.x] \ && ![echo $(_HASH)endif >> vercl.x] \ && ![$(cc32) -nologo -TC -P vercl.x 2>NUL] !include vercl.i !if $(VCVERSION) < 1900 !if ![echo VCVER= ^\> vercl.vc] \ && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc] !include vercl.vc !endif !else # The simple calculation above does not apply to new Visual Studio releases # Keep the compiler version in its native form. VCVER = $(VCVERSION) !endif !endif !if ![del 2>NUL /q/f vercl.x vercl.i vercl.vc] !endif #---------------------------------------------------------------- # The MACHINE macro is used by legacy makefiles so set it as well !ifdef MACHINE !if "$(MACHINE)" == "x86" !undef MACHINE MACHINE = IX86 !elseif "$(MACHINE)" == "x64" !undef MACHINE MACHINE = AMD64 !endif !if "$(MACHINE)" != "$(ARCH)" !error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH). !endif !else MACHINE=$(ARCH) !endif #--------------------------------------------------------------- # The PLATFORM_IDENTIFY macro matches the values returned by # the Tcl platform::identify command !if "$(MACHINE)" == "AMD64" PLATFORM_IDENTIFY = win32-x86_64 !else PLATFORM_IDENTIFY = win32-ix86 !endif # The MULTIPLATFORM macro controls whether binary extensions are installed # in platform-specific directories. Intended to be set/used by extensions. !ifndef MULTIPLATFORM_INSTALL MULTIPLATFORM_INSTALL = 0 !endif #------------------------------------------------------------ # Figure out the *host* architecture by reading the registry !if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86] NATIVE_ARCH=IX86 !else NATIVE_ARCH=AMD64 !endif # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !endif ################################################################ # 4. Build the nmakehlp program # This is a helper app we need to overcome nmake's limiting # environment. We will call out to it to get various bits of # information about supported compiler options etc. # # Tcl itself will always use the nmakehlp.c program which is # in its own source. It will be kept updated there. # # Extensions built against an installed Tcl will use the installed # copy of Tcl's nmakehlp.c if there is one and their own version # otherwise. In the latter case, they would also be using their own # rules.vc. Note that older versions of Tcl do not install nmakehlp.c # or rules.vc. # # Extensions built against Tcl sources will use the one from the Tcl source. # # When building an extension using a sufficiently new version of Tcl, # rules-ext.vc will define NMAKEHLPC appropriately to point to the # copy of nmakehlp.c to be used. !ifndef NMAKEHLPC # Default to the one in the current directory (the extension's own nmakehlp.c) NMAKEHLPC = nmakehlp.c !if !$(DOING_TCL) !if $(TCLINSTALL) !if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c !endif !else # !$(TCLINSTALL) !if exist("$(_TCLDIR)\win\nmakehlp.c") NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c !endif !endif # $(TCLINSTALL) !endif # !$(DOING_TCL) !endif # NMAKEHLPC # We always build nmakehlp even if it exists since we do not know # what source it was built from. !if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul] !endif ################################################################ # 5. Test for compiler features # Visual C++ compiler options have changed over the years. Check # which options are supported by the compiler in use. # # The following macros are set: # OPTIMIZATIONS - the compiler flags to be used for optimized builds # DEBUGFLAGS - the compiler flags to be used for debug builds # LINKERFLAGS - Flags passed to the linker # # Note that these are the compiler settings *available*, not those # that will be *used*. The latter depends on the OPTS macro settings # which we have not yet parsed. # # Also note that some of the flags in OPTIMIZATIONS are not really # related to optimization. They are placed there only for legacy reasons # as some extensions expect them to be included in that macro. # -Op improves float consistency. Note only needed for older compilers # Newer compilers do not need or support this option. !if [nmakehlp -c -Op] FPOPTS = -Op !endif # Strict floating point semantics - present in newer compilers in lieu of -Op !if [nmakehlp -c -fp:strict] FPOPTS = $(FPOPTS) -fp:strict !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' FPOPTS = $(FPOPTS) -QI0f !else !message *** Compiler does not have 'Pentium 0x0f fix' !endif !endif ### test for optimizations # /O2 optimization includes /Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy as per # documentation. Note we do NOT want /Gs as that inserts a _chkstk # stack probe at *every* function entry, not just those with more than # a page of stack allocation resulting in a performance hit. However, # /O2 documentation is misleading as its stack probes are simply the # default page size locals allocation probes and not what is implied # by an explicit /Gs option. OPTIMIZATIONS = $(FPOPTS) !if [nmakehlp -c -O2] OPTIMIZING = 1 OPTIMIZATIONS = $(OPTIMIZATIONS) -O2 !else # Legacy, really. All modern compilers support this !message *** Compiler does not have 'Optimizations' OPTIMIZING = 0 !endif # Checks for buffer overflows in local arrays !if [nmakehlp -c -GS] OPTIMIZATIONS = $(OPTIMIZATIONS) -GS !endif # Link time optimization. Note that this option (potentially) makes # generated libraries only usable by the specific VC++ version that # created it. Requires /LTCG linker option !if [nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -GL CC_GL_OPT_ENABLED = 1 !else # In newer compilers -GL and -YX are incompatible. !if [nmakehlp -c -YX] OPTIMIZATIONS = $(OPTIMIZATIONS) -YX !endif !endif # [nmakehlp -c -GL] DEBUGFLAGS = $(FPOPTS) # Run time error checks. Not available or valid in a release, non-debug build # RTC is for modern compilers, -GZ is legacy !if [nmakehlp -c -RTC1] DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 !elseif [nmakehlp -c -GZ] DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif #---------------------------------------------------------------- # Linker flags # LINKER_TESTFLAGS are for internal use when we call nmakehlp to test # if the linker supports a specific option. Without these flags link will # return "LNK1561: entry point must be defined" error compiling from VS-IDE: # They are not passed through to the actual application / extension # link rules. !ifndef LINKER_TESTFLAGS LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmakehlp.out !endif LINKERFLAGS = # If compiler has enabled link time optimization, linker must too with -ltcg !ifdef CC_GL_OPT_ENABLED !if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -ltcg !endif !endif ################################################################ # 6. Extract various version numbers from headers # For Tcl and Tk, version numbers are extracted from tcl.h and tk.h # respectively. For extensions, versions are extracted from the # configure.in or configure.ac from the TEA configuration if it # exists, and unset otherwise. # Sets the following macros: # TCL_MAJOR_VERSION # TCL_MINOR_VERSION # TCL_RELEASE_SERIAL # TCL_PATCH_LEVEL # TCL_PATCH_LETTER # TCL_VERSION # TK_MAJOR_VERSION # TK_MINOR_VERSION # TK_RELEASE_SERIAL # TK_PATCH_LEVEL # TK_PATCH_LETTER # TK_VERSION # DOTVERSION - set as (for example) 2.5 # VERSION - set as (for example 25) #-------------------------------------------------------------- !if [echo REM = This file is generated from rules.vc > versions.vc] !endif !if [echo TCL_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc] !endif !if [echo TCL_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc] !endif !if [echo TCL_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_RELEASE_SERIAL >> versions.vc] !endif !if [echo TCL_PATCH_LEVEL = \>> versions.vc] \ && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc] !endif !if defined(_TK_H) !if [echo TK_MAJOR_VERSION = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] !endif !if [echo TK_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] !endif !if [echo TK_RELEASE_SERIAL = \>> versions.vc] \ && [nmakehlp -V "$(_TK_H)" TK_RELEASE_SERIAL >> versions.vc] !endif !if [echo TK_PATCH_LEVEL = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc] !endif !endif # _TK_H !include versions.vc TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) !if [nmakehlp -f $(TCL_PATCH_LEVEL) "a"] TCL_PATCH_LETTER = a !elseif [nmakehlp -f $(TCL_PATCH_LEVEL) "b"] TCL_PATCH_LETTER = b !else TCL_PATCH_LETTER = . !endif !if defined(_TK_H) TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION) TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !if [nmakehlp -f $(TK_PATCH_LEVEL) "a"] TK_PATCH_LETTER = a !elseif [nmakehlp -f $(TK_PATCH_LEVEL) "b"] TK_PATCH_LETTER = b !else TK_PATCH_LETTER = . !endif !endif # Set DOTVERSION and VERSION !if $(DOING_TCL) DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_VERSION) !elseif $(DOING_TK) DOTVERSION = $(TK_DOTVERSION) VERSION = $(TK_VERSION) !else # Doing a non-Tk extension # If parent makefile has not defined DOTVERSION, try to get it from TEA # first from a configure.in file, and then from configure.ac !ifndef DOTVERSION !if [echo DOTVERSION = \> versions.vc] \ || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc] !if [echo DOTVERSION = \> versions.vc] \ || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc] !error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc. !endif !endif !include versions.vc !endif # DOTVERSION VERSION = $(DOTVERSION:.=) !endif # $(DOING_TCL) ... etc. # Windows RC files have 3 version components. Ensure this irrespective # of how many components the package has specified. Basically, ensure # minimum 4 components by appending 4 0's and then pick out the first 4. # Also take care of the fact that DOTVERSION may have "a" or "b" instead # of "." separating the version components. DOTSEPARATED=$(DOTVERSION:a=.) DOTSEPARATED=$(DOTSEPARATED:b=.) !if [echo RCCOMMAVERSION = \> versions.vc] \ || [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc] !error *** Could not generate RCCOMMAVERSION *** !endif !include versions.vc ######################################################################## # 7. Parse the OPTS macro to work out the requested build configuration. # Based on this, we will construct the actual switches to be passed to the # compiler and linker using the macros defined in the previous section. # The following macros are defined by this section based on OPTS # STATIC_BUILD - 0 -> Tcl is to be built as a shared library # 1 -> build as a static library and shell # TCL_THREADS - legacy but always 1 on Windows since winsock requires it. # DEBUG - 1 -> debug build, 0 -> release builds # SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's # PROFILE - 1 -> generate profiling info, 0 -> no profiling # PGO - 1 -> profile based optimization, 0 -> no # MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build # 0 -> link to static C runtime for static Tcl build. # Does not impact shared Tcl builds (STATIC_BUILD == 0) # Default: 1 for Tcl 8.7 and up, 0 otherwise. # TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions # in the Tcl and Wish shell. 0 -> keep them as shared libraries. Does # not impact shared Tcl builds. Implied by STATIC_BUILD since Tcl 8.7. # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) # TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. # (Not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 MSVCRT = 1 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 1 UNCHECKED = 0 CONFIG_CHECK = 1 !if $(DOING_TCL) USE_STUBS = 0 !else USE_STUBS = 1 !endif # If OPTS is not empty AND does not contain "none" which turns off all OPTS # set the above macros based on OPTS content !if "$(OPTS)" != "" && ![nmakehlp -f "$(OPTS)" "none"] # OPTS are specified, parse them !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 !endif !if [nmakehlp -f $(OPTS) "nostubs"] !message *** Not using stubs USE_STUBS = 0 !endif !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !if $(TCL_MAJOR_VERSION) == 8 && $(TCL_MINOR_VERSION) < 7 && $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !if [nmakehlp -f $(OPTS) "utfmax"] !message *** Force allowing 4-byte UTF-8 sequences internally TCL_UTF_MAX = 4 !endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 !else DEBUG = 0 !endif !if [nmakehlp -f $(OPTS) "pdbs"] !message *** Doing pdbs SYMBOLS = 1 !else SYMBOLS = 0 !endif !if [nmakehlp -f $(OPTS) "profile"] !message *** Doing profile PROFILE = 1 !else PROFILE = 0 !endif !if [nmakehlp -f $(OPTS) "pgi"] !message *** Doing profile guided optimization instrumentation PGO = 1 !elseif [nmakehlp -f $(OPTS) "pgo"] !message *** Doing profile guided optimization PGO = 2 !else PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif # TBD - should get rid of this option !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !if [nmakehlp -f $(OPTS) "noconfigcheck"] CONFIG_CHECK = 1 !else CONFIG_CHECK = 0 !endif !endif # "$(OPTS)" != "" && ... parsing of OPTS # Set linker flags based on above !if $(PGO) > 1 !if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize !else MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !elseif $(PGO) > 0 !if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument !else MSG=^ This compiler does not support profile guided optimization. !error $(MSG) !endif !endif ################################################################ # 8. Parse the STATS macro to configure code instrumentation # The following macros are set by this section: # TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation # 0 -> disables # TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging # 0 -> disables # Default both are off TCL_MEM_DEBUG = 0 TCL_COMPILE_DEBUG = 0 !if "$(STATS)" != "" && ![nmakehlp -f "$(STATS)" "none"] !if [nmakehlp -f $(STATS) "memdbg"] !message *** Doing memdbg TCL_MEM_DEBUG = 1 !else TCL_MEM_DEBUG = 0 !endif !if [nmakehlp -f $(STATS) "compdbg"] !message *** Doing compdbg TCL_COMPILE_DEBUG = 1 !else TCL_COMPILE_DEBUG = 0 !endif !endif #################################################################### # 9. Parse the CHECKS macro to configure additional compiler checks # The following macros are set by this section: # WARNINGS - compiler switches that control the warnings level # TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions # 0 -> enable deprecated functions # Defaults - Permit deprecated functions and warning level 3 TCL_NO_DEPRECATED = 0 WARNINGS = -W3 !if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"] !if [nmakehlp -f $(CHECKS) "nodep"] !message *** Doing nodep check TCL_NO_DEPRECATED = 1 !endif !if [nmakehlp -f $(CHECKS) "fullwarn"] !message *** Doing full warnings check WARNINGS = -W4 !if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)] LINKERFLAGS = $(LINKERFLAGS) -warn:3 !endif !endif !if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64] !message *** Doing 64bit portability warnings WARNINGS = $(WARNINGS) -Wp64 !endif !endif ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # # Naming convention (suffixes): # t = full thread support. (Not used for Tcl >= 8.7) # s = static library (as opposed to an import library) # g = linked to the debug enabled C run-time. # x = special static build when it links to the dynamic C run-time. # # The following macros are set in this section: # SUFX - the suffix to use for binaries based on above naming convention # BUILDDIRTOP - the toplevel default output directory # is of the form {Release,Debug}[_AMD64][_COMPILERVERSION] # TMP_DIR - directory where object files are created # OUT_DIR - directory where output executables are created # Both TMP_DIR and OUT_DIR are defaulted only if not defined by the # parent makefile (or command line). The default values are # based on BUILDDIRTOP. # STUBPREFIX - name of the stubs library for this project # PRJIMPLIB - output path of the generated project import library # PRJLIBNAME - name of generated project library # PRJLIB - output path of generated project library # PRJSTUBLIBNAME - name of the generated project stubs library # PRJSTUBLIB - output path of the generated project stubs library # RESFILE - output resource file (only if not static build) SUFX = tsgx !if $(DEBUG) BUILDDIRTOP = Debug !else BUILDDIRTOP = Release !endif !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif !if !$(DEBUG) || $(TCL_VERSION) > 86 || $(DEBUG) && $(UNCHECKED) SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !else TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=) EXT = lib !if !$(MSVCRT) TMP_DIRFULL = $(TMP_DIRFULL:X=) SUFX = $(SUFX:x=) !endif !endif !if !$(TCL_THREADS) || $(TCL_VERSION) > 86 TMP_DIRFULL = $(TMP_DIRFULL:Threaded=) SUFX = $(SUFX:t=) !endif !ifndef TMP_DIR TMP_DIR = $(TMP_DIRFULL) !ifndef OUT_DIR OUT_DIR = .\$(BUILDDIRTOP) !endif !else !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif # Relative paths -> absolute !if [echo OUT_DIR = \> nmakehlp.out] \ || [nmakehlp -Q "$(OUT_DIR)" >> nmakehlp.out] !error *** Could not fully qualify path OUT_DIR=$(OUT_DIR) !endif !if [echo TMP_DIR = \>> nmakehlp.out] \ || [nmakehlp -Q "$(TMP_DIR)" >> nmakehlp.out] !error *** Could not fully qualify path TMP_DIR=$(TMP_DIR) !endif !include nmakehlp.out # The name of the stubs library for the project being built STUBPREFIX = $(PROJECT)stub # # Set up paths to various Tcl executables and libraries needed by extensions # # TIP 430. Unused for 8.6 but no harm defining it to allow a common rules.vc TCLSCRIPTZIPNAME = libtcl$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)$(TCL_PATCH_LETTER)$(TCL_RELEASE_SERIAL).zip TKSCRIPTZIPNAME = libtk$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)$(TK_PATCH_LETTER)$(TK_RELEASE_SERIAL).zip !if $(DOING_TCL) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist("$(TCLSH)") TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib TCLSCRIPTZIP = $(_TCLDIR)\lib\$(TCLSCRIPTZIPNAME) TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" !else # Building against Tcl sources TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TCLIMPLIB)") TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)t$(SUFX:t=).lib !endif TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib TCLSCRIPTZIP = $(_TCLDIR)\win\$(BUILDDIRTOP)\$(TCLSCRIPTZIPNAME) TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif # TCLINSTALL tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" !endif # $(DOING_TCL) # We need a tclsh that will run on the host machine as part of the build. # IX86 runs on all architectures. !ifndef TCLSH_NATIVE !if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)" TCLSH_NATIVE = $(TCLSH) !else !error You must explicitly set TCLSH_NATIVE for cross-compilation !endif !endif # Do the same for Tk and Tk extensions that require the Tk libraries !if $(DOING_TK) || $(NEED_TK) WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !else TKLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tcl9tk$(TK_VERSION)$(SUFX).lib !endif TKSTUBLIBNAME = tkstub$(TK_VERSION).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" TKSCRIPTZIP = $(OUT_DIR)\$(TKSCRIPTZIPNAME) !else # effectively NEED_TK !if $(TKINSTALL) # Building against installed Tk WISH = $(_TKDIR)\bin\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) # When building extensions, may be linking against Tk that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TKIMPLIB)") TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\include" TKSCRIPTZIP = $(_TKDIR)\lib\$(TKSCRIPTZIPNAME) !else # Building against Tk sources WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) # When building extensions, may be linking against Tk that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. !if !exist("$(TKIMPLIB)") TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME) !endif TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib" TKSCRIPTZIP = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSCRIPTZIPNAME) !endif # TKINSTALL tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) !if $(TCL_MAJOR_VERSION) == 8 PRJLIBNAME = $(PRJLIBNAME8) !else PRJLIBNAME = $(PRJLIBNAME9) !endif PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, # we will generate one from standard template. !if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD) !ifdef RCFILE RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res) !else RESFILE = $(TMP_DIR)\$(PROJECT).res !endif !endif ################################################################### # 11. Construct the paths for the installation directories # The following macros get defined in this section: # LIB_INSTALL_DIR - where libraries should be installed # BIN_INSTALL_DIR - where the executables should be installed # DOC_INSTALL_DIR - where documentation should be installed # SCRIPT_INSTALL_DIR - where scripts should be installed # INCLUDE_INSTALL_DIR - where C include files should be installed # DEMO_INSTALL_DIR - where demos should be installed # PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk) !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION) !if $(MULTIPLATFORM_INSTALL) LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)\$(PLATFORM_IDENTIFY) !else LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR) BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR) !endif DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR) SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR) DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include !endif ################################################################### # 12. Set up actual options to be passed to the compiler and linker # Now we have all the information we need, set up the actual flags and # options that we will pass to the compiler and linker. The main # makefile should use these in combination with whatever other flags # and switches are specific to it. # The following macros are defined, names are for historical compatibility: # OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS # COMPILERFLAGS - /Dxxx C macro flags independent of any configuration opttions # crt - Compiler switch that selects the appropriate C runtime # cdebug - Compiler switches related to debug AND optimizations # cwarn - Compiler switches that set warning levels # cflags - complete compiler switches (subsumes cdebug and cwarn) # ldebug - Linker switches controlling debug information and optimization # lflags - complete linker switches (subsumes ldebug) except subsystem type # dlllflags - complete linker switches to build DLLs (subsumes lflags) # conlflags - complete linker switches for console program (subsumes lflags) # guilflags - complete linker switches for GUI program (subsumes lflags) # baselibs - minimum Windows libraries required. Parent makefile can # define PRJ_LIBS before including rules.rc if additional libs are needed OPTDEFINES = /DSTDC_HEADERS /DUSE_NMAKE=1 !if $(VCVERSION) > 1600 OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1 !else OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1 !endif !if $(VCVERSION) >= 1800 OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1 !endif !if $(TCL_MEM_DEBUG) OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG !endif !if $(TCL_COMPILE_DEBUG) OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS !endif !if $(TCL_THREADS) && $(TCL_VERSION) < 87 OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1 !if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87 OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1 !endif !endif !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD !elseif $(TCL_VERSION) > 86 OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH !if "$(MACHINE)" == "AMD64" OPTDEFINES = $(OPTDEFINES) /DMP_64BIT !endif !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED !endif !if $(USE_STUBS) # Note we do not define USE_TCL_STUBS even when building tk since some # test targets in tk do not use stubs !if !$(DOING_TCL) USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS !if $(NEED_TK) USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS !endif !endif !endif # USE_STUBS !if !$(DEBUG) OPTDEFINES = $(OPTDEFINES) /DNDEBUG !if $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED !endif !if "$(MACHINE)" == "AMD64" OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif !if "$(TCL_MAJOR_VERSION)" == "8" !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif !if "$(TCL_UTF_MAX)" == "4" OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4 !endif # _ATL_XP_TARGETING - Newer SDK's need this to build for XP COMPILERFLAGS = /D_ATL_XP_TARGETING !endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME # so we pass both !if !$(DOING_TCL) && !$(DOING_TK) PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \ /DPACKAGE_VERSION="\"$(DOTVERSION)\"" \ /DMODULE_SCOPE=extern !endif # crt picks the C run time based on selected OPTS !if $(MSVCRT) !if $(DEBUG) && !$(UNCHECKED) crt = -MDd !else crt = -MD !endif !else !if $(DEBUG) && !$(UNCHECKED) crt = -MTd !else crt = -MT !endif !endif # cdebug includes compiler options for debugging as well as optimization. !if $(DEBUG) # In debugging mode, optimizations need to be disabled cdebug = -Zi -Od $(DEBUGFLAGS) !else cdebug = $(OPTIMIZATIONS) !if $(SYMBOLS) cdebug = $(cdebug) -Zi !endif !endif # $(DEBUG) # cwarn includes default warning levels. cwarn = $(WARNINGS) !if "$(MACHINE)" == "AMD64" # Disable pointer<->int warnings related to cast between different sizes # There are a gadzillion of these due to use of ClientData and # clutter up compiler # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif !if $(DEBUG) # Turn warnings into errors cwarn = $(cwarn) -WX !endif INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform # rules.vc/makefile.vc to help visually compare that the pre- and # post-reform build logs # cflags contains generic flags used for building practically all object files cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) # appcflags contains $(cflags) and flags for building the application # object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus # flags used for building shared object files The two differ in the # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs # library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) /Zl /GL- /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 !if $(SYMBOLS) ldebug = $(ldebug) -debug -debugtype:cv !endif !endif # Note: Profiling is currently only possible with the Visual Studio Enterprise !if $(PROFILE) ldebug= $(ldebug) -profile !endif ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows # Libraries that are required for every image. # Extensions should define any additional libraries with $(PRJ_LIBS) winlibs = kernel32.lib advapi32.lib !if $(NEED_TK) winlibs = $(winlibs) gdi32.lib user32.lib uxtheme.lib !endif # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "AMD64" !if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 winlibs = $(winlibs) bufferoverflowU.lib !endif !endif baselibs = $(winlibs) $(PRJ_LIBS) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 baselibs = $(baselibs) ucrt.lib !endif ################################################################ # 13. Define standard commands, common make targets and implicit rules CCPKGCMD = $(cc32) $(pkgcflags) -Fo$(TMP_DIR)^\ CCAPPCMD = $(cc32) $(appcflags) -Fo$(TMP_DIR)^\ CCSTUBSCMD = $(cc32) $(stubscflags) -Fo$(TMP_DIR)^\ LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ /DCOMMAVERSION=$(RCCOMMAVERSION) \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif default-target: $(DEFAULT_BUILD_TARGET) !if $(MULTIPLATFORM_INSTALL) default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PLATFORM_IDENTIFY) $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } >> $(OUT_DIR)\pkgIndex.tcl !else default-pkgindex: @echo if {[package vsatisfies [package provide Tcl] 9.0-]} { > $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME9)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } else { >> $(OUT_DIR)\pkgIndex.tcl @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \ [list load [file join $$dir $(PRJLIBNAME8)]] >> $(OUT_DIR)\pkgIndex.tcl @echo } >> $(OUT_DIR)\pkgIndex.tcl !endif default-pkgindex-tea: @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl @PACKAGE_VERSION@ $(DOTVERSION) @PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME) @PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME) @PKG_LIB_FILE@ $(PRJLIBNAME) @PKG_LIB_FILE8@ $(PRJLIBNAME8) @PKG_LIB_FILE9@ $(PRJLIBNAME9) << default-install: default-install-binaries default-install-libraries !if $(SYMBOLS) default-install: default-install-pdbs !endif # Again to deal with historical brokenness, there is some confusion # in terminlogy. For extensions, the "install-binaries" was used to # locate target directory for *binary shared libraries* and thus # the appropriate macro is LIB_INSTALL_DIR since BIN_INSTALL_DIR is # for executables (exes). On the other hand the "install-libraries" # target is for *scripts* and should have been called "install-scripts". default-install-binaries: $(PRJLIB) @echo Installing binaries to '$(LIB_INSTALL_DIR)' @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" @$(CPY) $(PRJLIB) "$(LIB_INSTALL_DIR)" >NUL # Alias for default-install-scripts default-install-libraries: default-install-scripts default-install-scripts: $(OUT_DIR)\pkgIndex.tcl @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)' @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" @echo Installing package index in '$(SCRIPT_INSTALL_DIR)' @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR) default-install-stubs: @echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)' @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)" @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL default-install-pdbs: @echo Installing PDBs to '$(LIB_INSTALL_DIR)' @if not exist "$(LIB_INSTALL_DIR)" mkdir "$(LIB_INSTALL_DIR)" @$(CPY) "$(OUT_DIR)\*.pdb" "$(LIB_INSTALL_DIR)\" # "emacs font-lock highlighting fix default-install-docs-html: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)" default-install-docs-n: @echo Installing documentation files to '$(DOC_INSTALL_DIR)' @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)" @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.n") do @$(COPY) %f "$(DOC_INSTALL_DIR)" default-install-demos: @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt @echo Cleaning $(WIN_DIR)\_junk.pch ... @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) # Only for backward compatibility default-distclean: default-hose default-setup: @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) !if "$(TESTPAT)" != "" TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) !endif default-test: default-setup $(PROJECT) @set TCLLIBPATH=$(OUT_DIR:\=/) @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" cd "$(TESTDIR)" && $(DEBUGGER) $(TCLSH) all.tcl $(TESTFLAGS) default-shell: default-setup $(PROJECT) @set TCLLIBPATH=$(OUT_DIR:\=/) @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)" $(DEBUGGER) $(TCLSH) # Generation of Windows version resource !ifdef RCFILE # Note: don't use $** in below rule because there may be other dependencies # and only the "main" rc must be passed to the resource compiler $(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc $(RESCMD) $(RCDIR)\$(PROJECT).rc !else # If parent makefile has not defined a resource definition file, # we will generate one from standard template. $(TMP_DIR)\$(PROJECT).res: $(TMP_DIR)\$(PROJECT).rc $(TMP_DIR)\$(PROJECT).rc: @$(COPY) << $(TMP_DIR)\$(PROJECT).rc #include VS_VERSION_INFO VERSIONINFO FILEVERSION COMMAVERSION PRODUCTVERSION COMMAVERSION FILEFLAGSMASK 0x3fL #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS_NT_WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Tcl extension " PROJECT VALUE "OriginalFilename", PRJLIBNAME VALUE "FileVersion", DOTVERSION VALUE "ProductName", "Package " PROJECT " for Tcl" VALUE "ProductVersion", DOTVERSION END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END << !endif # ifdef RCFILE !ifndef DISABLE_IMPLICIT_RULES DISABLE_IMPLICIT_RULES = 0 !endif !if !$(DISABLE_IMPLICIT_RULES) # Implicit rule definitions - only for building library objects. For stubs and # main application, the makefile should define explicit rules. {$(ROOT)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(WIN_DIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(GENERICDIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(COMPATDIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << {$(RCDIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(WIN_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< {$(TMP_DIR)}.rc{$(TMP_DIR)}.res: $(RESCMD) $< .SUFFIXES: .SUFFIXES:.c .rc !endif ################################################################ # 14. Sanity check selected options against Tcl build options # When building an extension, certain configuration options should # match the ones used when Tcl was built. Here we check and # warn on a mismatch. !if !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl !if exist("$(_TCLDIR)\lib\nmake\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake" !endif !else # !$(TCLINSTALL) - building against Tcl source !if exist("$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake") TCLNMAKECONFIG = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl.nmake" !endif !endif # TCLINSTALL !if $(CONFIG_CHECK) !ifdef TCLNMAKECONFIG !include $(TCLNMAKECONFIG) !if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)" !error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)). !endif !if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC) !message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)). !endif !if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG) !message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)). !endif !endif !endif # TCLNMAKECONFIG !endif # !$(DOING_TCL) #---------------------------------------------------------- # Display stats being used. #---------------------------------------------------------- !if !$(DOING_TCL) !message *** Building against Tcl at '$(_TCLDIR)' !endif !if !$(DOING_TK) && $(NEED_TK) !message *** Building against Tk at '$(_TKDIR)' !endif !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' !message *** Installation, if selected, will be in '$(_INSTALLDIR)' !message *** Suffix for binaries will be '$(SUFX)' !message *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH). !endif # ifdef _RULES_VC itcl4.2.2/win/rules-ext.vc0000644003604700454610000000732414137636151014064 0ustar dgp771div# This file should only be included in makefiles for Tcl extensions, # NOT in the makefile for Tcl itself. !ifndef _RULES_EXT_VC # We need to run from the directory the parent makefile is located in. # nmake does not tell us what makefile was used to invoke it so parent # makefile has to set the MAKEFILEVC macro or we just make a guess and # warn if we think that is not the case. !if "$(MAKEFILEVC)" == "" !if exist("$(PROJECT).vc") MAKEFILEVC = $(PROJECT).vc !elseif exist("makefile.vc") MAKEFILEVC = makefile.vc !endif !endif # "$(MAKEFILEVC)" == "" !if !exist("$(MAKEFILEVC)") MSG = ^ You must run nmake from the directory containing the project makefile.^ If you are doing that and getting this message, set the MAKEFILEVC^ macro to the name of the project makefile. !message WARNING: $(MSG) !endif !if "$(PROJECT)" == "tcl" !error The rules-ext.vc file is not intended for Tcl itself. !endif # We extract version numbers using the nmakehlp program. For now use # the local copy of nmakehlp. Once we locate Tcl, we will use that # one if it is newer. !if [$(CC) -nologo -DNDEBUG "nmakehlp.c" -link -subsystem:console > nul] !endif # First locate the Tcl directory that we are working with. !if "$(TCLDIR)" != "" _RULESDIR = $(TCLDIR:/=\) !else # If an installation path is specified, that is also the Tcl directory. # Also Tk never builds against an installed Tcl, it needs Tcl sources !if defined(INSTALLDIR) && "$(PROJECT)" != "tk" _RULESDIR=$(INSTALLDIR:/=\) !else # Locate Tcl sources !if [echo _RULESDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] _RULESDIR = ..\..\tcl !else !include nmakehlp.out !endif !endif # defined(INSTALLDIR).... !endif # ifndef TCLDIR # Now look for the targets.vc file under the Tcl root. Note we check this # file and not rules.vc because the latter also exists on older systems. !if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl _RULESDIR = $(_RULESDIR)\lib\nmake !elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources _RULESDIR = $(_RULESDIR)\win !else # If we have not located Tcl's targets file, most likely we are compiling # against an older version of Tcl and so must use our own support files. _RULESDIR = . !endif !if "$(_RULESDIR)" != "." # Potentially using Tcl's support files. If this extension has its own # nmake support files, need to compare the versions and pick newer. !if exist("rules.vc") # The extension has its own copy !if [echo TCL_RULES_MAJOR = \> versions.vc] \ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc] !endif !if [echo TCL_RULES_MINOR = \>> versions.vc] \ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc] !endif !if [echo OUR_RULES_MAJOR = \>> versions.vc] \ && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc] !endif !if [echo OUR_RULES_MINOR = \>> versions.vc] \ && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc] !endif !include versions.vc # We have a newer version of the support files, use them !if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR)) _RULESDIR = . !endif !endif # if exist("rules.vc") !endif # if $(_RULESDIR) != "." # Let rules.vc know what copy of nmakehlp.c to use. NMAKEHLPC = $(_RULESDIR)\nmakehlp.c # Get rid of our internal defines before calling rules.vc !undef TCL_RULES_MAJOR !undef TCL_RULES_MINOR !undef OUR_RULES_MAJOR !undef OUR_RULES_MINOR !if exist("$(_RULESDIR)\rules.vc") !message *** Using $(_RULESDIR)\rules.vc !include "$(_RULESDIR)\rules.vc" !else !error *** Could not locate rules.vc in $(_RULESDIR) !endif !endif # _RULES_EXT_VCitcl4.2.2/win/nmakehlp.c0000644003604700454610000005120514137636232013542 0ustar dgp771div/* * ---------------------------------------------------------------------------- * nmakehlp.c -- * * This is used to fix limitations within nmake and the environment. * * Copyright (c) 2002 by David Gravereaux. * Copyright (c) 2006 by Pat Thoyts * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include #ifdef _MSC_VER #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #endif #include #include /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) #if _MSC_VER >= 1400 && _MSC_VER < 1500 #pragma comment(lib, "bufferoverflowU") #endif #endif /* ISO hack for dumb VC++ */ #ifdef _MSC_VER #define snprintf _snprintf #endif /* protos */ static int CheckForCompilerFeature(const char *option); static int CheckForLinkerFeature(char **options, int count); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); static int LocateDependency(const char *keyfile); static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ #define CHUNK 25 #define STATICBUFFERSIZE 1000 typedef struct { HANDLE pipe; char buffer[STATICBUFFERSIZE]; } pipeinfo; pipeinfo Out = {INVALID_HANDLE_VALUE, ""}; pipeinfo Err = {INVALID_HANDLE_VALUE, ""}; /* * exitcodes: 0 == no, 1 == yes, 2 == error */ int main( int argc, char *argv[]) { char msg[300]; DWORD dwWritten; int chars; const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. */ SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX); /* * Make sure the compiler and linker aren't effected by the outside world. */ SetEnvironmentVariable("CL", ""); SetEnvironmentVariable("LINK", ""); if (argc > 1 && *argv[1] == '-') { switch (*(argv[1]+1)) { case 'c': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c \n" "Tests for whether cl.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForCompilerFeature(argv[2]); case 'l': if (argc < 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -l ? ...?\n" "Tests for whether link.exe supports an option\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return CheckForLinkerFeature(&argv[2], argc-2); case 'f': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -f \n" "Find a substring within another\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } else if (argc == 3) { /* * If the string is blank, there is no match. */ return 0; } else { return IsIn(argv[2], argv[3]); } case 's': if (argc == 2) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -s \n" "Perform a set of string map type substutitions on a file\n" "exitcodes: 0\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return SubstituteFile(argv[2], argv[3]); case 'V': if (argc != 4) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -V filename matchstring\n" "Extract a version from a file:\n" "eg: pkgIndex.tcl \"package ifneeded http\"", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 0; } s = GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0'); if (s && *s) { printf("%s\n", s); return 0; } else return 1; /* Version not found. Return non-0 exit code */ case 'Q': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -Q path\n" "Emit the fully qualified path\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return QualifyPath(argv[2]); case 'L': if (argc != 3) { chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -L keypath\n" "Emit the fully qualified path of directory containing keypath\n" "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return LocateDependency(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, "usage: %s -c|-f|-l|-Q|-s|-V ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } static int CheckForCompilerFeature( const char *option) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; char cmdline[100]; hProcess = GetCurrentProcess(); ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = FALSE; /* * Create a non-inheritible pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritible, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch "); /* * Append our option for testing */ lstrcat(cmdline, option); /* * Filename to compile, which exists, but is nothing and empty. */ lstrcat(cmdline, " .\\nul"); ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in both streams. * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. */ return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL || strstr(Out.buffer, "D9002") != NULL || strstr(Err.buffer, "D9002") != NULL || strstr(Out.buffer, "D2021") != NULL || strstr(Err.buffer, "D2021") != NULL); } static int CheckForLinkerFeature( char **options, int count) { STARTUPINFO si; PROCESS_INFORMATION pi; SECURITY_ATTRIBUTES sa; DWORD threadID; char msg[300]; BOOL ok; HANDLE hProcess, h, pipeThreads[2]; int i; char cmdline[255]; hProcess = GetCurrentProcess(); ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.dwFlags = STARTF_USESTDHANDLES; si.hStdInput = INVALID_HANDLE_VALUE; ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); sa.nLength = sizeof(SECURITY_ATTRIBUTES); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; /* * Create a non-inheritible pipe. */ CreatePipe(&Out.pipe, &h, &sa, 0); /* * Dupe the write side, make it inheritible, and close the original. */ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Same as above, but for the error side. */ CreatePipe(&Err.pipe, &h, &sa, 0); DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); /* * Base command line. */ lstrcpy(cmdline, "link.exe -nologo "); /* * Append our option for testing. */ for (i = 0; i < count; i++) { lstrcat(cmdline, " \""); lstrcat(cmdline, options[i]); lstrcat(cmdline, "\""); } ok = CreateProcess( NULL, /* Module name. */ cmdline, /* Command line. */ NULL, /* Process handle not inheritable. */ NULL, /* Thread handle not inheritable. */ TRUE, /* yes, inherit handles. */ DETACHED_PROCESS, /* No console for you. */ NULL, /* Use parent's environment block. */ NULL, /* Use parent's starting directory. */ &si, /* Pointer to STARTUPINFO structure. */ &pi); /* Pointer to PROCESS_INFORMATION structure. */ if (!ok) { DWORD err = GetLastError(); int chars = snprintf(msg, sizeof(msg) - 1, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPSTR)&msg[chars], (300-chars), 0); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } /* * Close our references to the write handles that have now been inherited. */ CloseHandle(si.hStdOutput); CloseHandle(si.hStdError); WaitForInputIdle(pi.hProcess, 5000); CloseHandle(pi.hThread); /* * Start the pipe reader threads. */ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); /* * Block waiting for the process to end. */ WaitForSingleObject(pi.hProcess, INFINITE); CloseHandle(pi.hProcess); /* * Wait for our pipe to get done reading, should it be a little slow. */ WaitForMultipleObjects(2, pipeThreads, TRUE, 500); CloseHandle(pipeThreads[0]); CloseHandle(pipeThreads[1]); /* * Look for the commandline warning code in the stderr stream. */ return !(strstr(Out.buffer, "LNK1117") != NULL || strstr(Err.buffer, "LNK1117") != NULL || strstr(Out.buffer, "LNK4044") != NULL || strstr(Err.buffer, "LNK4044") != NULL || strstr(Out.buffer, "LNK4224") != NULL || strstr(Err.buffer, "LNK4224") != NULL); } static DWORD WINAPI ReadFromPipe( LPVOID args) { pipeinfo *pi = (pipeinfo *) args; char *lastBuf = pi->buffer; DWORD dwRead; BOOL ok; again: if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) { CloseHandle(pi->pipe); return (DWORD)-1; } ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L); if (!ok || dwRead == 0) { CloseHandle(pi->pipe); return 0; } lastBuf += dwRead; goto again; return 0; /* makes the compiler happy */ } static int IsIn( const char *string, const char *substring) { return (strstr(string, substring) != NULL); } /* * GetVersionFromFile -- * Looks for a match string in a file and then returns the version * following the match where a version is anything acceptable to * package provide or package ifneeded. */ static const char * GetVersionFromFile( const char *filename, const char *match, int numdots) { static char szBuffer[100]; char *szResult = NULL; FILE *fp = fopen(filename, "rt"); if (fp != NULL) { /* * Read data until we see our match string. */ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) { LPSTR p, q; p = strstr(szBuffer, match); if (p != NULL) { /* * Skip to first digit after the match. */ p += strlen(match); while (*p && !isdigit((unsigned char)*p)) { ++p; } /* * Find ending whitespace. */ q = p; while (*q && (strchr("0123456789.ab", *q)) && (((!strchr(".ab", *q) && !strchr("ab", q[-1])) || --numdots))) { ++q; } *q = 0; szResult = p; break; } } fclose(fp); } return szResult; } /* * List helpers for the SubstituteFile function */ typedef struct list_item_t { struct list_item_t *nextPtr; char * key; char * value; } list_item_t; /* insert a list item into the list (list may be null) */ static list_item_t * list_insert(list_item_t **listPtrPtr, const char *key, const char *value) { list_item_t *itemPtr = (list_item_t *)malloc(sizeof(list_item_t)); if (itemPtr) { itemPtr->key = strdup(key); itemPtr->value = strdup(value); itemPtr->nextPtr = NULL; while(*listPtrPtr) { listPtrPtr = &(*listPtrPtr)->nextPtr; } *listPtrPtr = itemPtr; } return itemPtr; } static void list_free(list_item_t **listPtrPtr) { list_item_t *tmpPtr, *listPtr = *listPtrPtr; while (listPtr) { tmpPtr = listPtr; listPtr = listPtr->nextPtr; free(tmpPtr->key); free(tmpPtr->value); free(tmpPtr); } } /* * SubstituteFile -- * As windows doesn't provide anything useful like sed and it's unreliable * to use the tclsh you are building against (consider x-platform builds - * eg compiling AMD64 target from IX86) we provide a simple substitution * option here to handle autoconf style substitutions. * The substitution file is whitespace and line delimited. The file should * consist of lines matching the regular expression: * \s*\S+\s+\S*$ * * Usage is something like: * nmakehlp -S << $** > $@ * @PACKAGE_NAME@ $(PACKAGE_NAME) * @PACKAGE_VERSION@ $(PACKAGE_VERSION) * << */ static int SubstituteFile( const char *substitutions, const char *filename) { static char szBuffer[1024], szCopy[1024]; list_item_t *substPtr = NULL; FILE *fp, *sp; fp = fopen(filename, "rt"); if (fp != NULL) { /* * Build a list of substutitions from the first filename */ sp = fopen(substitutions, "rt"); if (sp != NULL) { while (fgets(szBuffer, sizeof(szBuffer), sp) != NULL) { unsigned char *ks, *ke, *vs, *ve; ks = (unsigned char*)szBuffer; while (ks && *ks && isspace(*ks)) ++ks; ke = ks; while (ke && *ke && !isspace(*ke)) ++ke; vs = ke; while (vs && *vs && isspace(*vs)) ++vs; ve = vs; while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve; *ke = 0, *ve = 0; list_insert(&substPtr, (char*)ks, (char*)vs); } fclose(sp); } /* debug: dump the list */ #ifndef NDEBUG { int n = 0; list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr, ++n) { fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value); } } #endif /* * Run the substitutions over each line of the input */ while (fgets(szBuffer, sizeof(szBuffer), fp) != NULL) { list_item_t *p = NULL; for (p = substPtr; p != NULL; p = p->nextPtr) { char *m = strstr(szBuffer, p->key); if (m) { char *cp, *op, *sp; cp = szCopy; op = szBuffer; while (op != m) *cp++ = *op++; sp = p->value; while (sp && *sp) *cp++ = *sp++; op += strlen(p->key); while (*op) *cp++ = *op++; *cp = 0; memcpy(szBuffer, szCopy, sizeof(szCopy)); } } printf("%s", szBuffer); } list_free(&substPtr); } fclose(fp); return 0; } BOOL FileExists(LPCTSTR szPath) { #ifndef INVALID_FILE_ATTRIBUTES #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif DWORD pathAttr = GetFileAttributes(szPath); return (pathAttr != INVALID_FILE_ATTRIBUTES && !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); } /* * QualifyPath -- * * This composes the current working directory with a provided path * and returns the fully qualified and normalized path. * Mostly needed to setup paths for testing. */ static int QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } /* * Implements LocateDependency for a single directory. See that command * for an explanation. * Returns 0 if found after printing the directory. * Returns 1 if not found but no errors. * Returns 2 on any kind of error * Basically, these are used as exit codes for the process. */ static int LocateDependencyHelper(const char *dir, const char *keypath) { HANDLE hSearch; char path[MAX_PATH+1]; size_t dirlen; int keylen, ret; WIN32_FIND_DATA finfo; if (dir == NULL || keypath == NULL) return 2; /* Have no real error reporting mechanism into nmake */ dirlen = strlen(dir); if ((dirlen + 3) > sizeof(path)) return 2; strncpy(path, dir, dirlen); strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ keylen = strlen(keypath); #if 0 /* This function is not available in Visual C++ 6 */ /* * Use numerics 0 -> FindExInfoStandard, * 1 -> FindExSearchLimitToDirectories, * as these are not defined in Visual C++ 6 */ hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); #else hSearch = FindFirstFile(path, &finfo); #endif if (hSearch == INVALID_HANDLE_VALUE) return 1; /* Not found */ /* Loop through all subdirs checking if the keypath is under there */ ret = 1; /* Assume not found */ do { int sublen; /* * We need to check it is a directory despite the * FindExSearchLimitToDirectories in the above call. See SDK docs */ if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) continue; sublen = strlen(finfo.cFileName); if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) continue; /* Path does not fit, assume not matched */ strncpy(path+dirlen+1, finfo.cFileName, sublen); path[dirlen+1+sublen] = '\\'; strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); if (FileExists(path)) { /* Found a match, print to stdout */ path[dirlen+1+sublen] = '\0'; QualifyPath(path); ret = 0; break; } } while (FindNextFile(hSearch, &finfo)); FindClose(hSearch); return ret; } /* * LocateDependency -- * * Locates a dependency for a package. * keypath - a relative path within the package directory * that is used to confirm it is the correct directory. * The search path for the package directory is currently only * the parent and grandparent of the current working directory. * If found, the command prints * name_DIRPATH= * and returns 0. If not found, does not print anything and returns 1. */ static int LocateDependency(const char *keypath) { size_t i; int ret; static const char *paths[] = {"..", "..\\..", "..\\..\\.."}; for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { ret = LocateDependencyHelper(paths[i], keypath); if (ret == 0) return ret; } return ret; } /* * Local variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * indent-tabs-mode: t * tab-width: 8 * End: */ itcl4.2.2/win/makefile.vc0000644003604700454610000000626514137636232013714 0ustar dgp771div#------------------------------------------------------------- -*- makefile -*- # # Makefile for ITcl # # Basic build, test and install # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source test # nmake /s /nologo /f makefile.vc INSTALLDIR=c:\path\to\installdir TCLDIR=c:\path\to\tcl\source install # # For other build options (debug, static etc.) # See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # #------------------------------------------------------------------------------ PROJECT = itcl NEED_TCL_SOURCE = 1 RCFILE = itcl.rc !include "rules-ext.vc" PRJ_OBJS = \ $(TMP_DIR)\itcl2TclOO.obj \ $(TMP_DIR)\itclBase.obj \ $(TMP_DIR)\itclBuiltin.obj \ $(TMP_DIR)\itclClass.obj \ $(TMP_DIR)\itclCmd.obj \ $(TMP_DIR)\itclEnsemble.obj \ $(TMP_DIR)\itclHelpers.obj \ $(TMP_DIR)\itclInfo.obj \ $(TMP_DIR)\itclLinkage.obj \ $(TMP_DIR)\itclMethod.obj \ $(TMP_DIR)\itclMigrate2TclCore.obj \ $(TMP_DIR)\itclObject.obj \ $(TMP_DIR)\itclParse.obj \ $(TMP_DIR)\itclResolve.obj \ $(TMP_DIR)\itclStubs.obj \ $(TMP_DIR)\itclStubInit.obj \ $(TMP_DIR)\itclTclIntStubsFcn.obj \ $(TMP_DIR)\itclUtil.obj \ !if !$(STATIC_BUILD) $(TMP_DIR)\dllEntryPoint.obj \ !endif PRJ_STUBOBJS = $(TMP_DIR)\itclStubLib.obj PRJ_DEFINES = /D_CRT_SECURE_NO_WARNINGS !if $(DEBUG) PRJ_DEFINES = $(PRJ_DEFINES) /DITCL_DEBUG !endif PRJ_HEADERS_PUBLIC = \ $(GENERICDIR)\itcl.h \ $(GENERICDIR)\itclDecls.h # Define the standard targets except we have a custom test target DISABLE_TARGET_test = 1 !include "$(_RULESDIR)\targets.vc" pkgindex: $(OUT_DIR)\pkgIndex.tcl $(OUT_DIR)\pkgIndex.tcl: @$(COPY) << "$(OUT_DIR)\pkgIndex.tcl" # -*- tcl -*- # Tcl package index file, version 1.1 # if {![package vsatisfies [package provide Tcl] 8.6-]} {return} if {[package vsatisfies [package provide Tcl] 9.0-]} { package ifneeded itcl $(DOTVERSION) \ [list load [file join $$dir tcl9itcl$(VERSION).dll] Itcl] } else { package ifneeded itcl $(DOTVERSION) \ [list load [file join $$dir itcl$(VERSION).dll] Itcl] } package ifneeded Itcl $(DOTVERSION) [list package require -exact itcl $(DOTVERSION)] << !if $(STATIC_BUILD) test : @echo test target not supported for a static library. !else test : setup $(PROJECT) $(TCLSH) ..\tests\all.tcl $(TESTFLAGS) -loadfile << set env(ITCL_LIBRARY) [file normalize [file join $(MAKEDIR:\=/) .. library]] package ifneeded $(PROJECT) $(DOTVERSION) [list load [file normalize [file join $(MAKEDIR:\=/) $(PRJLIB:\=/)]]] << !endif genstubs: !if $(TCLINSTALL) @echo Need the source distribution to regenerate the Stubs table. !else $(TCLSH) $(TOOLSDIR)\genStubs.tcl $(GENERICDIR) \ $(GENERICDIR)\$(PROJECT).decls $(GENERICDIR)\$(PROJECT)Int.decls !endif itcl4.2.2/win/itcl.rc0000644003604700454610000000261514137636151013061 0ustar dgp771div// // Version resource script. // #include #include // // build-up the name suffix that defines the type of build this is. // #if DEBUG && !UNCHECKED #define SUFFIX_DEBUG "g" #else #define SUFFIX_DEBUG "" #endif #define SUFFIX SUFFIX_DEBUG VS_VERSION_INFO VERSIONINFO FILEVERSION ITCL_MAJOR_VERSION,ITCL_MINOR_VERSION,ITCL_RELEASE_LEVEL,ITCL_RELEASE_SERIAL PRODUCTVERSION ITCL_MAJOR_VERSION,ITCL_MINOR_VERSION,ITCL_RELEASE_LEVEL,ITCL_RELEASE_SERIAL FILEFLAGSMASK 0x3fL #ifdef DEBUG FILEFLAGS VS_FF_DEBUG #else FILEFLAGS 0x0L #endif FILEOS VOS__WINDOWS32 FILETYPE VFT_DLL FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "Itcl language extension for Tcl\0" VALUE "Authors", "Michael McLennan, Arnulf Wiedemann, David Gravereaux, Chad Smith, Mark Harrison, Daniel A. Steffen, and many others\0" VALUE "OriginalFilename", "itcl" STRINGIFY(ITCL_MAJOR_VERSION) STRINGIFY(ITCL_MINOR_VERSION) SUFFIX ".dll\0" VALUE "CompanyName", "Bell Labs Innovations for Lucent Technologies\0" VALUE "FileVersion", ITCL_PATCH_LEVEL VALUE "LegalCopyright", "Copyright \251 1993-2009\0" VALUE "ProductName", "[Incr Tcl] " ITCL_VERSION " for Windows\0" VALUE "ProductVersion", ITCL_PATCH_LEVEL END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x409, 1200 END END itcl4.2.2/win/dllEntryPoint.c0000644003604700454610000000232114137636151014545 0ustar dgp771div/* * dllEntryPoint.c -- * * This file implements the Dll entry point as needed by Windows. */ #define WIN32_LEAN_AND_MEAN #include #ifdef _MSC_VER /* Only do this when MSVC++ is compiling us. */ # define DllEntryPoint DllMain # if defined(USE_TCL_STUBS) && (!defined(_MT) || !defined(_DLL) || defined(_DEBUG)) /* * This fixes a bug with how the Stubs library was compiled. * The requirement for msvcrt.lib from tclstubXX.lib should * be removed. */ # pragma comment(linker, "-nodefaultlib:msvcrt.lib") # endif #endif /* *---------------------------------------------------------------------- * * DllEntryPoint -- * * This wrapper function is used by Windows to invoke the * initialization code for the DLL. If we are compiling * with Visual C++, this routine will be renamed to DllMain. * * Results: * Returns TRUE; * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifndef STATIC_BUILD BOOL APIENTRY DllEntryPoint(hInst, reason, reserved) HINSTANCE hInst; /* Library instance handle. */ DWORD reason; /* Reason this function is being called. */ LPVOID reserved; /* Not used. */ { return TRUE; } #endif itcl4.2.2/tools/0000755003604700454610000000000014140773323012134 5ustar dgp771divitcl4.2.2/tools/genStubs.tcl0000644003604700454610000007044114137636151014443 0ustar dgp771div# genStubs.tcl -- # # This script generates a set of stub files for a given # interface. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.4 namespace eval genStubs { # libraryName -- # # The name of the entire library. This value is used to compute # the USE_*_STUBS macro and the name of the init file. variable libraryName "UNKNOWN" # interfaces -- # # An array indexed by interface name that is used to maintain # the set of valid interfaces. The value is empty. array set interfaces {} # curName -- # # The name of the interface currently being defined. variable curName "UNKNOWN" # scspec -- # # Storage class specifier for external function declarations. # Normally "EXTERN", may be set to something like XYZAPI # variable scspec "EXTERN" # epoch, revision -- # # The epoch and revision numbers of the interface currently being defined. # (@@@TODO: should be an array mapping interface names -> numbers) # variable epoch {} variable revision 0 # hooks -- # # An array indexed by interface name that contains the set of # subinterfaces that should be defined for a given interface. array set hooks {} # stubs -- # # This three dimensional array is indexed first by interface name, # second by platform name, and third by a numeric offset or the # constant "lastNum". The lastNum entry contains the largest # numeric offset used for a given interface/platform combo. Each # numeric offset contains the C function specification that # should be used for the given entry in the stub table. The spec # consists of a list in the form returned by parseDecl. array set stubs {} # outDir -- # # The directory where the generated files should be placed. variable outDir . } # genStubs::library -- # # This function is used in the declarations file to set the name # of the library that the interfaces are associated with (e.g. "tcl"). # This value will be used to define the inline conditional macro. # # Arguments: # name The library name. # # Results: # None. proc genStubs::library {name} { variable libraryName $name } # genStubs::interface -- # # This function is used in the declarations file to set the name # of the interface currently being defined. # # Arguments: # name The name of the interface. # # Results: # None. proc genStubs::interface {name} { variable curName $name variable interfaces set interfaces($name) {} return } # genStubs::scspec -- # # Define the storage class macro used for external function declarations. # Typically, this will be a macro like XYZAPI or EXTERN that # expands to either DLLIMPORT or DLLEXPORT, depending on whether # -DBUILD_XYZ has been set. # proc genStubs::scspec {value} { variable scspec $value } # genStubs::epoch -- # # Define the epoch number for this library. The epoch # should be incrememented when a release is made that # contains incompatible changes to the public API. # proc genStubs::epoch {value} { variable epoch $value } # genStubs::hooks -- # # This function defines the subinterface hooks for the current # interface. # # Arguments: # names The ordered list of interfaces that are reachable through the # hook vector. # # Results: # None. proc genStubs::hooks {names} { variable curName variable hooks set hooks($curName) $names return } # genStubs::declare -- # # This function is used in the declarations file to declare a new # interface entry. # # Arguments: # index The index number of the interface. # platform The platform the interface belongs to. Should be one # of generic, win, unix, or macosx or aqua or x11. # decl The C function declaration, or {} for an undefined # entry. # # Results: # None. proc genStubs::declare {args} { variable stubs variable curName variable revision incr revision if {[llength $args] == 2} { lassign $args index decl set platformList generic } elseif {[llength $args] == 3} { lassign $args index platformList decl } else { puts stderr "wrong # args: declare $args" return } # Check for duplicate declarations, then add the declaration and # bump the lastNum counter if necessary. foreach platform $platformList { if {[info exists stubs($curName,$platform,$index)]} { puts stderr "Duplicate entry: declare $args" } } regsub -all "\[ \t\n\]+" [string trim $decl] " " decl set decl [parseDecl $decl] foreach platform $platformList { if {$decl ne ""} { set stubs($curName,$platform,$index) $decl if {![info exists stubs($curName,$platform,lastNum)] \ || ($index > $stubs($curName,$platform,lastNum))} { set stubs($curName,$platform,lastNum) $index } } } return } # genStubs::export -- # # This function is used in the declarations file to declare a symbol # that is exported from the library but is not in the stubs table. # # Arguments: # decl The C function declaration, or {} for an undefined # entry. # # Results: # None. proc genStubs::export {args} { if {[llength $args] != 1} { puts stderr "wrong # args: export $args" } return } # genStubs::rewriteFile -- # # This function replaces the machine generated portion of the # specified file with new contents. It looks for the !BEGIN! and # !END! comments to determine where to place the new text. # # Arguments: # file The name of the file to modify. # text The new text to place in the file. # # Results: # None. proc genStubs::rewriteFile {file text} { if {![file exists $file]} { puts stderr "Cannot find file: $file" return } set in [open ${file} r] set out [open ${file}.new w] fconfigure $out -translation lf while {![eof $in]} { set line [gets $in] if {[string match "*!BEGIN!*" $line]} { break } puts $out $line } puts $out "/* !BEGIN!: Do not edit below this line. */" puts $out $text while {![eof $in]} { set line [gets $in] if {[string match "*!END!*" $line]} { break } } puts $out "/* !END!: Do not edit above this line. */" puts -nonewline $out [read $in] close $in close $out file rename -force ${file}.new ${file} return } # genStubs::addPlatformGuard -- # # Wrap a string inside a platform #ifdef. # # Arguments: # plat Platform to test. # # Results: # Returns the original text inside an appropriate #ifdef. proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" switch $plat { win { append text "#if defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } append text " /* WIN */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* WIN */\n${eltxt}" } append text "#endif /* WIN */\n" } unix { append text "#if !defined(_WIN32)" if {$withCygwin} { append text " && !defined(__CYGWIN__)" } append text " && !defined(MAC_OSX_TCL)\ /* UNIX */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* UNIX */\n${eltxt}" } append text "#endif /* UNIX */\n" } macosx { append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* MACOSX */\n${eltxt}" } append text "#endif /* MACOSX */\n" } aqua { append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* AQUA */\n${eltxt}" } append text "#endif /* AQUA */\n" } x11 { append text "#if !(defined(_WIN32)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } append text " || defined(MAC_OSX_TK))\ /* X11 */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* X11 */\n${eltxt}" } append text "#endif /* X11 */\n" } default { append text "${iftxt}${eltxt}" } } return $text } # genStubs::emitSlots -- # # Generate the stub table slots for the given interface. If there # are no generic slots, then one table is generated for each # platform, otherwise one table is generated for all platforms. # # Arguments: # name The name of the interface being emitted. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitSlots {name textVar} { upvar $textVar text forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"} return } # genStubs::parseDecl -- # # Parse a C function declaration into its component parts. # # Arguments: # decl The function declaration. # # Results: # Returns a list of the form {returnType name args}. The args # element consists of a list of type/name pairs, or a single # element "void". If the function declaration is malformed # then an error is displayed and the return value is {}. proc genStubs::parseDecl {decl} { if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} { set prefix $decl set args {} } set prefix [string trim $prefix] if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} { puts stderr "Bad return type: $decl" return } set rtype [string trim $rtype] if {$args eq ""} { return [list $rtype $fname {}] } foreach arg [split $args ,] { lappend argList [string trim $arg] } if {![string compare [lindex $argList end] "..."]} { set args TCL_VARARGS foreach arg [lrange $argList 0 end-1] { set argInfo [parseArg $arg] if {[llength $argInfo] == 2 || [llength $argInfo] == 3} { lappend args $argInfo } else { puts stderr "Bad argument: '$arg' in '$decl'" return } } } else { set args {} foreach arg $argList { set argInfo [parseArg $arg] if {![string compare $argInfo "void"]} { lappend args "void" break } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} { lappend args $argInfo } else { puts stderr "Bad argument: '$arg' in '$decl'" return } } } return [list $rtype $fname $args] } # genStubs::parseArg -- # # This function parses a function argument into a type and name. # # Arguments: # arg The argument to parse. # # Results: # Returns a list of type and name with an optional third array # indicator. If the argument is malformed, returns "". proc genStubs::parseArg {arg} { if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { if {$arg eq "void"} { return $arg } else { return } } set result [list [string trim $type] $name] if {$array ne ""} { lappend result $array } return $result } # genStubs::makeDecl -- # # Generate the prototype for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted declaration string. proc genStubs::makeDecl {name decl index} { variable scspec lassign $decl rtype fname args append text "/* $index */\n" set line "$scspec $rtype" set count [expr {2 - ([string length $line] / 8)}] append line [string range "\t\t\t" 0 $count] set pad [expr {24 - [string length $line]}] if {$pad <= 0} { append line " " set pad 0 } if {$args eq ""} { append line $fname append text $line append text ";\n" return $text } append line $fname set arg1 [lindex $args 0] switch -exact $arg1 { void { append line "(void)" } TCL_VARARGS { set sep "(" foreach arg [lrange $args 1 end] { append line $sep set next {} append next [lindex $arg 0] if {[string index $next end] ne "*"} { append next " " } append next [lindex $arg 1] [lindex $arg 2] if {[string length $line] + [string length $next] \ + $pad > 76} { append text [string trimright $line] \n set line "\t\t\t\t" set pad 28 } append line $next set sep ", " } append line ", ...)" if {[lindex $args end] eq "{const char *} format"} { append line " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" } } default { set sep "(" foreach arg $args { append line $sep set next {} append next [lindex $arg 0] if {[string index $next end] ne "*"} { append next " " } append next [lindex $arg 1] [lindex $arg 2] if {[string length $line] + [string length $next] \ + $pad > 76} { append text [string trimright $line] \n set line "\t\t\t\t" set pad 28 } append line $next set sep ", " } append line ")" } } return "$text$line;\n" } # genStubs::makeMacro -- # # Generate the inline macro for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted macro definition. proc genStubs::makeMacro {name decl index} { lassign $decl rtype fname args set lfname [string tolower [string index $fname 0]] append lfname [string range $fname 1 end] set text "#define $fname \\\n\t(" if {$args eq ""} { append text "*" } append text "${name}StubsPtr->$lfname)" append text " /* $index */\n" return $text } # genStubs::makeSlot -- # # Generate the stub table entry for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted table entry. proc genStubs::makeSlot {name decl index} { lassign $decl rtype fname args set lfname [string tolower [string index $fname 0]] append lfname [string range $fname 1 end] set text " " if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } else { append text $rtype " (*" $lfname ") " } set arg1 [lindex $args 0] switch -exact $arg1 { void { append text "(void)" } TCL_VARARGS { set sep "(" foreach arg [lrange $args 1 end] { append text $sep [lindex $arg 0] if {[string index $text end] ne "*"} { append text " " } append text [lindex $arg 1] [lindex $arg 2] set sep ", " } append text ", ...)" if {[lindex $args end] eq "{const char *} format"} { append text " TCL_FORMAT_PRINTF(" [expr {[llength $args] - 1}] ", " [llength $args] ")" } } default { set sep "(" foreach arg $args { append text $sep [lindex $arg 0] if {[string index $text end] ne "*"} { append text " " } append text [lindex $arg 1] [lindex $arg 2] set sep ", " } append text ")" } } append text "; /* $index */\n" return $text } # genStubs::makeInit -- # # Generate the prototype for a function. # # Arguments: # name The interface name. # decl The function declaration. # index The slot index for this function. # # Results: # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { if {[lindex $decl 2] eq ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" } return $text } # genStubs::forAllStubs -- # # This function iterates over all of the platforms and invokes # a callback for each slot. The result of the callback is then # placed inside appropriate platform guards. # # Arguments: # name The interface name. # slotProc The proc to invoke to handle the slot. It will # have the interface name, the declaration, and # the index appended. # onAll If 1, emit the skip string even if there are # definitions for one or more platforms. # textVar The variable to use for output. # skipString The string to emit if a slot is skipped. This # string will be subst'ed in the loop so "$i" can # be used to substitute the index value. # # Results: # None. proc genStubs::forAllStubs {name slotProc onAll textVar {skipString {"/* Slot $i is reserved */\n"}}} { variable stubs upvar $textVar text set plats [array names stubs $name,*,lastNum] if {[info exists stubs($name,generic,lastNum)]} { # Emit integrated stubs block set lastNum -1 foreach plat [array names stubs $name,*,lastNum] { if {$stubs($plat) > $lastNum} { set lastNum $stubs($plat) } } for {set i 0} {$i <= $lastNum} {incr i} { set slots [array names stubs $name,*,$i] set emit 0 if {[info exists stubs($name,generic,$i)]} { if {[llength $slots] > 1} { puts stderr "conflicting generic and platform entries:\ $name $i" } append text [$slotProc $name $stubs($name,generic,$i) $i] set emit 1 } elseif {[llength $slots] > 0} { array set slot {unix 0 x11 0 win 0 macosx 0 aqua 0} foreach s $slots { set slot([lindex [split $s ,] 1]) 1 } # "aqua", "macosx" and "x11" are special cases: # "macosx" implies "unix", "aqua" implies "macosx" and "x11" # implies "unix", so we need to be careful not to emit # duplicate stubs entries: if {($slot(unix) && $slot(macosx)) || ( ($slot(unix) || $slot(macosx)) && ($slot(x11) || $slot(aqua)))} { puts stderr "conflicting platform entries: $name $i" } ## unix ## set temp {} set plat unix if {!$slot(aqua) && !$slot(x11)} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } ## x11 ## set temp {} set plat x11 if {!$slot(unix) && !$slot(macosx)} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } ## win ## set temp {} set plat win if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } ## macosx ## set temp {} set plat macosx if {!$slot(aqua) && !$slot(x11)} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$slot(unix)} { append temp [$slotProc $name $stubs($name,unix,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } ## aqua ## set temp {} set plat aqua if {!$slot(unix) && !$slot(macosx)} { if {[string range $skipString 1 2] ne "/*"} { # genStubs.tcl previously had a bug here causing it to # erroneously generate both a unix entry and an aqua # entry for a given stubs table slot. To preserve # backwards compatibility, generate a dummy stubs entry # before every aqua entry (note that this breaks the # correspondence between emitted entry number and # actual position of the entry in the stubs table, e.g. # TkIntStubs entry 113 for aqua is in fact at position # 114 in the table, entry 114 at position 116 etc). eval {append temp} $skipString set temp "[string range $temp 0 end-1] /*\ Dummy entry for stubs table backwards\ compatibility */\n" } if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { eval {append temp} $skipString } } if {$temp ne ""} { append text [addPlatformGuard $plat $temp] set emit 1 } } if {!$emit} { eval {append text} $skipString } } } else { # Emit separate stubs blocks per platform array set block {unix 0 x11 0 win 0 macosx 0 aqua 0} foreach s [array names stubs $name,*,lastNum] { set block([lindex [split $s ,] 1]) 1 } ## unix ## if {$block(unix) && !$block(x11)} { set temp {} set plat unix set lastNum $stubs($name,$plat,lastNum) for {set i 0} {$i <= $lastNum} {incr i} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } else { eval {append temp} $skipString } } append text [addPlatformGuard $plat $temp {} true] } ## win ## if {$block(win)} { set temp {} set plat win set lastNum $stubs($name,$plat,lastNum) for {set i 0} {$i <= $lastNum} {incr i} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } else { eval {append temp} $skipString } } append text [addPlatformGuard $plat $temp {} true] } ## macosx ## if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} { set temp {} set lastNum -1 foreach plat {unix macosx} { if {$block($plat)} { set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) ? $lastNum : $stubs($name,$plat,lastNum)}] } } for {set i 0} {$i <= $lastNum} {incr i} { set emit 0 foreach plat {unix macosx} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] set emit 1 break } } if {!$emit} { eval {append temp} $skipString } } append text [addPlatformGuard macosx $temp] } ## aqua ## if {$block(aqua)} { set temp {} set lastNum -1 foreach plat {unix macosx aqua} { if {$block($plat)} { set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) ? $lastNum : $stubs($name,$plat,lastNum)}] } } for {set i 0} {$i <= $lastNum} {incr i} { set emit 0 foreach plat {unix macosx aqua} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] set emit 1 break } } if {!$emit} { eval {append temp} $skipString } } append text [addPlatformGuard aqua $temp] } ## x11 ## if {$block(x11)} { set temp {} set lastNum -1 foreach plat {unix macosx x11} { if {$block($plat)} { set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum) ? $lastNum : $stubs($name,$plat,lastNum)}] } } for {set i 0} {$i <= $lastNum} {incr i} { set emit 0 foreach plat {unix macosx x11} { if {[info exists stubs($name,$plat,$i)]} { if {$plat ne "macosx"} { append temp [$slotProc $name \ $stubs($name,$plat,$i) $i] } else { eval {set etxt} $skipString append temp [addPlatformGuard $plat [$slotProc \ $name $stubs($name,$plat,$i) $i] $etxt true] } set emit 1 break } } if {!$emit} { eval {append temp} $skipString } } append text [addPlatformGuard x11 $temp {} true] } } } # genStubs::emitDeclarations -- # # This function emits the function declarations for this interface. # # Arguments: # name The interface name. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitDeclarations {name textVar} { upvar $textVar text append text "\n/*\n * Exported function declarations:\n */\n\n" forAllStubs $name makeDecl 0 text return } # genStubs::emitMacros -- # # This function emits the inline macros for an interface. # # Arguments: # name The name of the interface being emitted. # textVar The variable to use for output. # # Results: # None. proc genStubs::emitMacros {name textVar} { variable libraryName upvar $textVar text set upName [string toupper $libraryName] append text "\n#if defined(USE_${upName}_STUBS)\n" append text "\n/*\n * Inline function declarations:\n */\n\n" forAllStubs $name makeMacro 0 text append text "\n#endif /* defined(USE_${upName}_STUBS) */\n" return } # genStubs::emitHeader -- # # This function emits the body of the Decls.h file for # the specified interface. # # Arguments: # name The name of the interface being emitted. # # Results: # None. proc genStubs::emitHeader {name} { variable outDir variable hooks variable epoch variable revision set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] if {$epoch ne ""} { set CAPName [string toupper $name] append text "\n" append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" append text "#define ${CAPName}_STUBS_REVISION $revision\n" } append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n" emitDeclarations $name text if {[info exists hooks($name)]} { append text "\ntypedef struct {\n" foreach hook $hooks($name) { set capHook [string toupper [string index $hook 0]] append capHook [string range $hook 1 end] append text " const struct ${capHook}Stubs *${hook}Stubs;\n" } append text "} ${capName}StubHooks;\n" } append text "\ntypedef struct ${capName}Stubs {\n" append text " int magic;\n" if {$epoch ne ""} { append text " int epoch;\n" append text " int revision;\n" } if {[info exists hooks($name)]} { append text " const ${capName}StubHooks *hooks;\n\n" } else { append text " void *hooks;\n\n" } emitSlots $name text append text "} ${capName}Stubs;\n\n" append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n" append text "#ifdef __cplusplus\n}\n#endif\n" emitMacros $name text rewriteFile [file join $outDir ${name}Decls.h] $text return } # genStubs::emitInit -- # # Generate the table initializers for an interface. # # Arguments: # name The name of the interface to initialize. # textVar The variable to use for output. # # Results: # Returns the formatted output. proc genStubs::emitInit {name textVar} { variable hooks variable interfaces variable epoch upvar $textVar text set root 1 set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] if {[info exists hooks($name)]} { append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n" set sep " " foreach sub $hooks($name) { append text $sep "&${sub}Stubs" set sep ",\n " } append text "\n\};\n" } foreach intf [array names interfaces] { if {[info exists hooks($intf)]} { if {[lsearch -exact $hooks($intf) $name] >= 0} { set root 0 break } } } append text "\n" if {!$root} { append text "static " } append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n" if {$epoch ne ""} { set CAPName [string toupper $name] append text " ${CAPName}_STUBS_EPOCH,\n" append text " ${CAPName}_STUBS_REVISION,\n" } if {[info exists hooks($name)]} { append text " &${name}StubHooks,\n" } else { append text " 0,\n" } forAllStubs $name makeInit 1 text {" 0, /* $i */\n"} append text "\};\n" return } # genStubs::emitInits -- # # This function emits the body of the StubInit.c file for # the specified interface. # # Arguments: # name The name of the interface being emitted. # # Results: # None. proc genStubs::emitInits {} { variable hooks variable outDir variable libraryName variable interfaces # Assuming that dependencies only go one level deep, we need to emit # all of the leaves first to avoid needing forward declarations. set leaves {} set roots {} foreach name [lsort [array names interfaces]] { if {[info exists hooks($name)]} { lappend roots $name } else { lappend leaves $name } } foreach name $leaves { emitInit $name text } foreach name $roots { emitInit $name text } rewriteFile [file join $outDir ${libraryName}StubInit.c] $text } # genStubs::init -- # # This is the main entry point. # # Arguments: # None. # # Results: # None. proc genStubs::init {} { global argv argv0 variable outDir variable interfaces if {[llength $argv] < 2} { puts stderr "usage: $argv0 outDir declFile ?declFile...?" exit 1 } set outDir [lindex $argv 0] foreach file [lrange $argv 1 end] { source $file } foreach name [lsort [array names interfaces]] { puts "Emitting $name" emitHeader $name } emitInits } # lassign -- # # This function emulates the TclX lassign command. # # Arguments: # valueList A list containing the values to be assigned. # args The list of variables to be assigned. # # Results: # Returns any values that were not assigned to variables. if {[string length [namespace which lassign]] == 0} { proc lassign {valueList args} { if {[llength $args] == 0} { error "wrong # args: should be \"lassign list varName ?varName ...?\"" } uplevel [list foreach $args $valueList {break}] return [lrange $valueList [llength $args] end] } } genStubs::init itcl4.2.2/tests/0000755003604700454610000000000014140773323012136 5ustar dgp771divitcl4.2.2/tests/widgetclass.test0000644003604700454610000004272414137636151015364 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # widgetclass.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type command. # Uses the ::tcltest:: harness. # # There is at least Tcl 8.6a3 needed # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- # ### ### ### ######### ######### ######### ## Declare the minimal version of Tcl required to run the package ## tested by this testsuite, and its dependencies. proc testsNeedTcl {version} { # This command ensures that a minimum version of Tcl is used to # run the tests in the calling testsuite. If the minimum is not # met by the active interpreter we forcibly bail out of the # testsuite calling the command. The command has to be called # immediately after loading the utilities. if {[package vsatisfies [package provide Tcl] ${version}-]} return puts " Aborting the tests found in \"[file tail [info script]]\"" puts " Requiring at least Tcl $version, have [package provide Tcl]." # This causes a 'return' in the calling scope. return -code return } # ### ### ### ######### ######### ######### ## Declare the minimum version of Tcltest required to run the ## testsuite. proc testsNeedTcltest {version} { # This command ensure that a minimum version of the Tcltest # support package is used to run the tests in the calling # testsuite. If the minimum is not met by the loaded package we # forcibly bail out of the testsuite calling the command. The # command has to be called after loading the utilities. The only # command allowed to come before it is 'textNeedTcl' above. # Note that this command will try to load a suitable version of # Tcltest if the package has not been loaded yet. if {[lsearch [namespace children] ::tcltest] == -1} { if {![catch { package require tcltest $version }]} { namespace import -force ::tcltest::* return } } elseif {[package vcompare [package present tcltest] $version] >= 0} { namespace import -force ::tcltest::* return } puts " Aborting the tests found in [file tail [info script]]." puts " Requiring at least tcltest $version, have [package present tcltest]" # This causes a 'return' in the calling scope. return -code return } # Set up for Tk tests: enter the event loop long enough to catch # any bgerrors. proc tkbide {{msg "tkbide"} {msec 500}} { set ::bideVar 0 set ::bideError "" set ::bideErrorInfo "" # It looks like update idletasks does the job. if {0} { after $msec {set ::bideVar 1} tkwait variable ::bideVar } update idletasks if {"" != $::bideError} { error "$msg: $::bideError" $::bideErrorInfo } } testsNeedTcl 8.6 testsNeedTcltest 2.2 interp alias {} type {} ::itcl::type interp alias {} widget {} ::itcl::widget # Marks tests which are only for Tk. tcltest::testConstraint tk [expr {![catch {package require Tk}]}] ::tcltest::loadTestedCommands package require itcl #----------------------------------------------------------------------- # Widgets # A widget is just a widgetadaptor with an automatically created hull # component (a Tk frame). So the widgetadaptor tests apply; all we # need to test here is the frame creation. test widget-1.1 {creating a widget } -constraints { tk } -body { widget myframe { delegate method * to itcl_hull delegate option * to itcl_hull } myframe create .frm -background green set a [.frm cget -background] set b [.frm itcl_hull] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {green ::itcl::internal::widgets::hull1.frm} test widget-2.1 {can't redefine hull } -constraints { tk } -body { # there is no need to define or set itcl_hull as that is done automatically widget myframe { method resethull {} { set itcl_hull "" } } myframe .frm .frm resethull } -returnCodes { error } -cleanup { myframe destroy } -result {can't set "itcl_hull": The itcl_hull component cannot be redefined} #----------------------------------------------------------------------- # install # # The install command is used to install widget components, while getting # options for the option database. test install-1.1 {installed components are created properly } -constraints { tk } -body { widget myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { installcomponent text using text $win.text -background green } method getit {} { $win.text cget -background } } myframe .frm set a [.frm getit] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {green} test install-1.2 {installed components are saved properly } -constraints { tk } -body { widget myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { installcomponent text using text $win.text -background green } method getit {} { $text cget -background } } myframe .frm set a [.frm getit] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {green} test install-1.4 {install queries option database } -constraints { tk } -body { widget myframe { delegate option -font to text typeconstructor { option add *Myframe.font Courier } constructor {args} { installcomponent text using text $win.text } } myframe .frm set a [.frm cget -font] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Courier} test install-1.5 {explicit options override option database } -constraints { tk } -body { widget myframe { delegate option -font to text typeconstructor { option add *Myframe.font Courier } constructor {args} { installcomponent text using text $win.text -font Times } } myframe .frm set a [.frm cget -font] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Times} test install-1.6 {option db works with targetted options } -constraints { tk } -body { widget myframe { delegate option -textfont to text as -font typeconstructor { option add *Myframe.textfont Courier } constructor {args} { installcomponent text using text $win.text } } myframe .frm set a [.frm cget -textfont] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {Courier} test install-1.8 {install can install non-widget components } -constraints { tk } -body { type dog { option -tailcolor black } widget myframe { delegate option -tailcolor to thedog typeconstructor { option add *Myframe.tailcolor green } constructor {args} { installcomponent thedog using dog $win.dog } } myframe .frm set a [.frm cget -tailcolor] destroy .frm tkbide set a } -cleanup { dog destroy myframe destroy } -result {green} test install-1.9 {ok if no options are delegated to component } -constraints { tk } -body { type dog { option -tailcolor black } widget myframe { constructor {args} { installcomponent thedog using dog $win.dog } } myframe .frm destroy .frm tkbide # Test passes if no error is raised. list ok } -cleanup { myframe destroy dog destroy } -result {ok} test install-2.1 { delegate option * for a non-shadowed option. The text widget's -foreground and -font options should be set according to what's in the option database on the widgetclass. } -constraints { tk } -body { widget myframe { delegate option * to text typeconstructor { option add *Myframe.foreground red option add *Myframe.font {Times 14} } constructor {args} { installcomponent text using text $win.text } } myframe .frm set a [.frm cget -foreground] set b [.frm cget -font] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red {Times 14}} test install-2.2 { Delegate option * for a shadowed option. Foreground is declared as a non-delegated option, hence it will pick up the option database default. -foreground is not included in the "delegate option *", so the text widget's -foreground option will not be set from the option database. } -constraints { tk } -body { widget myframe { option -foreground white delegate option * to text typeconstructor { option add *Myframe.foreground red } constructor {args} { installcomponent text using text $win.text } method getit {} { $text cget -foreground } } myframe .frm set a [.frm cget -foreground] set b [.frm getit] destroy .frm tkbide expr {![string equal $a $b]} } -cleanup { myframe destroy } -result {1} test install-2.3 { Delegate option * for a creation option. Because the text widget's -foreground is set explicitly by the constructor, that always overrides the option database. } -constraints { tk } -body { widget myframe { delegate option * to text typeconstructor { option add *Myframe.foreground red } constructor {args} { installcomponent text using text $win.text -foreground blue } } myframe .frm set a [.frm cget -foreground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {blue} test install-2.4 { Delegate option * with an excepted option. Because the text widget's -state is excepted, it won't be set from the option database. } -constraints { tk } -body { widget myframe { delegate option * to text except -state typeconstructor { option add *Myframe.foreground red option add *Myframe.state disabled } constructor {args} { installcomponent text using text $win.text } method getstate {} { $text cget -state } } myframe .frm set a [.frm getstate] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {normal} #----------------------------------------------------------------------- # Advanced installhull tests # # installhull is used to install the hull widget for both widgets and # widget adaptors. It has two forms. In one form it installs a widget # created by some third party; in this form no querying of the option # database is needed, because we haven't taken responsibility for creating # it. But in the other form (installhull using) installhull actually # creates the widget, and takes responsibility for querying the # option database as needed. # # NOTE: "installhull using" is always used to create a widget's hull frame. # # That options passed into installhull override those from the # option database. test installhull-1.1 { options delegated to a widget's itcl_hull frame with the same name are initialized from the option database. Note that there's no explicit code in Snit to do this; it happens because we set the -class when the widget was created. In fact, it happens whether we delegate the option name or not. } -constraints { tk } -body { widget myframe { delegate option -background to itcl_hull typeconstructor { option add *Myframe.background red option add *Myframe.width 123 } method getwid {} { $itcl_hull cget -width } } myframe .frm set a [.frm cget -background] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red 123} test installhull-1.2 { Options delegated to a widget's itcl_hull frame with a different name are initialized from the option database. } -constraints { tk } -body { widget myframe { delegate option -mainbackground to itcl_hull as -background typeconstructor { option add *Myframe.mainbackground green } } myframe .frm set a [.frm cget -mainbackground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {green} test option-5.1 {local widget options read from option database } -constraints { tk } -body { widget dog { option -foo a option -bar b typeconstructor { option add *Dog.bar bb } } dog .fido set a [.fido cget -foo] set b [.fido cget -bar] destroy .fido tkbide list $a $b } -cleanup { dog destroy } -result {a bb} test option-5.2 {local option database values available in constructor } -constraints { tk } -body { widget dog { option -bar b variable saveit typeconstructor { option add *Dog.bar bb } constructor {args} { set saveit $itcl_options(-bar) } method getit {} { return $saveit } } dog .fido set result [.fido getit] destroy .fido tkbide set result } -cleanup { dog destroy } -result {bb} #----------------------------------------------------------------------- # Setting the widget class explicitly test widgetclass-1.3 {widgetclass must begin with uppercase letter } -constraints { tk } -body { widget dog { widgetclass dog } } -returnCodes { error } -result {widgetclass "dog" does not begin with an uppercase letter} test widgetclass-1.4 {widgetclass can only be defined once } -constraints { tk } -body { widget dog { widgetclass Dog widgetclass Dog } } -returnCodes { error } -result {too many widgetclass statements} test widgetclass-1.5 {widgetclass set successfully } -constraints { tk } -body { widget dog { widgetclass DogWidget } # The test passes if no error is thrown. list ok } -cleanup { dog destroy } -result {ok} test widgetclass-1.6 {implicit widgetclass applied to hull } -constraints { tk } -body { widget dog { typeconstructor { option add *Dog.background green } method background {} { $itcl_hull cget -background } } dog .dog set bg [.dog background] destroy .dog set bg } -cleanup { dog destroy } -result {green} test widgetclass-1.7 {explicit widgetclass applied to hull } -constraints { tk } -body { widget dog { widgetclass DogWidget typeconstructor { option add *DogWidget.background yellow } method background {} { $itcl_hull cget -background } } dog .dog set bg [.dog background] destroy .dog set bg } -cleanup { dog destroy } -result {yellow} #----------------------------------------------------------------------- # hulltype statement test hulltype-1.3 {hulltype can be frame } -constraints { tk } -body { widget dog { delegate option * to itcl_hull hulltype frame } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } -cleanup { dog destroy } -result {unknown option "-use"} test hulltype-1.4 {hulltype can be toplevel } -constraints { tk } -body { widget dog { delegate option * to itcl_hull hulltype toplevel } dog .fido catch {.fido configure -use} result destroy .fido tkbide set result } -cleanup { dog destroy } -result {-use use Use {} {}} test hulltype-1.5 {hulltype can only be defined once } -constraints { tk } -body { widget dog { hulltype frame hulltype toplevel } } -returnCodes { error } -result {too many hulltype statements} test hulltype-2.1 {list of valid hulltypes } -constraints { tk } -body { type dog { } lsort [dog info hulltypes] } -cleanup { dog destroy } -result {frame labelframe toplevel ttk:frame ttk:labelframe ttk:toplevel} test winfo-10.1 {widget info widgets } -constraints { tk } -body { widget dog { } widget cat { } lsort [dog info widgets] } -cleanup { dog destroy cat destroy } -result {cat dog} test winfo-10.2 {widget info components } -constraints { tk } -body { widget dog { component comp1 component comp2 } widget cat { component comp1 component comp1a } set a [lsort [dog info components]] set b [lsort [cat info components]] list $a $b } -cleanup { dog destroy cat destroy } -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}} test winfo-10.3 {widget info widgetclasses } -constraints { tk } -body { widget dog { widgetclass DogWidget } widget cat { widgetclass CatWidget } lsort [dog info widgetclasses] } -cleanup { dog destroy cat destroy } -result {CatWidget DogWidget} #--------------------------------------------------------------------- # Clean up ::tcltest::cleanupTests return itcl4.2.2/tests/widgetadaptor.test0000644003604700454610000005023314137636151015703 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typefunction.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # There is at least Tcl 8.6a3 needed # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- # ### ### ### ######### ######### ######### ## Declare the minimal version of Tcl required to run the package ## tested by this testsuite, and its dependencies. proc testsNeedTcl {version} { # This command ensures that a minimum version of Tcl is used to # run the tests in the calling testsuite. If the minimum is not # met by the active interpreter we forcibly bail out of the # testsuite calling the command. The command has to be called # immediately after loading the utilities. if {[package vsatisfies [package provide Tcl] ${version}-]} return puts " Aborting the tests found in \"[file tail [info script]]\"" puts " Requiring at least Tcl $version, have [package provide Tcl]." # This causes a 'return' in the calling scope. return -code return } # ### ### ### ######### ######### ######### ## Declare the minimum version of Tcltest required to run the ## testsuite. proc testsNeedTcltest {version} { # This command ensure that a minimum version of the Tcltest # support package is used to run the tests in the calling # testsuite. If the minimum is not met by the loaded package we # forcibly bail out of the testsuite calling the command. The # command has to be called after loading the utilities. The only # command allowed to come before it is 'textNeedTcl' above. # Note that this command will try to load a suitable version of # Tcltest if the package has not been loaded yet. if {[lsearch [namespace children] ::tcltest] == -1} { if {![catch { package require tcltest $version }]} { namespace import -force ::tcltest::* return } } elseif {[package vcompare [package present tcltest] $version] >= 0} { namespace import -force ::tcltest::* return } puts " Aborting the tests found in [file tail [info script]]." puts " Requiring at least tcltest $version, have [package present tcltest]" # This causes a 'return' in the calling scope. return -code return } # Set up for Tk tests: enter the event loop long enough to catch # any bgerrors. proc tkbide {{msg "tkbide"} {msec 500}} { set ::bideVar 0 set ::bideError "" set ::bideErrorInfo "" # It looks like update idletasks does the job. if {0} { after $msec {set ::bideVar 1} tkwait variable ::bideVar } update idletasks if {"" != $::bideError} { error "$msg: $::bideError" $::bideErrorInfo } } testsNeedTcl 8.6 testsNeedTcltest 2.2 interp alias {} type {} ::itcl::type interp alias {} widgetadaptor {} ::itcl::widgetadaptor # Marks tests which are only for Tk. tcltest::testConstraint tk [expr {![catch {package require Tk}]}] ::tcltest::loadTestedCommands package require itcl #----------------------------------------------------------------------- # Widgetadaptors test widgetadaptor-1.1 {creating a widget: hull hijacking } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configure {*}$args } delegate method * to itcl_hull delegate option * to itcl_hull } set xx [mylabel create .label -text "My Label"] set a [.label cget -text] set b [::itcl::internal::widgets::hull1.label cget -text] destroy .label tkbide list $a $b } -cleanup { mylabel destroy } -result {{My Label} {My Label}} test widgetadaptor-1.2 {destroying a widget with destroy } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .label set a [lsort [namespace children ::itcl::internal::variables]] destroy .label set b [lsort [namespace children ::itcl::internal::variables]] tkbide list $a $b } -cleanup { mylabel destroy } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.3 {destroying two widgets of the same type with destroy } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 mylabel create .lab2 set a [lsort [namespace children ::itcl::internal::variables]] destroy .lab1 destroy .lab2 set b [lsort [namespace children ::itcl::internal::variables]] tkbide list $a $b } -cleanup { mylabel destroy } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.4 {destroying a widget with rename, then destroy type } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .label set a [lsort [namespace children ::itcl::internal::variables]] rename .label "" set b [lsort [namespace children ::itcl::internal::variables]] mylabel destroy tkbide list $a $b } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.5 {destroying two widgets of the same type with rename } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 mylabel create .lab2 set a [lsort [namespace children ::itcl::internal::variables]] rename .lab1 "" rename .lab2 "" set b [lsort [namespace children ::itcl::internal::variables]] mylabel destroy tkbide list $a $b } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.6 {create/destroy twice, with destroy } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 set a [namespace children ::itcl::internal::variables] destroy .lab1 mylabel create .lab1 set b [namespace children ::itcl::internal::variables] destroy .lab1 set c [namespace children ::itcl::internal::variables] mylabel destroy tkbide list $a $b $c } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.7 {create/destroy twice, with rename } -constraints { tk } -body { widgetadaptor mylabel { constructor {} { installhull [label $self] } } mylabel create .lab1 set a [namespace children ::itcl::internal::variables] rename .lab1 "" mylabel create .lab1 set b [namespace children ::itcl::internal::variables] rename .lab1 "" set c [namespace children ::itcl::internal::variables] mylabel destroy tkbide list $a $b $c } -result {{::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::oo}} test widgetadaptor-1.8 {"create" is optional } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } mylabel .label set a [.label howdy] destroy .label tkbide set a } -cleanup { mylabel destroy } -result {Howdy!} test widgetadaptor-1.10 {"create" is optional, but must be a valid name } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } method howdy {} {return "Howdy!"} } catch {mylabel foo} result tkbide set result } -cleanup { mylabel destroy } -result {bad window path name "foo"} test widgetadaptor-1.11 {user-defined destructors are called } -constraints { tk } -body { widgetadaptor mylabel { typevariable flag "" constructor {args} { installhull [label $self] set flag "created $self" } destructor { set flag "destroyed $self" } typemethod getflag {} { return $flag } } mylabel .label set a [mylabel getflag] destroy .label tkbide list $a [mylabel getflag] } -cleanup { mylabel destroy } -result {{created ::itcl::internal::widgets::hull1.label} {destroyed ::itcl::internal::widgets::hull1.label}} test widgetadaptor-1.12 {Constructor errors tolerated } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} {error foo} destructor {} } # Without bug fix this will crash mylabel .label } -cleanup { mylabel destroy } -returnCodes error -result foo test widgetadaptor-1.14 {hull can be repeatedly renamed } -constraints { tk } -body { widgetadaptor basetype { constructor {args} { installhull [label $self] } method basemethod {} { return "basemethod" } } widgetadaptor w1 { constructor {args} { installhull [basetype create $self] } } widgetadaptor w2 { constructor {args} { installhull [w1 $self] } } set a [w2 .foo] destroy .foo tkbide set a } -cleanup { w2 destroy w1 destroy basetype destroy } -result {.foo} test widgetadaptor-1.15 {widget names can be generated } -constraints { tk } -body { widgetadaptor unique { constructor {args} { installhull [label $self] } } set w [unique .#auto] destroy $w tkbide set w } -cleanup { unique destroy } -result {.unique0} test widgetadaptor-1.16 {snit::widgetadaptor as hull } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] if {[llength $args]} { $self configure {*}$args } } method method1 {} { return "method1" } delegate option * to itcl_hull } widgetadaptor mylabel2 { constructor {args} { installhull [mylabel $self] $self configure {*}$args } method method2 {} { return "method2: [$itcl_hull method1]" } delegate option * to itcl_hull } mylabel2 .label -text "Some Text" set a [.label method2] set b [.label cget -text] .label configure -text "More Text" set c [.label cget -text] set d [lsort [namespace children ::itcl::internal::variables]] destroy .label set e [lsort [namespace children ::itcl::internal::variables]] mylabel2 destroy mylabel destroy tkbide list $a $b $c $d $e } -result {{method2: method1} {Some Text} {More Text} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo}} test widgetadaptor-1.17 {snit::widgetadaptor as hull; use rename } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] $self configure {*}$args } method method1 {} { return "method1" } delegate option * to itcl_hull } widgetadaptor mylabel2 { constructor {args} { installhull [mylabel $self] $self configure {*}$args } method method2 {} { return "method2: [$itcl_hull method1]" } delegate option * to itcl_hull } mylabel2 .label -text "Some Text" set a [.label method2] set b [.label cget -text] .label configure -text "More Text" set c [.label cget -text] set d [lsort [namespace children ::itcl::internal::variables]] rename .label "" set e [lsort [namespace children ::itcl::internal::variables]] mylabel2 destroy mylabel destroy tkbide list $a $b $c $d $e } -result {{method2: method1} {Some Text} {More Text} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo} {::itcl::internal::variables::mylabel ::itcl::internal::variables::mylabel2 ::itcl::internal::variables::oo}} test widgetadaptor-1.19 {error in widgetadaptor constructor } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { error "Simulated Error" } } mylabel .lab } -returnCodes { error } -cleanup { mylabel destroy } -result {Simulated Error} test install-1.3 {can't install until hull exists } -constraints { tk } -body { widgetadaptor myframe { # Delegate an option just to make sure the component variable # exists. delegate option -font to text constructor {args} { installcomponent text using text $win.text -background green } } myframe .frm } -returnCodes { error } -cleanup { myframe destroy } -result {cannot install "text" before "itcl_hull" exists} test installhull-1.3 { options delegated to a widgetadaptor's itcl_hull frame with the same name are initialized from the option database. Note that there's no explicit code in Snit to do this; there's no way to change the adapted hull widget's -class, so the widget is simply being initialized normally. } -constraints { tk } -body { widgetadaptor myframe { delegate option -background to itcl_hull typeconstructor { option add *Frame.background red option add *Frame.width 123 } constructor {args} { installhull using frame } method getwid {} { $itcl_hull cget -width } } myframe .frm set a [.frm cget -background] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {red 123} test installhull-1.4 { Options delegated to a widget's itcl_hull frame with a different name are initialized from the option database. } -constraints { tk } -body { widgetadaptor myframe { delegate option -mainbackground to itcl_hull as -background typeconstructor { option add *Frame.mainbackground red } constructor {args} { installhull using frame } } myframe .frm set a [.frm cget -mainbackground] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {red} test installhull-1.5 { Option values read from the option database are overridden by options explicitly passed, even if delegated under a different name. } -constraints { tk } -body { widgetadaptor myframe { delegate option -mainbackground to itcl_hull as -background typeconstructor { option add *Frame.mainbackground red option add *Frame.width 123 } constructor {args} { installhull using frame -background green -width 321 } method getwid {} { $itcl_hull cget -width } } myframe .frm set a [.frm cget -mainbackground] set b [.frm getwid] destroy .frm tkbide list $a $b } -cleanup { myframe destroy } -result {green 321} test option-2.5 {configure returns info, unknown options } -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option -width to itcl_hull delegate option * to itcl_hull constructor {args} { # need to reset because of test installhull-1.5 option add *Frame.width 0 installhull [frame $self] } } myframe .frm set a [.frm configure -foo] set b [.frm configure -width] set c [.frm configure -height] destroy .frm tkbide list $a $b $c } -cleanup { myframe destroy } -result {{-foo foo Foo a a} {-width width Width 0 0} {-height height Height 0 0}} test option-2.6 {configure -opt unknown to implicit component } -constraints { tk } -body { widgetadaptor myframe { delegate option * to itcl_hull constructor {args} { installhull [frame $self] } } myframe .frm catch {.frm configure -quux} result destroy .frm tkbide set result } -cleanup { myframe destroy } -result {unknown option "-quux"} test iinfo-6.5 {info options with unknown delegated options } -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to itcl_hull constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {-background -bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} test iinfo-6.7 {info options with exceptions } -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to itcl_hull except -background constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {-bd -bg -borderwidth -class -colormap -container -cursor -foo -height -highlightbackground -highlightcolor -highlightthickness -padx -pady -relief -takefocus -visual -width} test iinfo-6.8 {info options with pattern } -constraints { tk } -body { widgetadaptor myframe { option -foo a delegate option * to itcl_hull constructor {args} { installhull [frame $self] } } myframe .frm set a [lsort [.frm info options -c*]] destroy .frm tkbide set a } -cleanup { myframe destroy } -result {-class -colormap -container -cursor} test tinfo-3.2 {widget info instances } -constraints { tk } -body { widgetadaptor mylabel { constructor {args} { installhull [label $self] } } mylabel .lab1 mylabel .lab2 set result [mylabel info instances] destroy .lab1 destroy .lab2 tkbide lsort $result } -cleanup { mylabel destroy } -result {.lab1 .lab2} test widgetclass-1.2 {can't set widgetclass for itcl::widgetadaptors } -constraints { tk } -body { widgetadaptor dog { widgetclass Dog } } -returnCodes { error } -result {can't set widgetclass for ::itcl::widgetadaptor} test hulltype-1.2 {can't set hulltype for itcl::widgetadaptors } -constraints { tk } -body { widgetadaptor dog { hulltype Dog } } -returnCodes { error } -result {can't set hulltype for ::itcl::widgetadaptor} test wainfo-10.1 {widgetadaptor info widgetadaptors } -constraints { tk } -body { widgetadaptor dog { } widgetadaptor cat { } lsort [dog info widgetadaptors] } -cleanup { dog destroy cat destroy } -result {cat dog} test wainfo-10.2 {widgetadaptor info components } -constraints { tk } -body { widgetadaptor dog { component comp1 component comp2 } widgetadaptor cat { component comp1 component comp1a } set a [lsort [dog info components]] set b [lsort [cat info components]] list $a $b } -cleanup { dog destroy cat destroy } -result {{comp1 comp2 itcl_hull} {comp1 comp1a itcl_hull}} #--------------------------------------------------------------------- # Clean up ::tcltest::cleanupTests return itcl4.2.2/tests/typevariable.test0000644003604700454610000001633514137636151015541 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typefunction.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type #----------------------------------------------------------------------- # Type variables test typevariable-1.2 {undefined typevariables are OK} -body { type dog { typevariable theValue method tset {value} { set theValue $value } method tget {} { return $theValue } } dog create spot dog create fido spot tset Howdy list [spot tget] [fido tget] [set ::dog::theValue] } -cleanup { dog destroy } -result {Howdy Howdy Howdy} test typevariable-1.3 {predefined typevariables are OK} -body { type dog { typevariable greeting Hello method tget {} { return $greeting } } dog create spot dog create fido list [spot tget] [fido tget] ;# FIXME [set ::dog::greeting] } -cleanup { dog destroy } -result {Hello Hello} test typevariable-1.4 {typevariables can be arrays} -body { type dog { typevariable greetings method fill {} { set greetings(a) Hi set greetings(b) Howdy } } dog create spot spot fill list $::dog::greetings(a) $::dog::greetings(b) } -cleanup { dog destroy } -result {Hi Howdy} test typevariable-1.5 {typevariables can used in typemethods} -body { type dog { typevariable greetings Howdy typemethod greet {} { return $greetings } } dog greet } -cleanup { dog destroy } -result {Howdy} test typevariable-1.6 {typevariables can used in procs} -body { type dog { typevariable greetings Howdy method greet {} { return [realGreet] } proc realGreet {} { return $greetings } } dog create spot spot greet } -cleanup { dog destroy } -result {Howdy} test typevariable-1.7 {mytypevar qualifies typevariables} -body { type dog { method tvname {name} { mytypevar $name } } dog create spot spot tvname myvar } -cleanup { dog destroy } -result {::dog::myvar} test typevariable-1.8 {typevariable with too many initializers throws an error} -body { type dog { typevariable color dark brown } } -returnCodes { error } -result {wrong # args: should be "typevariable varname ?init?"} test typevariable-1.9 {typevariable with too many initializers throws an error} -body { type dog { typevariable color -array dark brown } set result } -returnCodes { error } -result {wrong # args: should be "typevariable varname ?init|-array init?"} test typevariable-1.10 {typevariable can initialize array variables} -body { type dog { typevariable data -array { family jones color brown } typemethod getdata {item} { return $data($item) } } list [dog getdata family] [dog getdata color] } -cleanup { dog destroy } -result {jones brown} #----------------------------------------------------------------------- # instance variable test ivariable-1.1 {myvar qualifies instance variables} -body { type dog { method vname {name} { myvar $name } } dog create spot spot vname somevar } -cleanup { dog destroy } -match glob -result {::itcl::internal::variables::*::dog::somevar} test ivariable-1.2 {undefined instance variables are OK} -body { type dog { variable greeting method setgreeting {value} { set greeting $value } method getgreeting {} { return $greeting } } set spot [dog create spot] spot setgreeting Hey dog create fido fido setgreeting Howdy list [spot getgreeting] [fido getgreeting] [set ::itcl::internal::variables[info object namespace spot]::dog::greeting] } -cleanup { dog destroy } -result {Hey Howdy Hey} test ivariable-1.3 {instance variables are destroyed automatically} -body { type dog { variable greeting constructor {args} { set greeting Hi } } dog create spot set ns [info object namespace spot] set g1 [set ::itcl::internal::variables${ns}::dog::greeting] spot destroy list $g1 [info exists ::itcl::internal::variables${ns}::dog::greeting] } -cleanup { dog destroy } -result {Hi 0} test ivariable-1.4 {defined instance variables need not be declared} -body { type dog { variable greetings method put {} { set greetings Howdy } method get {} { return $greetings } } dog create spot spot put spot get } -cleanup { dog destroy } -result {Howdy} test ivariable-1.5 {instance variables can be arrays} -body { type dog { variable greetings method fill {} { set greetings(a) Hi set greetings(b) Howdy } method vname {} { return [myvar greetings] } } dog create spot spot fill list [set [spot vname](a)] [set [spot vname](b)] } -cleanup { dog destroy } -result {Hi Howdy} test ivariable-1.6 {instance variables can be initialized in the definition} -body { type dog { variable greetings {Hi Howdy} variable empty {} method list {} { list $greetings $empty } } dog create spot spot list } -cleanup { dog destroy } -result {{Hi Howdy} {}} test ivariable-1.9 {procs which define selfns see instance variables} -body { type dog { variable greeting Howdy method caller {} { return [callee $selfns] } proc callee {selfns} { return [set ${selfns}::greeting] } } dog create spot spot caller } -cleanup { dog destroy } -result {Howdy} test ivariable-1.11 {variable with too many initializers throws an error} -body { type dog { variable color dark brown } } -returnCodes { error } -result {wrong # args: should be "variable name ?init?"} test ivariable-1.12 {variable with too many initializers throws an error} -body { type dog { variable color -array dark brown } } -returnCodes { error } -result {wrong # args: should be "variable varname ?init|-array init?"} test ivariable-1.13 {variable can initialize array variables} -body { type dog { variable data -array { family jones color brown } method getdata {item} { return $data($item) } } dog spot list [spot getdata family] [spot getdata color] } -cleanup { dog destroy } -result {jones brown} #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/typeoption.test0000644003604700454610000002744114137636151015264 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typeoption.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type #----------------------------------------------------------------------- # Options test option-1.1 {options get default values} -body { type dog { option -color golden } dog create spot spot cget -color } -cleanup { dog destroy } -result {golden} test option-1.2 {options can be set} -body { type dog { option -color golden } dog create spot spot configure -color black spot cget -color } -cleanup { dog destroy } -result {black} test option-1.3 {multiple options can be set} -body { type dog { option -color golden option -akc 0 } dog create spot spot configure -color brown -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {brown 1} test option-1.4 {options can be retrieved as instance variable} -body { type dog { option -color golden option -akc 0 method listopts {} { list $itcl_options(-color) $itcl_options(-akc) } } dog create spot spot configure -color black -akc 1 spot listopts } -cleanup { dog destroy } -result {black 1} test option-1.5 {options can be set as an instance variable} -body { type dog { option -color golden option -akc 0 method setopts {} { set itcl_options(-color) black set itcl_options(-akc) 1 } } dog create spot spot setopts list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {black 1} test option-1.6 {options can be set at creation time} -body { type dog { option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {white 1} test option-1.7 {undefined option: cget} -body { type dog { option -color golden option -akc 0 } dog create spot spot cget -colour } -returnCodes { error } -cleanup { dog destroy } -result {unknown option "-colour"} test option-1.8 {undefined option: configure} -body { type dog { option -color golden option -akc 0 } dog create spot spot configure -colour blue } -returnCodes { error } -cleanup { dog destroy } -result {unknown option "-colour"} test option-1.9 {options default to ""} -body { type dog { option -color } dog create spot spot cget -color } -cleanup { dog destroy } -result {} test option-1.10 {spaces allowed in option defaults} -body { type dog { option -breed "golden retriever" } dog fido fido cget -breed } -cleanup { dog destroy } -result {golden retriever} test option-1.11 {brackets allowed in option defaults} -body { type dog { option -regexp {[a-z]+} } dog fido fido cget -regexp } -cleanup { dog destroy } -result {[a-z]+} test option-2.1 {configure returns info, local options only} -body { type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -akc 0 lsort [spot configure] } -cleanup { dog destroy } -result {{-akc akc Akc 1 0} {-color color Color black red}} test option-2.2 {configure -opt returns info, local options only} -body { type dog { option -color black option -akc 1 } dog create spot spot configure -color red spot configure -color } -cleanup { dog destroy } -result {-color color Color black red} test option-2.3 {configure -opt returns info, explicit options} -body { type papers { option -akcflag 1 } type dog { option -color black delegate option -akc to papers as -akcflag constructor {args} { set papers [papers create $self.papers] } destructor { catch {$self.papers destroy} } } dog create spot spot configure -akc 0 spot configure -akc } -cleanup { dog destroy papers destroy } -result {-akc akc Akc 1 0} test option-2.4 {configure -unknownopt} -body { type papers { option -akcflag 1 } type dog { option -color black delegate option -akc to papers as -akcflag constructor {args} { set papers [papers create $self.papers] } destructor { catch {$self.papers destroy} } } dog create spot spot configure -foo } -returnCodes { error } -cleanup { dog destroy papers destroy } -result {unknown option "-foo"} test option-3.1 {set option resource name explicitly} -body { type dog { option {-tailcolor tailColor} black } dog fido fido configure -tailcolor } -cleanup { dog destroy } -result {-tailcolor tailColor TailColor black black} test option-3.2 {set option class name explicitly} -body { type dog { option {-tailcolor tailcolor TailColor} black } dog fido fido configure -tailcolor } -cleanup { dog destroy } -result {-tailcolor tailcolor TailColor black black} test option-3.3 {delegated option's names come from owner} -body { type tail { option -color black } type dog { delegate option -tailcolor to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor Tailcolor black black} test option-3.4 {delegated option's resource name set explicitly} -body { type tail { option -color black } type dog { delegate option {-tailcolor tailColor} to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailColor TailColor black black} test option-3.5 {delegated option's class name set explicitly} -body { type tail { option -color black } type dog { delegate option {-tailcolor tailcolor TailColor} to tail as -color constructor {args} { set tail [tail fidotail] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor TailColor black black} test option-3.6 {delegated option's default comes from component} -body { type tail { option -color black } type dog { delegate option -tailcolor to tail as -color constructor {args} { set tail [tail fidotail -color red] } } dog fido fido configure -tailcolor } -cleanup { dog destroy tail destroy } -result {-tailcolor tailcolor Tailcolor black red} test option-4.1 {local option name must begin with hyphen} -body { type dog { option nohyphen } } -returnCodes { error } -result {bad option name "nohyphen", options must start with a "-"} test option-4.2 {local option name must be lower case} -body { type dog { option -Upper } } -returnCodes { error } -result {bad option name "-Upper" , options must not contain uppercase characters} test option-4.3 {local option name may not contain spaces} -body { type dog { option {"-with space"} } } -returnCodes { error } -result {bad option name "-with space", option names must not contain " "} test option-4.4 {delegated option name must begin with hyphen} -body { type dog { delegate option nohyphen to tail } } -returnCodes { error } -result {bad delegated option name "nohyphen", options must start with a "-"} test option-4.5 {delegated option name must be lower case} -body { type dog { delegate option -Upper to tail } } -returnCodes { error } -result {bad option name "-Upper" , options must not contain uppercase characters} test option-4.6 {delegated option name may not contain spaces} -body { type dog { delegate option {"-with space"} to tail } } -returnCodes { error } -result {bad option name "-with space", option names must not contain " "} test option-6.1a {itcl_options variable is always there} -body { type dog { variable dummy } dog spot spot info vars itcl_options } -cleanup { dog destroy } -result {itcl_options} test option-6.2 {if no options, no options methods} -body { type dog { variable dummy } dog spot spot info methods c* } -cleanup { dog destroy } -result {} #----------------------------------------------------------------------- # option -validatemethod test validatemethod-1.1 {Validate method is called} -body { type dog { variable flag 0 option -color \ -default black \ -validatemethod ValidateColor method ValidateColor {option value} { set flag 1 } method getflag {} { return $flag } } dog fido -color brown fido getflag } -cleanup { dog destroy } -result {1} test validatemethod-1.2 {Validate method gets correct arguments} -body { type dog { option -color \ -default black \ -validatemethod ValidateColor method ValidateColor {option value} { if {![string equal $option "-color"] || ![string equal $value "brown"]} { error "Expected '-color brown'" } } } dog fido -color brown } -cleanup { dog destroy } -result {::fido} test validatemethod-1.4 {Invalid -validatemethod causes error} -body { type dog { option -foo -default bar -validatemethod bogus } dog fido fido configure -foo quux } -returnCodes { error } -cleanup { dog destroy } -result {invalid command name "bogus"} test validatemethod-1.5 {hierarchical -validatemethod} -body { type dog { option -foo -default bar -validatemethod {Val Opt} method {Val Opt} {option value} { error "Dummy" } } dog fido -foo value } -returnCodes { error } -cleanup { dog destroy } -result {Dummy} #----------------------------------------------------------------------- # option -readonly semantics test optionreadonly-1.1 {Readonly options can be set at creation time} -body { type dog { option -color \ -default black \ -readonly true } dog fido -color brown fido cget -color } -cleanup { dog destroy } -result {brown} test optionreadonly-1.2 {Readonly options can't be set after creation} -body { type dog { option -color \ -default black \ -readonly true } dog fido fido configure -color brown } -returnCodes { error } -cleanup { dog destroy } -result {option "-color" can only be set at instance creation} test optionreadonly-1.3 {Readonly options can't be set after creation} -body { type dog { option -color \ -default black \ -readonly true } dog fido -color yellow fido configure -color brown } -returnCodes { error } -cleanup { dog destroy } -result {option "-color" can only be set at instance creation} #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/typeinfo.test0000644003604700454610000006210314137636151014701 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typeoption.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type loadTestedCommands #----------------------------------------------------------------------- # Instance Introspection test iinfo-1.2 {object info too few args} -body { type dog { } dog create spot spot info } -returnCodes { error } -cleanup { dog destroy } -result {wrong # args: should be one of... info args procname info body procname info component ?name? ?-inherit? ?-value? info components ?pattern? info default method aname varname info delegated ?name? ?-inherit? ?-value? info instances ?pattern? info method ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info methods ?pattern? info options ?pattern? info type info typemethod ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info typemethods ?pattern? info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} test iinfo-1.3 {object info too many args} -body { type dog { } dog create spot spot info type foo } -returnCodes { error } -cleanup { dog destroy } -result {wrong # args: should be "info type"} test iinfo-2.1 {object info type} -body { type dog { } dog create spot spot info type } -cleanup { dog destroy } -result {::dog} test iinfo-3.1 {object info typevars} -body { type dog { typevariable thisvar 1 typevariable thatvar 2 constructor {args} { } } dog create spot lsort [spot info typevars] } -cleanup { dog destroy } -result {::dog::thatvar ::dog::thisvar} test iinfo-3.2 {object info typevars with pattern} -body { type dog { typevariable thisvar 1 typevariable thatvar 2 constructor {args} { } } dog create spot spot info typevars *this* } -cleanup { dog destroy } -result {::dog::thisvar} test iinfo-3.1a {object info typevarable} -body { type dog { typevariable thisvar 1 typevariable thatvar 2 constructor {args} { } } dog create spot spot info typevariable thatvar -name -protection -type -init -value } -cleanup { dog destroy } -result {::dog::thatvar public common 2 2} test iinfo-4.1 {object info vars} -body { type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot lsort [spot info vars] } -cleanup { dog destroy } -result {hisvar itcl_options} test iinfo-4.2 {object info vars with pattern} -body { type dog { variable hisvar 1 constructor {args} { variable hervar set hervar 2 } } dog create spot spot info vars "*his*" } -cleanup { dog destroy } -result {hisvar itcl_options} test iinfo-5.1 {object info no vars defined besides itcl_options} -body { type dog { } dog create spot list [spot info vars] [spot info typevars] } -cleanup { dog destroy } -result {itcl_options {}} test iinfo-6.1 {info options with no options} -body { type dog { } dog create spot llength [spot info options] } -cleanup { dog destroy } -result {0} test iinfo-6.2 {info options with only local options} -body { type dog { option -foo a option -bar b } dog create spot lsort [spot info options] } -cleanup { dog destroy } -result {-bar -foo} test iinfo-6.3 {info options with local and delegated options} -body { type dog { option -foo a option -bar b delegate option -quux to sibling } dog create spot lsort [spot info options] } -cleanup { dog destroy } -result {-bar -foo -quux} test iinfo-6.3a {info option} -body { type dog { option -foo a option -bar b delegate option -quux to sibling } dog create spot lsort [spot info option] } -cleanup { dog destroy } -result {-bar -foo} test iinfo-6.3b {info option with options} -body { type dog { option -foo -cgetmethod xx -configuremethodvar yy -default a option -bar b delegate option -quux to sibling } dog create spot spot info option -foo } -cleanup { dog destroy } -result {protected ::dog::-foo foo Foo a xx {} {} yy} test iinfo-7.1 {info typemethods, simple case} -body { type dog { } dog spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {create destroy info} test iinfo-7.2 {info typemethods, with pattern} -body { type dog { } dog spot spot info typemethods i* } -cleanup { dog destroy } -result {info} test iinfo-7.3 {info typemethods, with explicit typemethods} -body { type dog { typemethod foo {} {} typeconstructor { set comp string } delegate typemethod bar to comp } dog spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {bar create destroy foo info} test iinfo-7.4 {info typemethods, with implicit typemethods} -body { type dog { delegate typemethod * to comp typeconstructor { set comp string } } dog create spot set a [lsort [spot info typemethods]] dog length foo dog is boolean yes set b [lsort [spot info typemethods]] set c [spot info typemethods len*] list $a $b $c } -cleanup { dog destroy } -result {{create destroy info} {create destroy info is length} length} test iinfo-7.5 {info typemethods, with hierarchical typemethods} -body { type dog { delegate typemethod {comp foo} to comp typeconstructor { set comp string } typemethod {comp bar} {} {} } dog create spot lsort [spot info typemethods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} create destroy info} test iinfo-7.5a {info typemethod} -body { type dog { typemethod tail {args} { set a b } } dog create spot lsort [spot info typemethod] } -cleanup { dog destroy } -result {::dog::tail} test iinfo-7.5b {info typemethod with options} -body { type dog { typemethod tail {args} { set a b } } dog create spot spot info typemethod tail -name -protection -args -body -type } -cleanup { dog destroy } -result {::dog::tail public {?arg arg ...?} { set a b } typemethod} test iinfo-8.1 {info methods, simple case} -body { type dog { } dog spot lsort [spot info methods] } -cleanup { dog destroy } -result {destroy info} test iinfo-8.2 {info methods, with pattern} -body { type dog { } dog spot spot info methods i* } -cleanup { dog destroy } -result {info} test iinfo-8.1a {info method} -body { type dog { method tail {args} { set a b } } dog spot lsort [spot info method] } -cleanup { dog destroy } -result {::dog::callinstance ::dog::cget ::dog::configure ::dog::destroy ::dog::getinstancevar ::dog::info ::dog::isa ::dog::mymethod ::dog::myproc ::dog::mytypemethod ::dog::mytypevar ::dog::myvar ::dog::tail ::dog::unknown} test iinfo-8.1b {info method with options} -body { type dog { method tail {args} { set a b } } dog spot spot info method tail -name -protection -args -body -type } -cleanup { dog destroy } -result {::dog::tail public {?arg arg ...?} { set a b } method} test iinfo-8.3 {info methods, with explicit methods} -body { type dog { method foo {} {} typeconstructor { set comp string } delegate method bar to comp } dog spot lsort [spot info methods] } -cleanup { dog destroy } -result {bar destroy foo info} test iinfo-8.4 {info methods, with implicit methods} -body { type dog { delegate method * to comp constructor {args} { set comp string } } dog create spot set a [lsort [spot info methods]] spot length foo spot is boolean yes set b [lsort [spot info methods]] set c [spot info methods len*] list $a $b $c } -cleanup { dog destroy } -result {{destroy info} {destroy info is length} length} test iinfo-8.5 {info methods, with hierarchical methods} -body { type dog { delegate method {comp foo} to comp constructor {args} { set comp string } method {comp bar} {} {} } dog create spot lsort [spot info methods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} destroy info} test iinfo-9.1 {info args} -body { type dog { method bark {volume} {} } dog spot spot info args bark } -cleanup { dog destroy } -result {volume} test iinfo-9.2 {info args, too few args} -body { type dog { method bark {volume} {} } dog spot spot info args } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info args method"} test iinfo-9.3 {info args, too many args} -body { type dog { method bark {volume} {} } dog spot spot info args bark wag } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info args method"} test iinfo-9.4 {info args, unknown method} -body { type dog { } dog spot spot info args bark } -returnCodes error -cleanup { dog destroy } -result {"bark" isn't a method} test iinfo-9.5 {info args, delegated method} -body { type dog { component x typeconstructor { set x string } delegate method bark to x } dog spot spot info args bark } -returnCodes error -cleanup { dog destroy } -result {delegated method "bark"} test iinfo-10.1 {info default} -body { type dog { method bark {{volume 50}} {} } dog spot list [spot info default bark volume def] $def } -cleanup { dog destroy } -result {1 50} test iinfo-10.2 {info default, too few args} -body { type dog { method bark {volume} {} } dog spot spot info default } -returnCodes error -cleanup { dog destroy } -result {wrong # args, should be info default } test iinfo-10.3 {info default, too many args} -body { type dog { method bark {volume} {} } dog spot spot info default bark wag def foo } -returnCodes error -cleanup { dog destroy } -result {wrong # args, should be info default } test iinfo-10.4 {info default, unknown method} -body { type dog { } dog spot spot info default bark x var } -returnCodes error -cleanup { dog destroy } -result {unknown method "bark"} test iinfo-10.5 {info default, delegated method} -body { type dog { component x typeconstructor { set x string } delegate method bark to x } dog spot spot info default bark x var } -returnCodes error -cleanup { dog destroy } -result {delegated method "bark"} test iinfo-11.1 {info body} -body { type dog { typevariable x variable y method bark {volume} { speaker on speaker play bark.snd speaker off } } dog spot spot info body bark } -cleanup { dog destroy } -result { speaker on speaker play bark.snd speaker off } test iinfo-11.2 {info body, too few args} -body { type dog { method bark {volume} {} } dog spot spot info body } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info body method"} test iinfo-11.3 {info body, too many args} -body { type dog { method bark {volume} {} } dog spot spot info body bark wag } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info body method"} test iinfo-11.4 {info body, unknown method} -body { type dog { } dog spot spot info body bark } -returnCodes error -cleanup { dog destroy } -result {"bark" isn't a method} test iinfo-11.5 {info body, delegated method} -body { type dog { component x typeconstructor { set x string } delegate method bark to x } dog spot spot info body bark } -returnCodes error -cleanup { dog destroy } -result {delegated method "bark"} #----------------------------------------------------------------------- # Type Introspection test tinfo-1.2 {type info too few args} -body { type dog { } dog info } -returnCodes { error } -cleanup { dog destroy } -result {wrong # args: should be one of... info args procname info body procname info component ?name? ?-inherit? ?-value? info components ?pattern? info default method aname varname info delegated ?name? ?-inherit? ?-value? info instances ?pattern? info method ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info methods ?pattern? info options ?pattern? info type info typemethod ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info typemethods ?pattern? info types ?pattern? info typevariable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? info typevars ?pattern? info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? info variables ?pattern? ...and others described on the man page} test tinfo-1.3 {type info too many args} -body { type dog { } dog info instances foo bar } -returnCodes { error } -cleanup { dog destroy } -result {wrong # args should be: info instances ?pattern?} test tinfo-2.1 {type info typevars} -body { type dog { typevariable thisvar 1 typevariable thatvar 2 constructor {args} { } } dog create spot lsort [dog info typevars] } -cleanup { dog destroy } -result {::dog::thatvar ::dog::thisvar} test tinfo-3.1 {type info instances} -body { type dog { } dog create spot dog create fido lsort [dog info instances] } -cleanup { dog destroy } -result {::fido ::spot} test tinfo-3.3 {type info instances with non-global namespaces} -body { type dog { } dog create ::spot namespace eval ::dogs:: { set ::qname [dog create fido] } list $qname [lsort [dog info instances]] } -cleanup { dog destroy } -result {::dogs::fido {::dogs::fido ::spot}} test tinfo-3.4 {type info instances with pattern} -body { type dog { } dog create spot dog create fido dog info instances "*f*" } -cleanup { dog destroy } -result {::fido} test tinfo-4.1 {type info typevars with pattern} -body { type dog { typevariable thisvar 1 typevariable thatvar 2 constructor {args} { } } dog create spot dog info typevars *this* } -cleanup { dog destroy } -result {::dog::thisvar} test tinfo-5.1 {type info typemethods, simple case} -body { type dog { } lsort [dog info typemethods] } -cleanup { dog destroy } -result {create destroy info} test tinfo-5.2 {type info typemethods, with pattern} -body { type dog { } dog info typemethods i* } -cleanup { dog destroy } -result {info} test tinfo-5.3 {type info typemethods, with explicit typemethods} -body { type dog { typemethod foo {} {} typeconstructor { set comp string } delegate typemethod bar to comp } lsort [dog info typemethods] } -cleanup { dog destroy } -result {bar create destroy foo info} test tinfo-5.4 {type info typemethods, with implicit typemethods} -body { type dog { delegate typemethod * to comp typeconstructor { set comp string } } set a [lsort [dog info typemethods]] dog length foo dog is boolean yes set b [lsort [dog info typemethods]] set c [dog info typemethods len*] list $a $b $c } -cleanup { dog destroy } -result {{create destroy info} {create destroy info is length} length} test tinfo-5.5 {info typemethods, with hierarchical typemethods} -body { type dog { delegate typemethod {comp foo} to comp typeconstructor { set comp string } typemethod {comp bar} {} {} } lsort [dog info typemethods] } -cleanup { dog destroy } -result {{comp bar} {comp foo} create destroy info} test tinfo-6.1 {type info args} -body { type dog { typemethod bark {volume} {} } dog info args bark } -cleanup { dog destroy } -result {volume} test tinfo-6.2 {type info args, too few args} -body { type dog { typemethod bark {volume} {} } dog info args } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info args method"} test tinfo-6.3 {type info args, too many args} -body { type dog { typemethod bark {volume} {} } dog info args bark wag } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info args method"} test tinfo-6.4 {type info args, unknown method} -body { type dog { } dog info args bark } -returnCodes error -cleanup { dog destroy } -result {"bark" isn't a method} test tinfo-6.5 {type info args, delegated method} -body { type dog { typeconstructor { set x string } delegate typemethod bark to x } dog info args bark } -returnCodes error -cleanup { dog destroy } -result {delegated typemethod "bark"} test tinfo-7.1 {type info default} -body { type dog { typemethod bark {{volume 50}} {} } list [dog info default bark volume def] $def } -cleanup { dog destroy } -result {1 50} test tinfo-7.2 {type info default, too few args} -body { type dog { typemethod bark {volume} {} } dog info default } -returnCodes error -cleanup { dog destroy } -result {wrong # args, should be info default } test tinfo-7.3 {type info default, too many args} -body { type dog { typemethod bark {volume} {} } dog info default bark wag def foo } -returnCodes error -cleanup { dog destroy } -result {wrong # args, should be info default } test tinfo-7.4 {type info default, unknown method} -body { type dog { } dog info default bark x var } -returnCodes error -cleanup { dog destroy } -result {unknown method "bark"} test tinfo-7.5 {type info default, delegated method} -body { type dog { typeconstructor { set x string } delegate typemethod bark to x } dog info default bark x var } -returnCodes error -cleanup { dog destroy } -result {delegated typemethod "bark"} test tinfo-8.1 {type info body} -body { type dog { typevariable x variable y typemethod bark {volume} { speaker on speaker play bark.snd speaker off } } dog info body bark } -cleanup { dog destroy } -result { speaker on speaker play bark.snd speaker off } test tinfo-8.2 {type info body, too few args} -body { type dog { typemethod bark {volume} {} } dog info body } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info body method"} test tinfo-8.3 {type info body, too many args} -body { type dog { typemethod bark {volume} {} } dog info body bark wag } -returnCodes error -cleanup { dog destroy } -result {wrong # args: should be "info body method"} test tinfo-8.4 {type info body, unknown method} -body { type dog { } dog info body bark } -returnCodes error -cleanup { dog destroy } -result {"bark" isn't a method} test tinfo-8.5 {type info body, delegated method} -body { type dog { typeconstructor { set x string } delegate typemethod bark to x } dog info body bark } -returnCodes { error } -cleanup { dog destroy } -result {delegated typemethod "bark"} test tinfo-10.1 {type info types} -body { type dog { } type cat { } lsort [dog info types] } -cleanup { dog destroy cat destroy } -result {cat dog} test tinfo-10.2 {type info components} -body { type dog { component comp1 component comp2 } type cat { component comp1 component comp1a } set a [lsort [dog info components]] set b [lsort [cat info components]] list $a $b } -cleanup { dog destroy cat destroy } -result {{comp1 comp2} {comp1 comp1a}} test tinfo-10.2a {type info component} -body { type dog { component comp1 component comp2 } type cat { component comp1 component comp1a } set a [lsort [dog info component]] set b [lsort [cat info component]] list $a $b } -cleanup { dog destroy cat destroy } -result {{::dog::comp1 ::dog::comp2} {::cat::comp1 ::cat::comp1a}} test tinfo-10.2b {type info component with options} -body { type dog { component comp1 component comp2 } dog info component comp1 -name -inherit } -cleanup { dog destroy } -result {::dog::comp1 0} test tinfo-10.4 {type info delegated methods} -body { type dog { } dog info delegated xxx } -returnCodes { error } -cleanup { dog destroy } -result {wrong # args: should be one of... info methods ?pattern? info typemethods ?pattern? info options ?pattern? ...and others described on the man page} test tinfo-10.5 {type info delegated methods} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } lsort [dog info delegated methods] } -cleanup { dog destroy } -result {{tail comp2} {wag comp1}} test tinfo-10.5a {type info delegated method} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } lsort [dog info delegated method] } -cleanup { dog destroy } -result {tail wag} test tinfo-10.5b {type info delegated method with options} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } dog info delegated method wag -name -component -using -as -exceptions } -cleanup { dog destroy } -result {wag comp1 {} {} {}} test tinfo-10.5c {type info delegated typemethod} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } lsort [dog info delegated typemethod] } -cleanup { dog destroy } -result {typetail typewag} test tinfo-10.5d {type info delegated typemethod with options} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } dog info delegated typemethod typewag -name -component -using -as -exceptions } -cleanup { dog destroy } -result {typewag comp1 {} {} {}} test tinfo-10.6 {type info delegated typemethods} -body { type dog { component comp1 component comp2 delegate method wag to comp1 delegate method tail to comp2 delegate typemethod typewag to comp1 delegate typemethod typetail to comp2 typeconstructor { set comp1 string set comp2 string } } lsort [dog info delegated typemethods] } -cleanup { dog destroy } -result {{typetail comp2} {typewag comp1}} test tinfo-10.7 {type info delegated options} -body { type dog { component comp1 component comp2 component comp3 delegate option -foo to comp1 delegate option -bar to comp2 delegate option * to comp3 typeconstructor { set comp1 string set comp2 string set comp3 string } } lsort [dog info delegated options] } -cleanup { dog destroy } -result {{* comp3} {-bar comp2} {-foo comp1}} test tinfo-11.1 {type info type} -body { type dog { typeconstructor { } } dog info type } -cleanup { dog destroy } -result {::dog} #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/typefunction.test0000644003604700454610000001720214137636151015573 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typefunction.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type #----------------------------------------------------------------------- # procs test proc-1.1 {proc args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { proc foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #----------------------------------------------------------------------- # methods test method-1.1 {methods get called} -body { type dog { method bark {} { return "$self barks" } } dog create spot spot bark } -cleanup { dog destroy } -result {::spot barks} test method-1.2 {methods can call other methods} -body { type dog { method bark {} { return "$self barks." } method chase {quarry} { return "$self chases $quarry; [$self bark]" } } dog create spot spot chase cat } -cleanup { dog destroy } -result {::spot chases cat; ::spot barks.} test method-1.3 {instances can call one another} -body { type dog { method bark {} { return "$self barks." } method chase {quarry} { return "$self chases $quarry; [$quarry bark] [$self bark]" } } dog create spot dog create fido spot chase ::fido } -cleanup { dog destroy } -result {::spot chases ::fido; ::fido barks. ::spot barks.} test method-1.4 {upvar works in methods} -body { type dog { method goodname {varname} { upvar $varname myvar set myvar spot } } dog create fido set thename fido fido goodname thename set thename } -cleanup { dog destroy } -result {spot} test method-1.6 {unknown methods get an error } -body { type dog { } dog create spot set result "" spot chase } -cleanup { dog destroy } -returnCodes { error } -result {bad option "chase": should be one of... spot callinstance spot cget -option spot configure ?-option? ?value -option value...? spot destroy spot getinstancevar spot isa className spot mymethod spot myvar spot unknown} test method-1.7 {info type method returns the object's type} -body { type dog { } dog create spot spot info type } -cleanup { dog destroy } -result {::dog} test method-1.8 {instance method can call type method} -body { type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[$type hello], World!" } } dog create spot spot helloworld } -cleanup { dog destroy } -result {Hello, World!} test method-1.9 {type methods must be qualified} -body { type dog { typemethod hello {} { return "Hello" } method helloworld {} { return "[hello], World!" } } dog create spot spot helloworld } -cleanup { dog destroy } -returnCodes { error } -result {invalid command name "hello"} test method-1.11 {too few arguments} -body { type dog { method bark {volume} { } } dog create spot spot bark } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot bark volume"} test method-1.13 {too many arguments} -body { type dog { method bark {volume} { } } dog create spot spot bark really loud } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot bark volume"} test method-1.14 {method args can't include type} -body { type dog { method foo {a type b} { } } } -returnCodes { error } -result {method foo's arglist may not contain "type" explicitly} test method-1.15 {method args can't include self} -body { type dog { method foo {a self b} { } } } -returnCodes { error } -result {method foo's arglist may not contain "self" explicitly} test method-1.16 {method args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { method foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #----------------------------------------------------------------------- # mymethod actually works test mymethod-1.1 {run mymethod handler} -body { type foo { option -command {} method runcmd {} { eval [linsert $itcl_options(-command) end $self snarf] return } } type bar { variable sub constructor {args} { set sub [foo fubar -command [mymethod Handler]] return } method Handler {args} { set ::RES $args } method test {} { $sub runcmd return } } set ::RES {} bar boogle boogle test set ::RES } -cleanup { bar destroy foo destroy } -result {::bar::fubar snarf} #----------------------------------------------------------------------- # myproc test myproc-1.1 {myproc qualifies proc names} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo] } } dog getit } -cleanup { dog destroy } -result {::dog::foo} test myproc-1.2 {myproc adds arguments} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b"] } } dog getit } -cleanup { dog destroy } -result {::dog::foo {a b}} test myproc-1.3 {myproc adds arguments} -body { type dog { proc foo {} {} typemethod getit {} { return [myproc foo "a b" c d] } } dog getit } -cleanup { dog destroy } -result {::dog::foo {a b} c d} test myproc-1.4 {procs with selfns work} -body { type dog { variable datum foo method qualify {} { return [myproc getdatum $selfns] } proc getdatum {selfns} { return [set ${selfns}::datum] } } dog create spot eval [spot qualify] } -cleanup { dog destroy } -result {foo} #----------------------------------------------------------------------- # mytypemethod test mytypemethod-1.1 {mytypemethod qualifies typemethods} -body { type dog { typemethod this {} {} typemethod a {} { return [mytypemethod this] } typemethod b {} { return [mytypemethod this x] } typemethod c {} { return [mytypemethod this "x y"] } typemethod d {} { return [mytypemethod this x y] } } list [dog a] [dog b] [dog c] [dog d] } -cleanup { dog destroy } -result {{::dog this} {::dog this x} {::dog this {x y}} {::dog this x y}} #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/typedelegation.test0000644003604700454610000004540714137636151016071 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typefunction.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type proc, method, typemethod commands. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type if {1} { #----------------------------------------------------------------------- # Typemethod delegation test dtypemethod-1.1 {delegate typemethod to non-existent component} -body { set result "" type dog { delegate typemethod foo to bar } dog foo } -returnCodes { error } -result {::dog delegates typemethod "foo" to undefined typecomponent "bar"} test dtypemethod-1.2 {delegating to existing typecomponent} -body { type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} test dtypemethod-1.4 {delegating to existing typecomponent with error} -body { type dog { delegate typemethod length to string typeconstructor { set string string } } dog length foo bar } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "dog length string"} test dtypemethod-1.5 {delegating unknown typemethods to existing typecomponent} -body { type dog { delegate typemethod * to string typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} test dtypemethod-1.6a {delegating unknown typemethod to existing typecomponent with error} -body { type dog { delegate typemethod * to stringhandler typeconstructor { set stringhandler string } } dog foo bar } -cleanup { dog destroy } -returnCodes { error } -match glob -result {unknown or ambiguous subcommand "foo": must be *} test dtypemethod-1.7 {can't delegate local typemethod: order 1} -body { type dog { typemethod foo {} {} delegate typemethod foo to bar } } -returnCodes { error } -result {Error in "delegate typemethod foo...", "foo" has been defined locally.} test dtypemethod-1.8 {can't delegate local typemethod: order 2} -body { type dog { delegate typemethod foo to bar typemethod foo {} {} } } -returnCodes { error } -result {Error in "typemethod foo...", "foo" has been delegated} test dtypemethod-1.10 {excepted methods are caught properly} -body { type dog { delegate typemethod * to string except {match index} typeconstructor { set string string } } catch {dog length foo} a catch {dog match foo} b catch {dog index foo} c list $a $b $c } -cleanup { dog destroy } -result {3 {unknown subcommand "match": must be length} {unknown subcommand "index": must be length}} test dtypemethod-1.11 {as clause can include arguments} -body { proc tail {a b} { return "<$a $b>" } type dog { delegate typemethod wag to tail as {wag briskly} typeconstructor { set tail tail } } dog wag } -cleanup { dog destroy rename tail "" } -result {} test dtypemethod-2.1 {'using "%c %m"' gets normal behavior} -body { type dog { delegate typemethod length to string using {%c %m} typeconstructor { set string string } } dog length foo } -cleanup { dog destroy } -result {3} test dtypemethod-2.2 {All relevant 'using' conversions are converted} -body { proc echo {args} { return $args } type dog { delegate typemethod tail using {echo %% %t %M %m %j %n %w %s %c} } dog tail } -cleanup { dog destroy rename echo "" } -result {% ::dog tail tail tail %n %w %s %c} test dtypemethod-2.3 {"%%" is handled properly} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod wag using {echo %%m %%%m} } dog wag } -cleanup { dog destroy rename echo "" } -result {%m|%wag} test dtypemethod-2.4 {Method "*" and "using"} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod * using {echo %m} } list [dog wag] [dog bark loudly] } -cleanup { dog destroy rename echo "" } -result {wag bark|loudly} test dtypemethod-3.1 {typecomponent names can be changed dynamically} -body { proc echo {args} { join $args "|" } type dog { delegate typemethod length to mycomp typeconstructor { set mycomp string } typemethod switchit {} { set mycomp echo } } set a [dog length foo] dog switchit set b [dog length foo] list $a $b } -cleanup { dog destroy rename echo "" } -result {3 length|foo} test dtypemethod-4.4 {redefinition is OK} -body { type wag { method tail {} {return "wags tail"} method briskly {} {return "wags tail briskly"} } type dog { typeconstructor { set wag [wag #auto] } delegate typemethod tail to wag as tail delegate typemethod tail to wag as briskly } dog tail } -cleanup { dog destroy wag destroy } -result {wags tail briskly} #----------------------------------------------------------------------- # delegate: general syntax tests test delegate-1.1 {can only delegate methods or options} -body { type dog { delegate foo bar to baz } } -returnCodes { error } -result {bad option "foo": should be one of... delegate method name to targetName as scipt using script delegate option option to targetOption as script delegate typemethod name to targetName as scipt using script} test delegate-1.2 {"to" must appear in the right place} -body { type dog { delegate method foo from bar } } -returnCodes { error } -result {bad option "from" should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} test delegate-1.3 {"as" must have a target} -body { type dog { delegate method foo to bar as } } -returnCodes { error } -result {wrong # args should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} test delegate-1.4 {"as" must have a single target} -body { type dog { delegate method foo to bar as baz quux } } -returnCodes { error } -result {wrong # args should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} test delegate-1.5 {"as" doesn't work with "*"} -body { type dog { delegate method * to hull as foo } } -returnCodes { error } -result {cannot specify "as" with "delegate method *"} test delegate-1.6 {"except" must have a target} -body { type dog { delegate method * to bar except } } -returnCodes { error } -result {wrong # args should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} test delegate-1.7 {"except" must have a single target} -body { type dog { delegate method * to bar except baz quux } } -returnCodes { error } -result {wrong # args should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} test delegate-1.8 {"except" works only with "*"} -body { type dog { delegate method foo to hull except bar } } -returnCodes { error } -result {can only specify "except" with "delegate method *"} test delegate-1.9 {only "as" or "except"} -body { type dog { delegate method foo to bar with quux } } -returnCodes { error } -result {bad option "with" should be delegate method to ?as ? delegate method ?to ? using delegate method * ?to ? ?using ? ?except ?} #----------------------------------------------------------------------- # delegated methods test dmethod-1.1 {delegate method to non-existent component} -body { type dog { delegate method foo to bar } dog create spot spot foo } -returnCodes { error } -cleanup { dog destroy } -result {::dog ::spot delegates method "foo" to undefined component "bar"} test dmethod-1.2 {delegating to existing component} -body { type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo } -cleanup { dog destroy } -result {3} test dmethod-1.4 {delegating to existing component with error} -body { type dog { constructor {args} { set string string } delegate method length to string } dog create spot spot length foo bar } -cleanup { dog destroy } -returnCodes { error } -result {wrong # args: should be "spot length string"} test dmethod-1.5 {delegating unknown methods to existing component} -body { type dog { constructor {args} { set string string } delegate method * to string } dog create spot spot length foo } -cleanup { dog destroy } -result {3} test dmethod-1.6a {delegating unknown method to existing component with error} -body { type dog { constructor {args} { set stringhandler string } delegate method * to stringhandler } dog create spot spot foo bar } -returnCodes { error } -cleanup { dog destroy } -match glob -result {unknown or ambiguous subcommand "foo": must be *} test dmethod-1.7 {can't delegate local method: order 1} -body { type cat { method foo {} {} delegate method foo to hull } } -returnCodes { error } -result {method "foo" has been defined locally} test dmethod-1.8 {can't delegate local method: order 2} -body { type cat { delegate method foo to hull method foo {} {} } } -returnCodes { error } -result {method "foo" has been delegated} test dmethod-1.10 {excepted methods are caught properly} -body { type tail { method wag {} {return "wagged"} method flaunt {} {return "flaunted"} method tuck {} {return "tuck"} } type cat { method meow {} {} delegate method * to tail except {wag tuck} constructor {args} { set tail [tail #auto] } } cat fifi catch {fifi flaunt} a catch {fifi wag} b catch {fifi tuck} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {flaunted {unknown subcommand "wag": must be flaunt} {unknown subcommand "tuck": must be flaunt}} test dmethod-1.11 {as clause can include arguments} -body { type tail { method wag {adverb} {return "wagged $adverb"} } type dog { delegate method wag to tail as {wag briskly} constructor {args} { set tail [tail #auto] } } dog spot spot wag } -cleanup { dog destroy tail destroy } -result {wagged briskly} test dmethod-2.1 {'using "%c %m"' gets normal behavior} -body { type tail { method wag {adverb} {return "wagged $adverb"} } type dog { delegate method wag to tail using {%c %m} constructor {args} { set tail [tail #auto] } } dog spot spot wag briskly } -cleanup { dog destroy tail destroy } -result {wagged briskly} test dmethod-2.3 {"%%" is handled properly} -body { proc echo {args} { join $args "|" } type dog { delegate method wag using {echo %%m %%%m} } dog spot spot wag } -cleanup { dog destroy rename echo "" } -result {%m|%wag} test dmethod-2.4 {Method "*" and "using"} -body { proc echo {args} { join $args "|" } type dog { delegate method * using {echo %m} } dog spot list [spot wag] [spot bark loudly] } -cleanup { dog destroy rename echo "" } -result {wag bark|loudly} test dmethod-3.1 {component names can be changed dynamically} -body { type tail1 { method wag {} {return "wagged"} } type tail2 { method wag {} {return "drooped"} } type dog { delegate method wag to tail constructor {args} { set tail [tail1 #auto] } method switchit {} { set tail [tail2 #auto] } } dog fido set a [fido wag] fido switchit set b [fido wag] list $a $b } -cleanup { dog destroy tail1 destroy tail2 destroy } -result {wagged drooped} #----------------------------------------------------------------------- # delegated options test doption-1.1 {delegate option to non-existent component} -body { type dog { delegate option -foo to bar } dog create spot spot cget -foo } -returnCodes { error } -cleanup { dog destroy } -result {component "bar" is undefined, needed for option "-foo"} test doption-1.2 {delegating option to existing component: cget} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey } delegate option -color to catthing } dog create spot spot cget -color } -cleanup { dog destroy cat destroy } -result {black} test doption-1.3 {delegating option to existing component: configure} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey $self configure {*}$args } delegate option -color to catthing } dog create spot -color blue list [spot cget -color] [hershey cget -color] } -cleanup { dog destroy cat destroy } -result {blue blue} test doption-1.4 {delegating unknown options to existing component} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey # Note: must do this after components are defined; this # may be a problem. $self configure {*}$args } delegate option * to catthing } dog create spot -color blue list [spot cget -color] [hershey cget -color] } -cleanup { dog destroy cat destroy } -result {blue blue} test doption-1.7 {delegating unknown options to existing component: error} -body { type cat { option -color "black" } cat create hershey type dog { constructor {args} { set catthing ::hershey $self configure {*}$args } delegate option * to catthing } dog create spot -colour blue } -returnCodes { error } -cleanup { dog destroy cat destroy } -result {unknown option "-colour"} test doption-1.8 {can't delegate local option: order 1} -body { type cat { option -color "black" delegate option -color to hull } } -returnCodes { error } -result {option "-color" has been defined locally} test doption-1.9 {can't delegate local option: order 2} -body { type cat { delegate option -color to hull option -color "black" } } -returnCodes { error } -result {cannot define option "-color" locally, it has already been delegated} test doption-1.10 {excepted options are caught properly on cget} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail #auto] } } cat fifi catch {fifi cget -a} a catch {fifi cget -b} b catch {fifi cget -c} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {a {unknown option "-b"} {unknown option "-c"}} test doption-1.11 {excepted options are caught properly on configurelist} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail #auto] } } cat fifi catch {fifi configure {*}{-a 1}} a catch {fifi configure {*}{-b 1}} b catch {fifi configure {*}{-c 1}} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.12 {excepted options are caught properly on configure, 1} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail #auto] } } cat fifi catch {fifi configure -a 1} a catch {fifi configure -b 1} b catch {fifi configure -c 1} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{} {unknown option "-b"} {unknown option "-c"}} test doption-1.13 {excepted options are caught properly on configure, 2} -body { type tail { option -a a option -b b option -c c } type cat { delegate option * to tail except {-b -c} constructor {args} { set tail [tail #auto] } } cat fifi catch {fifi configure -a} a catch {fifi configure -b} b catch {fifi configure -c} c list $a $b $c } -cleanup { cat destroy tail destroy } -result {{-a a A a a} {unknown option "-b"} {unknown option "-c"}} test doption-1.14 {configure query skips excepted options} -body { type tail { option -a a option -b b option -c c } type cat { option -d d delegate option * to tail except {-b -c} constructor {args} { set tail [tail #auto] } } cat fifi fifi configure } -cleanup { cat destroy tail destroy } -result {{-d d D d d} {-a a A a a}} # end } #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/typeclass.test0000644003604700454610000003252714137636151015062 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # typeclass.test # # AUTHOR: # Arnulf Wiedemann with a lot of code from the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::type command. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl interp alias {} type {} ::itcl::type loadTestedCommands #----------------------------------------------------------------------- # type destruction test typedestruction-1.1 {type command is deleted} -body { type dog { } dog destroy info command ::dog } -result {} test typedestruction-1.2 {instance commands are deleted} -body { type dog { } dog create spot dog destroy info command ::spot } -result {} test typedestruction-1.3 {type namespace is deleted} -body { type dog { } dog destroy namespace exists ::dog } -result {0} test typedestruction-1.4 {type proc is destroyed on error} -body { catch {type dog { error "Error creating dog" }} result list [namespace exists ::dog] [info command ::dog] } -result {0 {}} #----------------------------------------------------------------------- # type and typemethods test type-1.1 {type names get qualified} -body { type dog {} } -cleanup { dog destroy } -result {::dog} test type-1.2 {typemethods can be defined} -body { type dog { typemethod foo {a b} { return [list $a $b] } } dog foo 1 2 } -cleanup { dog destroy } -result {1 2} test type-1.3 {upvar works in typemethods} -body { type dog { typemethod goodname {varname} { upvar $varname myvar set myvar spot } } set thename fido dog goodname thename set thename } -cleanup { dog destroy unset thename } -result {spot} test type-1.4 {typemethod args can't include type} -body { type dog { typemethod foo {a type b} { } } } -returnCodes error -result {typemethod foo's arglist may not contain "type" explicitly} test type-1.5 {typemethod args can't include self} -body { type dog { typemethod foo {a self b} { } } } -returnCodes error -result {typemethod foo's arglist may not contain "self" explicitly} test type-1.6 {typemethod args can span multiple lines} -body { # This case caused an error at definition time in 0.9 because the # arguments were included in a comment in the compile script, and # the subsequent lines weren't commented. type dog { typemethod foo { a b } { } } } -cleanup { dog destroy } -result {::dog} #--------------------------------------------------------------------- # typeconstructor test typeconstructor-1.1 {a typeconstructor can be defined} -body { type dog { typevariable a typeconstructor { set a 1 } typemethod aget {} { return $a } } dog aget } -cleanup { dog destroy } -result {1} test typeconstructor-1.2 {only one typeconstructor can be defined} -body { type dog { typevariable a typeconstructor { set a 1 } typeconstructor { set a 2 } } } -returnCodes { error } -result {"typeconstructor" already defined in class "::dog"} test typeconstructor-1.3 {type proc is destroyed on error} -body { catch { type dog { typeconstructor { error "Error creating dog" } } } result list [namespace exists ::dog] [info command ::dog] } -result {0 {}} #----------------------------------------------------------------------- # Type components test typecomponent-1.1 {typecomponent defines typevariable} -body { type dog { typecomponent mycomp typemethod test {} { return $mycomp } } dog test } -cleanup { dog destroy } -result {} test typecomponent-1.4 {typecomponent -inherit yes} -body { type dog { typecomponent mycomp -inherit yes typeconstructor { set mycomp string } } dog length foo } -cleanup { dog destroy } -result {3} #----------------------------------------------------------------------- # type creation test creation-1.1 {type instance names get qualified} -body { type dog { } dog create spot } -cleanup { dog destroy } -result {::spot} test creation-1.2 {type instance names can be generated} -body { type dog { } dog create my#auto } -cleanup { dog destroy } -result {::mydog0} test creation-1.3 {"create" method is optional} -body { type dog { } dog fido } -cleanup { dog destroy } -result {::fido} test creation-1.4 {constructor arg can't be type} -body { type dog { constructor {type} { } } } -returnCodes { error } -result {constructor's arglist may not contain "type" explicitly} test creation-1.5 {constructor arg can't be self} -body { type dog { constructor {self} { } } } -returnCodes { error } -result {constructor's arglist may not contain "self" explicitly} test creation-1.6 {weird names are OK} -body { # I.e., names with non-identifier characters type confused-dog { method meow {} { return "$self meows." } } confused-dog spot spot meow } -cleanup { confused-dog destroy } -result {::spot meows.} #----------------------------------------------------------------------- # renaming test typeclass-rename-1.1 {mymethod uses name of instance name variable} -body { type dog { method mymethod {} { list [mymethod] [mymethod "A B"] [mymethod A B] } } dog fido fido mymethod } -cleanup { dog destroy } -match glob -result {{::itcl::builtin::callinstance *} {::itcl::builtin::callinstance * {A B}} {::itcl::builtin::callinstance * A B}} test typeclass-rename-1.2 {instances can be renamed} -body { type dog { method names {} { list [mymethod] $selfns $win $self } } dog fido set a [fido names] rename fido spot set b [spot names] concat $a $b } -cleanup { dog destroy } -match glob -result {{::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::fido {::itcl::builtin::callinstance *} ::itcl::internal::variables::*::dog fido ::spot} test rename-1.3 {rename to "" deletes an instance} -body { type dog { } dog fido rename fido "" namespace children ::dog } -cleanup { dog destroy } -result {} test rename-1.4 {rename to "" deletes an instance even after a rename} -body { type dog { } dog fido rename fido spot rename spot "" namespace children ::dog } -cleanup { dog destroy } -result {} test rename-1.5 {creating an object twice destroys the first instance} -body { type dog { typemethod x {} {} } dog fido set ns [info object namespace fido] set a [namespace children ::itcl::internal::variables$ns] dog fido set ns [info object namespace fido] set b [namespace children ::itcl::internal::variables$ns] fido destroy set c [namespace which ::itcl::internal::variables$ns] list $a $b $c } -cleanup { dog destroy } -match glob -result {::itcl::internal::variables::*::dog ::itcl::internal::variables::*::dog {}} test typeclass-component-1.1 {component defines variable} -body { type dog { typecomponent mycomp public proc test {} { return $mycomp } } dog fido fido test } -cleanup { fido destroy dog destroy } -result {} test typeclass-component-1.2 {component -inherit} -body { type dog { component mycomp -inherit constructor {} { set mycomp string } } dog fido fido length foo } -cleanup { fido destroy dog destroy } -result {3} test typeclass-component-1.3 {component -inherit can only have one of it} -body { type dogbase { component mycompbase -inherit } type dog { inherit dogbase component mycomp -inherit constructor {} { set mycomp string } } dog fido fido length foo } -cleanup { dog destroy dogbase destroy } -returnCodes { error } -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"} #----------------------------------------------------------------------- # constructor test constructor-1.1 {constructor can do things} -body { type dog { variable a variable b constructor {args} { set a 1 set b 2 } method foo {} { list $a $b } } dog create spot spot foo } -cleanup { dog destroy } -result {1 2} test constructor-1.2 {constructor with no configurelist ignores args} -body { type dog { constructor {args} { } option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {golden 0} test constructor-1.3 {constructor with configurelist gets args} -body { type dog { constructor {args} { $self configure {*}$args } option -color golden option -akc 0 } dog create spot -color white -akc 1 list [spot cget -color] [spot cget -akc] } -cleanup { dog destroy } -result {white 1} test constructor-1.4 {constructor with specific args} -body { type dog { option -value "" constructor {a b args} { set itcl_options(-value) [list $a $b $args] } } dog spot retriever golden -akc 1 spot cget -value } -cleanup { dog destroy } -result {retriever golden {-akc 1}} test constructor-1.5 {constructor with list as one list arg} -body { type dog { option -value "" constructor {args} { set itcl_options(-value) $args } } dog spot {retriever golden} spot cget -value } -cleanup { dog destroy } -result {{retriever golden}} test constructor-1.6 {default constructor configures options} -body { type dog { option -color brown option -breed mutt } dog spot -color golden -breed retriever list [spot cget -color] [spot cget -breed] } -cleanup { dog destroy } -result {golden retriever} test constructor-1.7 {default constructor takes no args if no options} -body { type dog { variable color } dog spot -color golden } -returnCodes { error } -cleanup { dog destroy } -result {type "dog" has no options, but constructor has option arguments} #----------------------------------------------------------------------- # destroy test destroy-1.1 {destroy cleans up the instance} -body { type dog { option -color golden } set a [namespace children ::dog::] dog create spot set ns [info object namespace spot] set b [namespace children ::itcl::internal::variables$ns] spot destroy set c [namespace which ::itcl::internal::variables$ns] list $a $b $c [info commands ::dog::spot] } -cleanup { dog destroy } -match glob -result {{} ::itcl::internal::variables::*::dog {} {}} test destroy-1.2 {incomplete objects are destroyed} -body { array unset ::dog::snit_ivars type dog { option -color golden constructor {args} { $self configure {*}$args if {"red" == [$self cget -color]} { error "No Red Dogs!" } } } catch {dog create spot -color red} result set names [array names ::dog::snit_ivars] list $result $names [info commands ::dog::spot] } -cleanup { dog destroy } -result {{No Red Dogs!} {} {}} test destroy-1.3 {user-defined destructors are called} -body { type dog { typevariable flag "" constructor {args} { set flag "created $self" } destructor { set flag "destroyed $self" } typemethod getflag {} { return $flag } } dog create spot set a [dog getflag] spot destroy list $a [dog getflag] } -cleanup { dog destroy } -result {{created ::spot} {destroyed ::spot}} test install-1.7 {install works for itcl::types } -body { type tail { option -tailcolor black } type dog { delegate option -tailcolor to tail constructor {args} { installcomponent tail using tail $self.tail } } dog fido fido cget -tailcolor } -cleanup { dog destroy tail destroy } -result {black} #----------------------------------------------------------------------- # Setting the widget class explicitly test widgetclass-1.1 {can't set widgetclass for itcl::types} -body { type dog { widgetclass Dog } } -returnCodes { error } -result {can't set widgetclass for ::itcl::type} #----------------------------------------------------------------------- # hulltype statement test hulltype-1.1 {can't set hulltype for snit::types} -body { type dog { hulltype Dog } } -returnCodes { error } -result {can't set hulltype for ::itcl::type} #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/tclIndex0000644003604700454610000000270414137636151013641 0ustar dgp771div# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(Simple1) [list source [file join $dir mkindex.itcl]] set auto_index(Simple2) [list source [file join $dir mkindex.itcl]] set auto_index(ens) [list source [file join $dir mkindex.itcl]] set auto_index(::Simple2::bump) [list source [file join $dir mkindex.itcl]] set auto_index(::Simple2::by) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::inside) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::inside::find) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::inside::bump) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::inside::by) [list source [file join $dir mkindex.itcl]] set auto_index(top) [list source [file join $dir mkindex.itcl]] set auto_index(::top::find) [list source [file join $dir mkindex.itcl]] set auto_index(::top::notice) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::ens) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::under::neath) [list source [file join $dir mkindex.itcl]] set auto_index(::buried::deep::within) [list source [file join $dir mkindex.itcl]] itcl4.2.2/tests/sfbugs.test0000644003604700454610000003650414137636151014343 0ustar dgp771div# # Tests for SF bugs # ---------------------------------------------------------------------- # AUTHOR: Arnulf Wiedemann # arnulf@wiedemann-pri.de # ---------------------------------------------------------------------- # Copyright (c) Arnulf Wiedemann # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl global ::test_status # ---------------------------------------------------------------------- # Test bugs of the SourceForge bug tracker for incrtcl # ---------------------------------------------------------------------- test sfbug-163 {upvar has to resolve instance variables in caller} -setup { itcl::class o1 { public method getValue {name} { upvar $name val set val 22 } } itcl::class o2 { public variable command constructor {cls2} { $cls2 getValue command } public method b {cls2} { return $command } } o1 test1 o2 test2 test1 } -body { test2 b test1 } -cleanup { itcl::delete class o2 itcl::delete class o1 } -result 22 test sfbug-187 {upvar with this variable SF bug #187 } -body { ::itcl::class foo { method test {} { PopID } proc PopID {} { upvar 1 this me set me } } foo bar bar test } -result {::bar} \ -cleanup {::itcl::delete class foo} test sfbug-234 {chain with no argument SF bug #234 } -body { set ::test_status "" itcl::class One { public method t1 {x} { lappend ::test_status "$this One.t1($x)" } public method t2 {} { lappend ::test_status "$this One.t2" } } itcl::class Two { inherit One public method t1 {x} { lappend ::test_status "$this Two.t1($x)" chain $x } public method t2 {} { lappend ::test_status "$this Two.t2" chain } } set y [Two #auto] $y t1 a $y t2 } -result {{::two0 Two.t1(a)} {::two0 One.t1(a)} {::two0 Two.t2} {::two0 One.t2}} \ -cleanup {::itcl::delete class Two} test sfbug-236 {problem with inheritance of methods SF bug #236 } -body { set ::test_status "" ::itcl::class c_mem { private method get_ports {} public method get_mem {} } ::itcl::class c_rom { inherit c_mem private method get_ports {} } ::itcl::body c_rom::get_ports {} { return "toto" } ::itcl::body c_mem::get_ports {} { return "tata" } ::itcl::body c_mem::get_mem {} { return [concat "titi" [get_ports]] } set ptr [c_rom #auto] lappend ::test_status [$ptr get_mem] # expected output: # titi toto } -result {{titi toto}} \ -cleanup {::itcl::delete class c_rom} test sfbug-237 { problem with chain command SF bug #237 } -body { set ::test_status "" itcl::class main { constructor {} { lappend ::test_status "OK ITCL constructor" } public method init_OK1 { parm } { lappend ::test_status "OK1 MAIN $parm" } public method init_OK2 {} { lappend ::test_status "OK2 MAIN" } public method init_ERR1 {} { lappend ::test_status "ERR1 MAIN" } } itcl::class child { inherit main constructor {} {} public method init_OK1 {} { lappend ::test_status "OK1 CHILD" chain TEST } public method init_OK2 {} { lappend ::test_status "OK2 CHILD" next } public method init_ERR1 {} { lappend ::test_status "ERR1 CHILD" chain } } set obj [child #auto] $obj init_OK1 $obj init_OK2 $obj init_ERR1 } -result {{OK ITCL constructor} {OK1 CHILD} {OK1 MAIN TEST} {OK2 CHILD} {OK2 MAIN} {ERR1 CHILD} {ERR1 MAIN}} \ -cleanup {::itcl::delete class child} test sfbug-243 {faulty namespace behaviour SF bug #243 } -body { set ::test_status "" namespace eval ns {} itcl::class ns::A { method do {} {nsdo} method nsdo {} { lappend ::test_status "body do: [info function do -body]" } } [ns::A #auto] do itcl::body ns::A::do {} {A::nsdo} [ns::A #auto] do itcl::body ns::A::do {} {::ns::A::nsdo} [ns::A #auto] do itcl::body ns::A::do {} {ns::A::nsdo} [ns::A #auto] do } -result {{body do: nsdo} {body do: A::nsdo} {body do: ::ns::A::nsdo} {body do: ns::A::nsdo}} \ -cleanup {::itcl::delete class ns::A} test sfbug-244 { SF bug 244 } -body { set ::test_status "" proc foo {body} { uplevel $body } itcl::class A { method do {body} {foo $body} method do2 {} {lappend ::test_status done} } set y [A #auto] $y do { lappend ::test_status "I'm $this" do2 } } -result {{I'm ::a0} done} \ -cleanup {::itcl::delete class A; rename foo {}} test sfbug-250 { SF bug #250 } -body { set ::test_status "" ::itcl::class A { variable b constructor {} { set b [B #auto] } public method m1 {} { $b m3 } public method m2 {} { lappend ::test_status m2 } } ::itcl::class B { public method m3 {} { uplevel m2 } } set a [A #auto] $a m1 } -result {m2} \ -cleanup {::itcl::delete class A B} test sfbug-Schelte {bug with onfo reported from Schelte SF bug xxx } -body { set ::test_status "" itcl::class foo { method kerplunk {args} { lappend ::test_status [info level 0] lappend ::test_status [::info level 0] lappend ::test_status [[namespace which info] level 0] } } [foo #auto] kerplunk hello world } -result {{foo0 kerplunk hello world} {foo0 kerplunk hello world} {foo0 kerplunk hello world}} \ -cleanup {::itcl::delete class foo} test sfbug-254.1 { SF bug #254 + bug [1dc2d851eb] } -body { set interp [interp create] set ::test_status "" $interp eval { oo::class destroy } lappend ::test_status "::oo::class destroy worked" if {[catch { $interp eval [::tcltest::loadScript] $interp eval { package require itcl } } msg]} { lappend ::test_status $msg } } -result {{::oo::class destroy worked} {::oo::class does not refer to an object}} \ -cleanup {interp delete $interp} test sfbug-254.2 { SF bug #254 + bug [1dc2d851eb] } -body { set interp [interp create] set ::test_status "" $interp eval {set ::tcl::inl_mem_test 0} $interp eval [::tcltest::loadScript] $interp eval { package require itcl oo::class destroy } lappend ::test_status "::oo::class destroy worked" if {[catch { $interp eval { ::itcl::class ::test {} } } msg]} { lappend ::test_status $msg } } -result {{::oo::class destroy worked} {oo-subsystem is deleted}} \ -cleanup {interp delete $interp} test sfbug-254.3 { delete oo-subsystem should remove all classes + summary of bug [1dc2d851eb] } -body { set interp [interp create] set ::test_status "" $interp eval {set ::tcl::inl_mem_test 0} $interp eval [::tcltest::loadScript] $interp eval { package require itcl ::itcl::class ::test {} } lappend ::test_status "::test class created" $interp eval { oo::class destroy } lappend ::test_status "::oo::class destroy worked" if {[catch { $interp eval { ::test x } } msg]} { lappend ::test_status $msg } if {[catch { $interp eval { ::itcl::class ::test2 {inherit ::test} } } msg]} { lappend ::test_status $msg } } -result {{::test class created} {::oo::class destroy worked} {invalid command name "::test"} {oo-subsystem is deleted}} \ -cleanup {interp delete $interp} test sfbug-255 { SF bug #255 } -body { set ::test_status "" proc ::sfbug_255_do_uplevel { body } { uplevel 1 $body } proc ::sfbug_255_testclass { pathName args } { uplevel TestClass $pathName $args } ::itcl::class TestClass { public variable property "value" constructor {} { } private method internal-helper {} { return "TestClass::internal-helper" } public method api-call {} { lappend ::test_status "TestClass::api-call" lappend ::test_status [internal-helper] lappend ::test_status [sfbug_255_do_uplevel { internal-helper }] lappend ::test_status [cget -property] sfbug_255_do_uplevel { lappend ::test_status [cget -property] } } } [::sfbug_255_testclass tc] api-call } -result {TestClass::api-call TestClass::internal-helper TestClass::internal-helper value value} \ -cleanup {::itcl::delete class TestClass} test fossilbug-8 { fossil bug 2cd667f270b68ef66d668338e09d144e20405e23 } -body { ::itcl::class ::Naughty { private method die {} { } } ::Naughty die } -cleanup { ::itcl::delete class ::Naughty } -result {die} test sfbug-256 { SF bug #256 } -body { set ::test_status "" proc ::sfbug_256_do_uplevel { body } { uplevel 1 $body } proc ::sfbug_256_testclass { pathName args } { uplevel TestClass256 $pathName $args } ::itcl::class TestClass256 { public variable property "value" constructor {} { } private method internal-helper {} { lappend ::test_status "TestClass::internal-helper" sfbug_256_do_uplevel { lappend ::test_status [cget -property] } } public method api-call {} { lappend ::test_status "TestClass::api-call" lappend ::test_status [internal-helper] lappend ::test_status [sfbug_256_do_uplevel { internal-helper }] lappend ::test_status [cget -property] sfbug_256_do_uplevel { lappend ::test_status [cget -property] } } } [::sfbug_256_testclass tc] api-call } -result {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value {TestClass::api-call TestClass::internal-helper value} TestClass::internal-helper value} value value} \ -cleanup {::itcl::delete class TestClass256} test sfbug-257 { SF bug #257 } -body { set interp [interp create] $interp eval {set ::tcl::inl_mem_test 0} $interp eval [::tcltest::loadScript] $interp eval { package require itcl set ::test_status "" ::itcl::class ::cl1 { method m1 {} { ::oo::class destroy lappend ::test_status "method Hello World" } proc p1 {} { lappend ::test_status "proc Hello World" } } set obj1 [::cl1 #auto] ::cl1::p1 $obj1 p1 $obj1 m1 catch { $obj1 m1 ::cl1::p1 } msg lappend ::test_status $msg } } -result {{proc Hello World} {proc Hello World} {method Hello World} {invalid command name "cl10"}} \ -cleanup {interp delete $interp} test sfbug-259 { SF bug #257 } -setup { interp create child load {} Itcl child } -cleanup { interp delete child } -body { child eval { proc do_uplevel { body } { uplevel 1 $body } proc ::testclass { pathName args } { uplevel TestClass $pathName $args } itcl::class TestClass { constructor {} {} public variable property "value" public method api-call {} protected method internal-helper {} } itcl::body TestClass::internal-helper {} { } itcl::configbody TestClass::property { internal-helper } itcl::body TestClass::api-call {} { do_uplevel {configure -property blah} } set tc [::testclass .] $tc api-call } } test sfbug-261 { SF bug #261 } -setup { itcl::class A { public method a1 {} {a2} public method a2 {} {uplevel a3 hello} public method a3 {s} {return $s} } A x } -body { x a1 } -cleanup { itcl::delete class A } -result hello test sfbug-265.1 { SF bug #265 } -setup { itcl::class C {} } -body { namespace eval A {C c} namespace eval B {C c} } -cleanup { itcl::delete class C namespace delete A B } -result c test sfbug-265.2 { SF bug #265 } -setup { itcl::class C {} itcl::class B::C {} } -body { C ::A::B B::C ::A } -cleanup { itcl::delete class B::C itcl::delete class C namespace delete A B } -result ::A test sfbug-268 { SF bug #268 } -setup { itcl::class C { private variable v destructor {error foo} public method demo {} {set v 0} } C c } -body { catch {itcl::delete object c} c demo } -cleanup { rename c {} itcl::delete class C } -result 0 test sfbug-273 { SF bug #273 } -setup { itcl::class C { public proc call {m} {$m} public proc crash {} { call null info frame 2 return ok } public proc null {} {} } } -body { C::call crash } -cleanup { itcl::delete class C } -result ok test sfbug-276.0 { SF bug #276 } -setup { set ::answer {} itcl::class A { constructor {} { lappend ::answer [uplevel namespace current] } } itcl::class B { inherit A constructor {} {} } } -body { B b set ::answer } -cleanup { itcl::delete class A B unset -nocomplain ::answer } -result ::B test sfbug-276.1 { SF bug #276 } -setup { set ::answer {} itcl::class A { constructor {} { lappend ::answer [uplevel namespace current] } } itcl::class E { constructor {} { lappend ::answer [uplevel namespace current] } } itcl::class B { inherit A E constructor {} {} } } -body { B b set ::answer } -cleanup { itcl::delete class A B E unset -nocomplain ::answer } -result {::B ::B} test fossil-9.0 {d0126511d9} -setup { itcl::class N::B {} } -body { itcl::class N {} } -cleanup { itcl::delete class N::B N } -result {} test fossil-9.1 {d0126511d9} -setup { itcl::class N::B {} itcl::delete class N::B namespace delete N } -body { itcl::class N {} } -cleanup { itcl::delete class N catch {namespace delete N} } -result {} test fossil-9.2 {ec215db901} -setup { set ::answer {} itcl::class Object { constructor {} {set n 1} {set ::answer $n} } } -body { Object foo set ::answer } -cleanup { itcl::delete class Object unset -nocomplain ::answer } -result 1 test fossil-9.3 {c45384364c} -setup { itcl::class A { method demo script {uplevel 1 $script} } A a itcl::class B { method demo script {eval $script; a demo $script} } B b } -body { b demo {lappend result $this} } -cleanup { itcl::delete class A B } -result {::b ::b} test fossil-9.4 {9eea4912b9} -setup { itcl::class A { public method foo WRONG } } -body { itcl::body A::foo {RIGHT} {} A a a info args foo } -cleanup { itcl::delete class A } -result RIGHT test sfbugs-281 {Resolve inherited common} -setup { itcl::class Parent {protected common x 0} } -cleanup { itcl::delete class Parent } -body { itcl::class Child { inherit Parent set Parent::x } } -result {} #test sfbug-xxx { SF bug xxx #} -body { # set ::test_status "" # #} -result {::bar} \ # -cleanup {::itcl::delete class yyy} ::tcltest::cleanupTests return itcl4.2.2/tests/scope.test0000644003604700454610000002266614137636151014167 0ustar dgp771div# # Tests for code/scope commands # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Syntax of the "scope" command # ---------------------------------------------------------------------- test scope-1.1 {scope command takes one argument} { list [catch {itcl::scope} msg] $msg [catch {itcl::scope x y} msg] $msg } {1 {wrong # args: should be "itcl::scope varname"} 1 {wrong # args: should be "itcl::scope varname"}} test scope-1.2 {argument to scope command must be a variable} { variable test_scope_var 0 list [catch {itcl::scope xyzzy} msg] $msg \ [catch {itcl::scope test_scope_var} msg] $msg } {1 {variable "xyzzy" not found in namespace "::"} 0 ::test_scope_var} test scope-1.3 {if variable is already fully qualified, scope does nothing} { list [itcl::scope ::xyzzy] [itcl::scope ::test_scope_var] } {::xyzzy ::test_scope_var} test scope-1.4 {scope command returns fully qualified name} { namespace eval test_scope_ns { namespace eval child { variable v1 0 itcl::scope v1 } } } {::test_scope_ns::child::v1} namespace delete test_scope_ns unset test_scope_var # ---------------------------------------------------------------------- # Syntax of the "code" command # ---------------------------------------------------------------------- test scope-2.1 {code command takes at least one argument} { list [catch {itcl::code} msg] $msg } {1 {wrong # args: should be "itcl::code ?-namespace name? command ?arg arg...?"}} test scope-2.2 {code command with one argument} { itcl::code arg1 } {namespace inscope :: arg1} test scope-2.3 {code command with many arguments} { list [itcl::code arg1 arg2] [itcl::code arg1 arg2 arg3 arg4] } {{namespace inscope :: {arg1 arg2}} {namespace inscope :: {arg1 arg2 arg3 arg4}}} test scope-2.4 {code command appends arguments as list elements} { list [itcl::code "foo bar"] \ [itcl::code "foo bar" "hello, world!" "one, two, three"] } {{namespace inscope :: {foo bar}} {namespace inscope :: {{foo bar} {hello, world!} {one, two, three}}}} test scope-2.5 {code command inside code command} { itcl::code [itcl::code arg1 arg2] arg3 } {namespace inscope :: {{namespace inscope :: {arg1 arg2}} arg3}} test scope-2.6 {code command returns fully qualified names} { namespace eval test_scope_ns { namespace eval child { itcl::code foo bar baz } } } {namespace inscope ::test_scope_ns::child {foo bar baz}} test scope-2.7 {code command lets you specify a namespace} { list [catch {itcl::code -namespace xyzzy arg1 arg2} msg] $msg \ [catch {itcl::code -namespace test_scope_ns::child arg1 arg2} msg] $msg } {1 {unknown namespace "xyzzy"} 0 {namespace inscope ::test_scope_ns::child {arg1 arg2}}} test scope-2.8 {last namespace wins} { itcl::code -namespace test_scope_ns::child -namespace test_scope_ns arg1 } {namespace inscope ::test_scope_ns arg1} test scope-2.9 {"--" terminates switches} { list [catch {itcl::code -namespace test_scope_ns -foo -bar} msg] $msg \ [catch {itcl::code -namespace test_scope_ns -- -foo -bar} msg] $msg } {1 {bad option "-foo": should be -namespace or --} 0 {namespace inscope ::test_scope_ns {-foo -bar}}} namespace delete test_scope_ns # ---------------------------------------------------------------------- # Test code/scope commands in a class # ---------------------------------------------------------------------- test scope-3.1 {define simple classes with things to export} { itcl::class test_scope { private variable priv "private-value" protected variable prov "protected-value" public variable pubv "public-value" private common pric "private-common-value" protected common proc "protected-common-value" public common pubc "public-common-value" variable varray common carray method mcontext {args} { return [eval $args] } proc pcontext {args} { return [eval $args] } private method prim {args} { return "prim: $args" } protected method prom {args} { return "prom: $args" } public method pubm {args} { return "pubm: $args" } } test_scope #auto } {test_scope0} test scope-3.2 {code command captures only class context} { list [test_scope0 mcontext itcl::code arg1 arg2] \ [test_scope::pcontext itcl::code arg1 arg2] } {{namespace inscope ::test_scope {arg1 arg2}} {namespace inscope ::test_scope {arg1 arg2}}} test scope-3.3 {scope command captures class and object context} -body { list [test_scope0 mcontext itcl::scope priv] \ [test_scope::pcontext itcl::scope pric] } -match glob -result {::itcl::internal::variables::*::test_scope::priv ::itcl::internal::variables::test_scope::pric} test scope-3.4 {scope command must recognize variable} { list [catch {test_scope0 mcontext itcl::scope xyzzy} msg] $msg } {1 {variable "xyzzy" not found in class "::test_scope"}} test scope-3.5 {scope command provides access to instance variables} { set result "" foreach vname {priv prov pubv} { lappend result [test_scope0 info variable $vname] set var [test_scope0 mcontext itcl::scope $vname] set $var "$vname-new" lappend result [test_scope0 info variable $vname] } set result } {{private variable ::test_scope::priv private-value private-value} {private variable ::test_scope::priv private-value priv-new} {protected variable ::test_scope::prov protected-value protected-value} {protected variable ::test_scope::prov protected-value prov-new} {public variable ::test_scope::pubv public-value {} public-value} {public variable ::test_scope::pubv public-value {} pubv-new}} test scope-3.6 {scope command provides access to common variables} { set result "" foreach vname {pric proc pubc} { lappend result [test_scope0 info variable $vname] set var [test_scope0 mcontext itcl::scope $vname] set $var "$vname-new" lappend result [test_scope0 info variable $vname] } set result } {{private common ::test_scope::pric private-common-value private-common-value} {private common ::test_scope::pric private-common-value pric-new} {protected common ::test_scope::proc protected-common-value protected-common-value} {protected common ::test_scope::proc protected-common-value proc-new} {public common ::test_scope::pubc public-common-value public-common-value} {public common ::test_scope::pubc public-common-value pubc-new}} test scope-3.7 {code command provides access to methods} { set result "" foreach mname {prim prom pubm} { set cmd [test_scope0 mcontext eval itcl::code \$this $mname] lappend result $cmd [uplevel 0 $cmd 1 2 3] } set result } {{namespace inscope ::test_scope {::test_scope0 prim}} {prim: 1 2 3} {namespace inscope ::test_scope {::test_scope0 prom}} {prom: 1 2 3} {namespace inscope ::test_scope {::test_scope0 pubm}} {pubm: 1 2 3}} test scope-3.8 {scope command allows access to slots in an array} -body { test_scope0 mcontext set varray(0) "defined" test_scope::pcontext set carray(0) "defined" list [catch {test_scope0 mcontext itcl::scope varray(0)} msg] $msg \ [catch {test_scope0 mcontext itcl::scope varray(1)} msg] $msg \ [catch {test_scope::pcontext itcl::scope carray(0)} msg] $msg \ [catch {test_scope::pcontext itcl::scope carray(1)} msg] $msg } -match glob -result {0 ::itcl::internal::variables::*::test_scope::varray(0) 0 ::itcl::internal::variables::*::test_scope::varray(1) 0 ::itcl::internal::variables::test_scope::carray(0) 0 ::itcl::internal::variables::test_scope::carray(1)} itcl::delete class test_scope # ---------------------------------------------------------------------- # Test code/scope commands in a namespace # ---------------------------------------------------------------------- test scope-4.1 {define simple namespace with things to export} { namespace eval test_scope_ns { variable array proc pcontext {args} { return [eval $args] } } namespace children :: ::test_scope_ns } {::test_scope_ns} test scope-4.2 {scope command allows access to slots in an array} { test_scope_ns::pcontext set array(0) "defined" list [catch {test_scope_ns::pcontext itcl::scope array(0)} msg] $msg \ [catch {test_scope_ns::pcontext itcl::scope array(1)} msg] $msg } {0 ::test_scope_ns::array(0) 0 ::test_scope_ns::array(1)} namespace delete test_scope_ns test scope-5.0 {Bug e5f529da75} -setup { itcl::class B { common c method v {} {itcl::scope c} } itcl::class D { inherit B method v {} {itcl::scope c} } B b D d } -body { string equal [b v] [d v] } -cleanup { itcl::delete class B } -result 1 ::tcltest::cleanupTests return itcl4.2.2/tests/protection.test0000644003604700454610000003406514137636151015240 0ustar dgp771div# # Tests for method/variable protection and access # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Class members are protected by access restrictions # ---------------------------------------------------------------------- test protect-1.1 {define a class with various protection levels} { itcl::class test_pr { public { variable pubv "public var" common pubc "public com" method pubm {} {return "public method"} method ovpubm {} {return "overloaded public method"} proc pubp {} {return "public proc"} } protected { variable prov "protected var" common proc "protected com" method prom {} {return "protected method"} method ovprom {} {return "overloaded protected method"} proc prop {} {return "protected proc"} } private { variable priv "private var" common pric "private com" method prim {} {return "private method"} method ovprim {} {return "overloaded private method"} proc prip {} {return "private proc"} } method do {args} {eval $args} } } "" test protect-1.2 {create an object to execute tests} { test_pr #auto } {test_pr0} test protect-1.3a {public methods can be accessed from outside} { list [catch {test_pr0 pubm} msg] $msg } {0 {public method}} test protect-1.3b {public methods can be accessed from inside} { list [catch {test_pr0 do pubm} msg] $msg } {0 {public method}} test protect-1.4a {protected methods are blocked from outside} { list [catch {test_pr0 prom} msg] $msg } {1 {bad option "prom": should be one of... test_pr0 cget -option test_pr0 configure ?-option? ?value -option value...? test_pr0 do ?arg arg ...? test_pr0 isa className test_pr0 ovpubm test_pr0 pubm}} test protect-1.4b {protected methods can be accessed from inside} { list [catch {test_pr0 do prom} msg] $msg } {0 {protected method}} test protect-1.5a {private methods are blocked from outside} { list [catch {test_pr0 prim} msg] $msg } {1 {bad option "prim": should be one of... test_pr0 cget -option test_pr0 configure ?-option? ?value -option value...? test_pr0 do ?arg arg ...? test_pr0 isa className test_pr0 ovpubm test_pr0 pubm}} test protect-1.5b {private methods can be accessed from inside} { list [catch {test_pr0 do prim} msg] $msg } {0 {private method}} test protect-1.6a {public procs can be accessed from outside} { list [catch {test_pr::pubp} msg] $msg } {0 {public proc}} test protect-1.6b {public procs can be accessed from inside} { list [catch {test_pr0 do pubp} msg] $msg } {0 {public proc}} test protect-1.7a {protected procs are blocked from outside} { list [catch {test_pr::prop} msg] $msg } {1 {can't access "::test_pr::prop": protected function}} test protect-1.7b {protected procs can be accessed from inside} { list [catch {test_pr0 do prop} msg] $msg } {0 {protected proc}} test protect-1.8a {private procs are blocked from outside} { list [catch {test_pr::prip} msg] $msg } {1 {can't access "::test_pr::prip": private function}} test protect-1.8b {private procs can be accessed from inside} { list [catch {test_pr0 do prip} msg] $msg } {0 {private proc}} test protect-1.9a {public commons can be accessed from outside} { list [catch {set test_pr::pubc} msg] $msg } {0 {public com}} test protect-1.9b {public commons can be accessed from inside} { list [catch {test_pr0 do set pubc} msg] $msg } {0 {public com}} test protect-1.10 {protected commons can be accessed from inside} { list [catch {test_pr0 do set proc} msg] $msg } {0 {protected com}} test protect-1.11 {private commons can be accessed from inside} { list [catch {test_pr0 do set pric} msg] $msg } {0 {private com}} test protect-1.12a {object-specific variables require an access command} { list [catch {set test_pr::pubv} msg] $msg } {1 {can't read "test_pr::pubv": no such variable}} test protect-1.12b {public variables can be accessed from inside} { list [catch {test_pr0 do set pubv} msg] $msg } {0 {public var}} test protect-1.13a {object-specific variables require an access command} { list [catch {set test_pr::prov} msg] $msg } {1 {can't read "test_pr::prov": no such variable}} test protect-1.13b {protected variables can be accessed from inside} { list [catch {test_pr0 do set prov} msg] $msg } {0 {protected var}} test protect-1.14a {object-specific variables require an access command} { list [catch {set test_pr::priv} msg] $msg } {1 {can't read "test_pr::priv": no such variable}} test protect-1.14b {private variables can be accessed from inside} { list [catch {test_pr0 do set priv} msg] $msg } {0 {private var}} # ---------------------------------------------------------------------- # Access restrictions work properly with inheritance # ---------------------------------------------------------------------- test protect-2.1 {define a derived class} { itcl::class test_pr_derived { inherit test_pr method do {args} {eval $args} public method ovpubm {} {return "specific public method"} protected method ovprom {} {return "specific protected method"} private method ovprim {} {return "specific private method"} public method dpubm {} {return "pub (only in derived)"} protected method dprom {} {return "pro (only in derived)"} private method dprim {} {return "pri (only in derived)"} } } "" test protect-2.2 {create an object to execute tests} { test_pr_derived #auto } {test_pr_derived0} test protect-2.3 {public methods can be accessed from inside} { list [catch {test_pr_derived0 do pubm} msg] $msg } {0 {public method}} test protect-2.4 {protected methods can be accessed from inside} { list [catch {test_pr_derived0 do prom} msg] $msg } {0 {protected method}} test protect-2.5 {private methods are blocked} { list [catch {test_pr_derived0 do prim} msg] $msg } {1 {invalid command name "prim"}} test protect-2.6 {public procs can be accessed from inside} { list [catch {test_pr_derived0 do pubp} msg] $msg } {0 {public proc}} test protect-2.7 {protected procs can be accessed from inside} { list [catch {test_pr_derived0 do prop} msg] $msg } {0 {protected proc}} test protect-2.8 {private procs are blocked} { list [catch {test_pr_derived0 do prip} msg] $msg } {1 {invalid command name "prip"}} test protect-2.9 {public commons can be accessed from inside} { list [catch {test_pr_derived0 do set pubc} msg] $msg } {0 {public com}} test protect-2.10 {protected commons can be accessed from inside} { list [catch {test_pr_derived0 do set proc} msg] $msg } {0 {protected com}} test protect-2.11 {private commons are blocked} { list [catch {test_pr_derived0 do set pric} msg] $msg } {1 {can't read "pric": no such variable}} test protect-2.12 {public variables can be accessed from inside} { list [catch {test_pr_derived0 do set pubv} msg] $msg } {0 {public var}} test protect-2.13 {protected variables can be accessed from inside} { list [catch {test_pr_derived0 do set prov} msg] $msg } {0 {protected var}} test protect-2.14 {private variables are blocked} { list [catch {test_pr_derived0 do set priv} msg] $msg } {1 {can't read "priv": no such variable}} test protect-2.15 {can access overloaded public method} { set cmd {namespace eval test_pr_derived {test_pr_derived0 ovpubm}} list [catch $cmd msg] $msg } {0 {specific public method}} test protect-2.16 {can access overloaded public method} { set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprom}} list [catch $cmd msg] $msg } {0 {specific protected method}} test protect-2.17 {can access overloaded private method} { set cmd {namespace eval test_pr_derived {test_pr_derived0 ovprim}} list [catch $cmd msg] $msg } {0 {specific private method}} test protect-2.18 {can access overloaded public method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 ovpubm}} list [catch $cmd msg] $msg } {0 {specific public method}} test protect-2.19 {can access overloaded protected method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 ovprom}} list [catch $cmd msg] $msg } {0 {specific protected method}} test protect-2.20 {*cannot* access overloaded private method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 ovprim}} list [catch $cmd msg] $msg } {1 {bad option "ovprim": should be one of... test_pr_derived0 cget -option test_pr_derived0 configure ?-option? ?value -option value...? test_pr_derived0 do ?arg arg ...? test_pr_derived0 dpubm test_pr_derived0 isa className test_pr_derived0 ovprom test_pr_derived0 ovpubm test_pr_derived0 prim test_pr_derived0 prom test_pr_derived0 pubm}} test protect-2.21 {can access non-overloaded public method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 dpubm}} list [catch $cmd msg] $msg } {0 {pub (only in derived)}} test protect-2.22 {*cannot* access non-overloaded protected method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 dprom}} list [catch $cmd msg] $msg } {1 {bad option "dprom": should be one of... test_pr_derived0 cget -option test_pr_derived0 configure ?-option? ?value -option value...? test_pr_derived0 do ?arg arg ...? test_pr_derived0 dpubm test_pr_derived0 isa className test_pr_derived0 ovprom test_pr_derived0 ovpubm test_pr_derived0 prim test_pr_derived0 prom test_pr_derived0 pubm}} test protect-2.23 {*cannot* access non-overloaded private method from base class} { set cmd {namespace eval test_pr {test_pr_derived0 dprim}} list [catch $cmd msg] $msg } {1 {bad option "dprim": should be one of... test_pr_derived0 cget -option test_pr_derived0 configure ?-option? ?value -option value...? test_pr_derived0 do ?arg arg ...? test_pr_derived0 dpubm test_pr_derived0 isa className test_pr_derived0 ovprom test_pr_derived0 ovpubm test_pr_derived0 prim test_pr_derived0 prom test_pr_derived0 pubm}} eval namespace delete [itcl::find classes test_pr*] # ---------------------------------------------------------------------- # Access restrictions don't mess up "info" # ---------------------------------------------------------------------- test protect-3.1 {define a base class with private variables} { itcl::class test_info_base { private variable pribv "pribv-value" private common pribc "pribc-value" protected variable probv "probv-value" protected common probc "probc-value" public variable pubbv "pubbv-value" public common pubbc "pubbc-value" } itcl::class test_info_derived { inherit test_info_base private variable pridv "pridv-value" private common pridc "pridc-value" } } "" test protect-3.2 {create an object to execute tests} { test_info_derived #auto } {test_info_derived0} test protect-3.3 {all variables are reported} { list [catch {test_info_derived0 info variable} msg] [lsort $msg] } {0 {::test_info_base::pribc ::test_info_base::pribv ::test_info_base::probc ::test_info_base::probv ::test_info_base::pubbc ::test_info_base::pubbv ::test_info_derived::pridc ::test_info_derived::pridv ::test_info_derived::this}} test protect-3.4 {private base class variables can be accessed} { list [catch {test_info_derived0 info variable pribv} msg] $msg } {0 {private variable ::test_info_base::pribv pribv-value pribv-value}} test protect-3.5 {private base class commons can be accessed} { list [catch {test_info_derived0 info variable pribc} msg] $msg } {0 {private common ::test_info_base::pribc pribc-value pribc-value}} test protect-3.6 {protected base class variables can be accessed} { list [catch {test_info_derived0 info variable probv} msg] $msg } {0 {protected variable ::test_info_base::probv probv-value probv-value}} test protect-3.7 {protected base class commons can be accessed} { list [catch {test_info_derived0 info variable probc} msg] $msg } {0 {protected common ::test_info_base::probc probc-value probc-value}} test protect-3.8 {public base class variables can be accessed} { list [catch {test_info_derived0 info variable pubbv} msg] $msg } {0 {public variable ::test_info_base::pubbv pubbv-value {} pubbv-value}} test protect-3.9 {public base class commons can be accessed} { list [catch {test_info_derived0 info variable pubbc} msg] $msg } {0 {public common ::test_info_base::pubbc pubbc-value pubbc-value}} test protect-3.10 {private derived class variables can be accessed} { list [catch {test_info_derived0 info variable pridv} msg] $msg } {0 {private variable ::test_info_derived::pridv pridv-value pridv-value}} test protect-3.11 {private derived class commons can be accessed} { list [catch {test_info_derived0 info variable pridc} msg] $msg } {0 {private common ::test_info_derived::pridc pridc-value pridc-value}} test protect-3.12 {private base class variables can't be accessed from class} { list [catch { namespace eval test_info_derived {info variable pribv} } msg] $msg } {1 {cannot access object-specific info without an object context}} test protect-3.13 {private base class commons can be accessed from class} { list [catch { namespace eval test_info_derived {info variable pribc} } msg] $msg } {0 {private common ::test_info_base::pribc pribc-value pribc-value}} eval namespace delete [itcl::find classes test_info*] ::tcltest::cleanupTests return itcl4.2.2/tests/namespace.test0000644003604700454610000000673514137636151015011 0ustar dgp771div# # Tests for classes within namespaces # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Classes within namespaces # ---------------------------------------------------------------------- test namespace-1.1 {same class name can be used in different namespaces } -body { namespace eval test_ns_1 { itcl::class Counter { variable num 0 method ++ {{by 1}} { incr num $by } method do {args} { return [eval $args] } common tag 1 } proc exists {} { return "don't clobber me!" } } namespace eval test_ns_2 { itcl::class Counter { variable num 0 method ++ {{by 2}} { if {$num == 0} { set num 1 } else { set num [expr {$num*$by}] } } method do {args} { return [eval $args] } common tag 2 } } } -result {} test namespace-1.2 {classes in different namespaces are different } -body { list [namespace eval test_ns_1::Counter {info variable tag}] \ [namespace eval test_ns_2::Counter {info variable tag}] \ } -result {{protected common ::test_ns_1::Counter::tag 1 1} {protected common ::test_ns_2::Counter::tag 2 2}} test namespace-1.3 {create an object in one namespace } -body { namespace eval test_ns_1 { list [Counter c] [c ++] [c ++] [c ++] [c ++] } } -result {c 1 2 3 4} test namespace-1.4 {create an object in another namespace } -body { namespace eval test_ns_2 { list [Counter c] [c ++] [c ++] [c ++] [c ++] } } -cleanup { namespace delete ::itcl::internal::variables::test_ns_2 namespace delete test_ns_2 } -result {c 1 2 4 8} test namespace-1.5 {can find classes wrapped in a namespace } -body { list [catch {test_ns_1::c do itcl::find objects -isa Counter} msg] $msg \ [catch {test_ns_1::c do itcl::find objects -class Counter} msg] $msg } -result {0 ::test_ns_1::c 0 ::test_ns_1::c} test namespace-1.6 {can't create an object that clobbers a command in this namespace } -body { list [catch {namespace eval test_ns_1 {Counter exists}} msg] $msg } -result {1 {command "exists" already exists in namespace "::test_ns_1"}} test namespace-1.7 {can create an object that shadows a command in the global namespace } -body { list [catch {namespace eval test_ns_1 {Counter lreplace}} msg] $msg \ [catch {itcl::find objects *lreplace} msg] $msg \ [namespace eval test_ns_1 {namespace which lreplace}] } -cleanup { namespace delete ::itcl::internal::variables::test_ns_1 namespace delete test_ns_1 } -result {0 lreplace 0 ::test_ns_1::lreplace ::test_ns_1::lreplace} ::tcltest::cleanupTests return itcl4.2.2/tests/mkindex.test0000644003604700454610000000432314137636151014503 0ustar dgp771div# # Tests for "auto_mkindex" and autoloading facility # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test set ::tcl::inl_mem_test 0 ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Test "auto_mkindex" in the presence of class definitions # ---------------------------------------------------------------------- test mkindex-1.1 {remove any existing tclIndex file} { file delete tclIndex file exists tclIndex } {0} test mkindex-1.2 {build tclIndex based on a test file} { if {[pwd] != $::tcltest::testsDirectory} { file copy -force [file join $::tcltest::testsDirectory mkindex.itcl] \ ./mkindex.itcl } auto_mkindex . mkindex.itcl if {[pwd] != $::tcltest::testsDirectory} { file delete -force ./mkindex.itcl } file exists tclIndex } {1} set element "{source [file join . mkindex.itcl]}" test mkindex-1.3 {examine tclIndex} { namespace eval itcl_mkindex_tmp { set dir "." variable auto_index source tclIndex set result "" foreach elem [lsort [array names auto_index]] { lappend result [list $elem $auto_index($elem)] } set result } } "{::Simple2::bump $element} {::Simple2::by $element} {::buried::deep::within $element} {::buried::ens $element} {::buried::inside $element} {::buried::inside::bump $element} {::buried::inside::by $element} {::buried::inside::find $element} {::buried::under::neath $element} {::top::find $element} {::top::notice $element} {Simple1 $element} {Simple2 $element} {ens $element} {top $element}" file delete tclIndex ::tcltest::cleanupTests return itcl4.2.2/tests/mkindex.itcl0000644003604700454610000000367614137636151014471 0ustar dgp771div# Test file for: # auto_mkindex # # This file provides example cases for testing the Tcl autoloading # facility. Things are much more complicated with namespaces and classes. # The "auto_mkindex" facility can no longer be built on top of a simple # regular expression parser. It must recognize constructs like this: # # namespace eval foo { # class Internal { ... } # body Internal::func {x y} { ... } # namespace eval bar { # class Another { ... } # } # } # # Note that class definitions can be nested inside of namespaces. # # Copyright (c) 1993-1998 Lucent Technologies, Inc. # # Should be able to handle simple class definitions, even if # they are prefaced with white space. # namespace import itcl::* class Simple1 { variable x 0 public method bump {} {incr x} } itcl::class Simple2 { variable x 0 public variable by 1 public method bump {} } itcl::ensemble ens { part one {x} {} part two {x y} {} part three {x y z} {} } # # Should be able to handle "body" and "configbody" declarations. # body Simple2::bump {} {incr x $by} configbody Simple2::by {if {$by <= 0} {error "bad increment"}} # # Should be able to handle class declarations within namespaces, # even if they have explicit namespace paths. # namespace eval buried { class inside { variable x 0 public variable by 1 public method bump {} method skip {x y z} {} proc find {args} {} } body inside::bump {} {incr x $by} configbody inside::by {if {$by <= 0} {error "bad increment"}} class ::top { method skip {x y z} {} method ignore {} {} public proc find {args} {} protected proc notice {args} {} } ensemble ens { part one {x} {} part two {x y} {} part three {x y z} {} } namespace eval under { itcl::class neath { } } namespace eval deep { ::itcl::class within { } } } itcl4.2.2/tests/methods.test0000644003604700454610000001476514137636151014522 0ustar dgp771div# # Tests for argument lists and method execution # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Methods with various argument lists # ---------------------------------------------------------------------- test methods-1.1 {define a class with lots of methods and arg lists} { itcl::class test_args { method none {} { return "none" } method two {x y} { return "two: $x $y" } method defvals {x {y def1} {z def2}} { return "defvals: $x $y $z" } method varargs {x {y def1} args} { return "varargs: $x $y ($args)" } method nomagic {args x} { return "nomagic: $args $x" } method clash {x bang boom} { return "clash: $x $bang $boom" } method clash_time {x bang boom} { time {set result "clash_time: $x $bang $boom"} 1 return $result } proc crash {x bang boom} { return "crash: $x $bang $boom" } proc crash_time {x bang boom} { time {set result "crash_time: $x $bang $boom"} 1 return $result } variable bang "ok" common boom "no-problem" } } "" test methods-1.2 {create an object to execute tests} { test_args ta } {ta} test methods-1.3 {argument checking: not enough args} { list [catch {ta two 1} msg] $msg } {1 {wrong # args: should be "ta two x y"}} test methods-1.4a {argument checking: too many args} { list [catch {ta two 1 2 3} msg] $msg } {1 {wrong # args: should be "ta two x y"}} test methods-1.4b {argument checking: too many args} { list [catch {ta none 1 2 3} msg] $msg } {1 {wrong # args: should be "ta none"}} test methods-1.5a {argument checking: just right} { list [catch {ta two 1 2} msg] $msg } {0 {two: 1 2}} test methods-1.5b {argument checking: just right} { list [catch {ta none} msg] $msg } {0 none} test methods-1.6a {default arguments: not enough args} { list [catch {ta defvals} msg] $msg } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} test methods-1.6b {default arguments: missing arguments supplied} { list [catch {ta defvals 1} msg] $msg } {0 {defvals: 1 def1 def2}} test methods-1.6c {default arguments: missing arguments supplied} { list [catch {ta defvals 1 2} msg] $msg } {0 {defvals: 1 2 def2}} test methods-1.6d {default arguments: all arguments assigned} { list [catch {ta defvals 1 2 3} msg] $msg } {0 {defvals: 1 2 3}} test methods-1.6e {default arguments: too many args} { list [catch {ta defvals 1 2 3 4} msg] $msg } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} test methods-1.7a {variable arguments: not enough args} { list [catch {ta varargs} msg] $msg } {1 {wrong # args: should be "ta varargs x ?y? ?arg arg ...?"}} test methods-1.7b {variable arguments: empty} { list [catch {ta varargs 1 2} msg] $msg } {0 {varargs: 1 2 ()}} test methods-1.7c {variable arguments: one} { list [catch {ta varargs 1 2 one} msg] $msg } {0 {varargs: 1 2 (one)}} test methods-1.7d {variable arguments: two} { list [catch {ta varargs 1 2 one two} msg] $msg } {0 {varargs: 1 2 (one two)}} test methods-1.8 {magic "args" argument has no magic unless at end of list} { list [catch {ta nomagic 1 2 3 4} msg] $msg } {1 {wrong # args: should be "ta nomagic args x"}} test methods-1.9 {formal args don't clobber class members} { list [catch {ta clash 1 2 3} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {clash: 1 2 3} ok no-problem} test methods-1.10 {formal args don't clobber class members} { list [catch {test_args::crash 4 5 6} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {crash: 4 5 6} ok no-problem} test methods-1.11 {formal args don't clobber class members, even in "time"} { list [catch {ta clash_time 7 8 9} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {clash_time: 7 8 9} ok no-problem} test methods-1.12 {formal args don't clobber class members, even in "time"} { list [catch {test_args::crash_time a b c} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {crash_time: a b c} ok no-problem} test methods-2.1 {covers leak condition test for compiled locals, no args} { for {set i 0} {$i < 100} {incr i} { ::itcl::class LeakClass { proc leakProc {} { set n 1 } } LeakClass::leakProc ::itcl::delete class LeakClass } list 0 } 0 test methods-2.2 {covers leak condition test for nested methods calls within eval, bug [8e632ce049]} -setup { itcl::class C1 { proc factory {} { set obj [C1 #auto] $obj myeval [list $obj read] itcl::delete object $obj } method myeval {script} { eval $script } method read {} { myeval {} } } } -body { time { C1::factory } 50 list 0 } -result 0 -cleanup { itcl::delete class C1 } test methods-2.3 {call of method after object is destroyed inside other methods, SF-bug [c1289b1c32]} -setup { proc c1test {} { return c1test } itcl::class C1 { public method m1 {} { itcl::delete object $this c1test } public method m2 {} { rename $this {} c1test } public method c1test {} { return C1::c1test } } } -body { set result {} set obj [C1 #auto] lappend result [catch {$obj m1} v] $v [namespace which -command $obj] set obj [C1 #auto] lappend result [catch {$obj m2} v] $v [namespace which -command $obj] } -match glob -result {1 * {} 1 * {}} -cleanup { itcl::delete class C1 rename c1test {} } # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_args ::tcltest::cleanupTests return itcl4.2.2/tests/local.test0000644003604700454610000000432314137636151014136 0ustar dgp771div# # Tests for "local" command for creating objects local to a proc # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Test "local" to create objects that only exist within a proc # ---------------------------------------------------------------------- test local-1.1 {define a class to use for testing} { itcl::class test_local { common status "" constructor {} { lappend status "created $this" } destructor { lappend status "deleted $this" } proc clear {} { set status "" } proc check {} { return $status } proc test {} { itcl::local test_local #auto lappend status "processing" } proc test2 {} { itcl::local test_local #auto lappend status "call test..." test lappend status "...back" } } test_local #auto } {test_local0} test local-1.2 {} { test_local::clear test_local::test test_local::check } {{created ::test_local::test_local1} processing {deleted ::test_local::test_local1}} test local-1.3 {} { test_local::clear test_local::test2 test_local::check } {{created ::test_local::test_local2} {call test...} {created ::test_local::test_local3} processing {deleted ::test_local::test_local3} ...back {deleted ::test_local::test_local2}} test local-1.4 {} { itcl::find objects -isa test_local } {test_local0} itcl::delete class test_local ::tcltest::cleanupTests return itcl4.2.2/tests/interp.test0000644003604700454610000000516614137636151014353 0ustar dgp771div# # Tests for using [incr Tcl] in child interpreters # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Make sure that child interpreters can be created and loaded # with [incr Tcl]... # ---------------------------------------------------------------------- test interp-1.1 {create a child interp with [incr Tcl]} { interp create child load "" Itcl child list [child eval "namespace children :: itcl"] [interp delete child] } {::itcl {}} test interp-1.2 {create a safe child interp with [incr Tcl]} { interp create -safe child load "" Itcl child list [child eval "namespace children :: itcl"] [interp delete child] } {::itcl {}} test interp-1.3 {errors are okay when child interp is deleted} { catch {interp delete child} interp create child load "" Itcl child child eval { itcl::class Troublemaker { destructor { error "cannot delete this object" } } itcl::class Foo { variable obj "" constructor {} { set obj [Troublemaker #auto] } destructor { delete object $obj } } Foo f } interp delete child } {} test interp-1.4 {one namespace can cause another to be destroyed} { interp create child load "" Itcl child child eval { namespace eval group { itcl::class base1 {} itcl::class base2 {} } itcl::class TroubleMaker { inherit group::base1 group::base2 } } interp delete child } {} test interp-1.5 {cleanup interp object list, this should not include an object that deletes itself in ctor} { interp create child load "" Itcl child child eval { itcl::class DeleteSelf { constructor {} { itcl::delete object $this } } DeleteSelf ds } interp delete child } {} ::tcltest::cleanupTests return itcl4.2.2/tests/inherit.test0000644003604700454610000005305414137636151014513 0ustar dgp771div# # Tests for inheritance and scope handling # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Test construction/destruction with inheritance # ---------------------------------------------------------------------- test inherit-1.1 {define classes with constructors/destructors} { variable ::test_cd_watch "" itcl::class test_cd_foo { constructor {x y} { global ::test_cd_watch lappend test_cd_watch "foo: $x $y" } destructor { global ::test_cd_watch lappend test_cd_watch "foo destruct" } } itcl::class test_cd_bar { constructor {args} { global ::test_cd_watch lappend test_cd_watch "bar: $args" } destructor { global ::test_cd_watch lappend test_cd_watch "bar destruct" } } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar constructor {x y args} { test_cd_foo::constructor $x $y } { global ::test_cd_watch lappend test_cd_watch "foobar: $x $y ($args)" } destructor { global ::test_cd_watch lappend test_cd_watch "foobar destruct" } } itcl::class test_cd_geek { constructor {} { global ::test_cd_watch lappend test_cd_watch "geek" } destructor { global ::test_cd_watch lappend test_cd_watch "geek destruct" } } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek constructor {x} { eval test_cd_foobar::constructor 1 2 fred $x } { global ::test_cd_watch lappend test_cd_watch "mongrel: $x" } destructor { global ::test_cd_watch lappend test_cd_watch "mongrel destruct" } } itcl::class test_cd_none { inherit test_cd_bar test_cd_geek } itcl::class test_cd_skip { inherit test_cd_none constructor {} { global ::test_cd_watch lappend test_cd_watch "skip" } destructor { global ::test_cd_watch lappend test_cd_watch "skip destruct" } } } {} test inherit-1.2 {constructors should be invoked in the proper order} { set ::test_cd_watch "" list [test_cd_mongrel #auto bob] [set ::test_cd_watch] } {test_cd_mongrel0 {{foo: 1 2} {bar: } {foobar: 1 2 (fred bob)} geek {mongrel: bob}}} test inherit-1.3 {destructors should be invoked in the proper order} { set ::test_cd_watch "" list [itcl::delete object test_cd_mongrel0] [set ::test_cd_watch] } {{} {{mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} test inherit-1.4 {constructors are optional} { set ::test_cd_watch "" list [test_cd_none #auto] [set ::test_cd_watch] } {test_cd_none0 {geek {bar: }}} test inherit-1.5 {destructors are optional} { set ::test_cd_watch "" list [itcl::delete object test_cd_none0] [set ::test_cd_watch] } {{} {{bar destruct} {geek destruct}}} test inherit-1.6 {construction ok if constructors are missing} { set ::test_cd_watch "" list [test_cd_skip #auto] [set ::test_cd_watch] } {test_cd_skip0 {geek {bar: } skip}} test inherit-1.7 {destruction ok if destructors are missing} { set ::test_cd_watch "" list [itcl::delete object test_cd_skip0] [set ::test_cd_watch] } {{} {{skip destruct} {bar destruct} {geek destruct}}} test inherit-1.8 {errors during construction are cleaned up and reported} knownBug { global errorInfo test_cd_watch set test_cd_watch "" itcl::body test_cd_bar::constructor {args} {error "bar: failed"} list [catch {test_cd_mongrel #auto bob} msg] $msg \ $errorInfo $test_cd_watch } {1 {bar: failed} {bar: failed while executing "error "bar: failed"" while constructing object "::test_cd_mongrel1" in ::test_cd_bar::constructor (body line 1) while constructing object "::test_cd_mongrel1" in ::test_cd_foobar::constructor (body line 1) invoked from within "test_cd_foobar::constructor 1 2 fred bob" ("eval" body line 1) invoked from within "eval test_cd_foobar::constructor 1 2 fred $x" while constructing object "::test_cd_mongrel1" in ::test_cd_mongrel::constructor (body line 2) invoked from within "::itcl::parser::handleClass test_cd_mongrel ::test_cd_mongrel #auto bob" invoked from within "test_cd_mongrel #auto bob"} {{foo: 1 2} {mongrel destruct} {foobar destruct} {foo destruct} {bar destruct} {geek destruct}}} test inherit-1.9 {errors during destruction prevent object delete} { global errorInfo test_cd_watch itcl::body test_cd_bar::constructor {args} {return "bar: $args"} itcl::body test_cd_bar::destructor {} {error "bar: failed"} test_cd_mongrel mongrel1 ted set test_cd_watch "" list [catch {itcl::delete object mongrel1} msg] $msg \ $errorInfo $test_cd_watch [itcl::find objects mongrel*] } {1 {bar: failed} {bar: failed while executing "error "bar: failed"" while deleting object "::mongrel1" in ::test_cd_bar::destructor (body line 1) invoked from within "itcl::delete object mongrel1"} {{mongrel destruct} {foobar destruct} {foo destruct}} mongrel1} test inherit-1.10 {errors during destruction prevent class delete} { itcl::body test_cd_bar::destructor {} {error "bar: failed"} test_cd_mongrel mongrel2 xxx list [catch {itcl::delete class test_cd_foo} msg] $msg } {1 {bar: failed}} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test data member access and scoping # ---------------------------------------------------------------------- test inherit-2.1 {define classes with data members} { itcl::class test_cd_foo { protected variable x "foo-x" method do {args} {eval $args} } itcl::class test_cd_bar { protected variable x "bar-x" method do {args} {eval $args} } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar method do {args} {eval $args} } itcl::class test_cd_geek { method do {args} {eval $args} } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek protected variable x "mongrel-x" method do {args} {eval $args} } } {} test inherit-2.2 {"info" provides access to shadowed data members} { test_cd_mongrel #auto list [lsort [test_cd_mongrel0 info variable]] \ [test_cd_mongrel0 info variable test_cd_foo::x] \ [test_cd_mongrel0 info variable test_cd_bar::x] \ [test_cd_mongrel0 info variable test_cd_mongrel::x] \ [test_cd_mongrel0 info variable x] } {{::test_cd_bar::x ::test_cd_foo::x ::test_cd_mongrel::this ::test_cd_mongrel::x} {protected variable ::test_cd_foo::x foo-x foo-x} {protected variable ::test_cd_bar::x bar-x bar-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x} {protected variable ::test_cd_mongrel::x mongrel-x mongrel-x}} test inherit-2.3 {variable resolution works properly in methods} { list [test_cd_mongrel0 test_cd_foo::do set x] \ [test_cd_mongrel0 test_cd_bar::do set x] \ [test_cd_mongrel0 test_cd_foobar::do set x] \ [test_cd_mongrel0 test_cd_mongrel::do set x] } {foo-x bar-x foo-x mongrel-x} test inherit-2.4 {methods have access to shadowed data members} { list [test_cd_mongrel0 test_cd_foobar::do set x] \ [test_cd_mongrel0 test_cd_foobar::do set test_cd_foo::x] \ [test_cd_mongrel0 test_cd_foobar::do set test_cd_bar::x] \ [test_cd_mongrel0 test_cd_mongrel::do set test_cd_foo::x] \ [test_cd_mongrel0 test_cd_mongrel::do set test_cd_bar::x] } {foo-x foo-x bar-x foo-x bar-x} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test public variables and "configure" method # ---------------------------------------------------------------------- test inherit-3.1 {define classes with public variables} { variable ::test_cd_watch "" itcl::class test_cd_foo { public variable x "foo-x" { global test_cd_watch lappend test_cd_watch "foo: $x in scope [namespace current]" } method do {args} {eval $args} } itcl::class test_cd_bar { public variable x "bar-x" { global test_cd_watch lappend test_cd_watch "bar: $x in scope [namespace current]" } method do {args} {eval $args} } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar method do {args} {eval $args} } itcl::class test_cd_geek { method do {args} {eval $args} } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek public variable x "mongrel-x" { global test_cd_watch lappend test_cd_watch "mongrel: $x in scope [namespace current]" } method do {args} {eval $args} } } {} test inherit-3.2 {create an object with public variables} { test_cd_mongrel #auto } {test_cd_mongrel0} test inherit-3.3 {"configure" lists all public variables} { lsort [test_cd_mongrel0 configure] } {{-test_cd_bar::x bar-x bar-x} {-test_cd_foo::x foo-x foo-x} {-x mongrel-x mongrel-x}} test inherit-3.4 {"configure" treats simple names as "most specific"} { lsort [test_cd_mongrel0 configure -x] } {-x mongrel-x mongrel-x} test inherit-3.5 {"configure" treats simple names as "most specific"} { set ::test_cd_watch "" list [test_cd_mongrel0 configure -x hello] \ [set ::test_cd_watch] } {{} {{mongrel: hello in scope ::test_cd_mongrel}}} test inherit-3.6 {"configure" allows access to shadowed options} { set ::test_cd_watch "" list [test_cd_mongrel0 configure -test_cd_foo::x hello] \ [test_cd_mongrel0 configure -test_cd_bar::x there] \ [set ::test_cd_watch] } {{} {} {{foo: hello in scope ::test_cd_foo} {bar: there in scope ::test_cd_bar}}} test inherit-3.7 {"configure" will change several variables at once} { set ::test_cd_watch "" list [test_cd_mongrel0 configure -x one \ -test_cd_foo::x two \ -test_cd_bar::x three] \ [set ::test_cd_watch] } {{} {{mongrel: one in scope ::test_cd_mongrel} {foo: two in scope ::test_cd_foo} {bar: three in scope ::test_cd_bar}}} test inherit-3.8 {"cget" does proper name resolution} { list [test_cd_mongrel0 cget -x] \ [test_cd_mongrel0 cget -test_cd_foo::x] \ [test_cd_mongrel0 cget -test_cd_bar::x] \ [test_cd_mongrel0 cget -test_cd_mongrel::x] } {one two three one} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test inheritance info # ---------------------------------------------------------------------- test inherit-4.1 {define classes for inheritance info} { itcl::class test_cd_foo { method do {args} {eval $args} } itcl::class test_cd_bar { method do {args} {eval $args} } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar method do {args} {eval $args} } itcl::class test_cd_geek { method do {args} {eval $args} } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek method do {args} {eval $args} } } {} test inherit-4.2 {create an object for inheritance tests} { test_cd_mongrel #auto } {test_cd_mongrel0} test inherit-4.3 {"info class" should be virtual} { list [test_cd_mongrel0 info class] \ [test_cd_mongrel0 test_cd_foo::do info class] \ [test_cd_mongrel0 test_cd_geek::do info class] } {::test_cd_mongrel ::test_cd_mongrel ::test_cd_mongrel} test inherit-4.4 {"info inherit" depends on class scope} { list [test_cd_mongrel0 info inherit] \ [test_cd_mongrel0 test_cd_foo::do info inherit] \ [test_cd_mongrel0 test_cd_foobar::do info inherit] } {{::test_cd_foobar ::test_cd_geek} {} {::test_cd_foo ::test_cd_bar}} test inherit-4.5 {"info heritage" depends on class scope} { list [test_cd_mongrel0 info heritage] \ [test_cd_mongrel0 test_cd_foo::do info heritage] \ [test_cd_mongrel0 test_cd_foobar::do info heritage] } {{::test_cd_mongrel ::test_cd_foobar ::test_cd_foo ::test_cd_bar ::test_cd_geek} ::test_cd_foo {::test_cd_foobar ::test_cd_foo ::test_cd_bar}} test inherit-4.6 {built-in "isa" method works} { set status "" foreach c [test_cd_mongrel0 info heritage] { lappend status [test_cd_mongrel0 isa $c] } set status } {1 1 1 1 1} test inherit-4.7 {built-in "isa" method works within methods} { set status "" foreach c [test_cd_mongrel0 info heritage] { lappend status [test_cd_mongrel0 test_cd_foo::do isa $c] } set status } {1 1 1 1 1} test inherit-4.8 {built-in "isa" method recognizes bad classes} { itcl::class test_cd_other {} test_cd_mongrel0 isa test_cd_other } {0} test inherit-4.9 {built-in "isa" method recognizes bad classes} { list [catch {test_cd_mongrel0 isa test_cd_bogus} msg] $msg } {1 {class "test_cd_bogus" not found in context "::test_cd_foo"}} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test "find objects" # ---------------------------------------------------------------------- test inherit-5.1 {define classes for inheritance info} { itcl::class test_cd_foo { } itcl::class test_cd_bar { } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar } itcl::class test_cd_geek { } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek } } {} test inherit-5.2 {create objects for info tests} { list [test_cd_foo #auto] [test_cd_foo #auto] \ [test_cd_foobar #auto] \ [test_cd_geek #auto] \ [test_cd_mongrel #auto] } {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_geek0 test_cd_mongrel0} test inherit-5.3 {find objects: -class qualifier} { lsort [itcl::find objects -class test_cd_foo] } {test_cd_foo0 test_cd_foo1} test inherit-5.4 {find objects: -class qualifier} { lsort [itcl::find objects -class test_cd_mongrel] } {test_cd_mongrel0} test inherit-5.5 {find objects: -isa qualifier} { lsort [itcl::find objects -isa test_cd_foo] } {test_cd_foo0 test_cd_foo1 test_cd_foobar0 test_cd_mongrel0} test inherit-5.6 {find objects: -isa qualifier} { lsort [itcl::find objects -isa test_cd_mongrel] } {test_cd_mongrel0} test inherit-5.7 {find objects: name qualifier} { lsort [itcl::find objects test_cd_foo*] } {test_cd_foo0 test_cd_foo1 test_cd_foobar0} test inherit-5.8 {find objects: -class and -isa qualifiers} { lsort [itcl::find objects -isa test_cd_foo -class test_cd_foobar] } {test_cd_foobar0} test inherit-5.9 {find objects: -isa and name qualifiers} { lsort [itcl::find objects -isa test_cd_foo *0] } {test_cd_foo0 test_cd_foobar0 test_cd_mongrel0} test inherit-5.10 {find objects: usage errors} { list [catch {itcl::find objects -xyzzy value} msg] $msg } {1 {wrong # args: should be "itcl::find objects ?-class className? ?-isa className? ?pattern?"}} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test method scoping and execution # ---------------------------------------------------------------------- test inherit-6.1 {define classes for scope tests} { itcl::class test_cd_foo { method check {} {return "foo"} method do {args} {return "foo says: [eval $args]"} } itcl::class test_cd_bar { method check {} {return "bar"} method do {args} {return "bar says: [eval $args]"} } itcl::class test_cd_foobar { inherit test_cd_foo test_cd_bar method check {} {return "foobar"} method do {args} {return "foobar says: [eval $args]"} } itcl::class test_cd_geek { method check {} {return "geek"} method do {args} {return "geek says: [eval $args]"} } itcl::class test_cd_mongrel { inherit test_cd_foobar test_cd_geek method check {} {return "mongrel"} method do {args} {return "mongrel says: [eval $args]"} } } {} test inherit-6.2 {create objects for scoping tests} { list [test_cd_mongrel #auto] [test_cd_foobar #auto] } {test_cd_mongrel0 test_cd_foobar0} test inherit-6.3 {methods are "virtual" outside of the class} { test_cd_mongrel0 check } {mongrel} test inherit-6.4 {specific methods can be accessed by name} { test_cd_mongrel0 test_cd_foo::check } {foo} test inherit-6.5 {methods are "virtual" within a class too} { test_cd_mongrel0 test_cd_foobar::do check } {foobar says: mongrel} test inherit-6.6 {methods are executed where they were defined} { list [test_cd_mongrel0 test_cd_foo::do namespace current] \ [test_cd_mongrel0 test_cd_foobar::do namespace current] \ [test_cd_mongrel0 do namespace current] \ } {{foo says: ::test_cd_foo} {foobar says: ::test_cd_foobar} {mongrel says: ::test_cd_mongrel}} test inherit-6.7 {"virtual" command no longer exists} { list [catch { test_cd_mongrel0 test_cd_foobar::do virtual namespace current } msg] $msg } {1 {invalid command name "virtual"}} test inherit-6.8 {"previous" command no longer exists} { list [catch { test_cd_mongrel0 test_cd_foobar::do previous check } msg] $msg } {1 {invalid command name "previous"}} test inherit-6.9 {errors are detected and reported across class boundaries} { # # NOTE: For tcl8.2.3 and earlier the stack trace will have # 'invoked from within "eval $args"' for the first eval # statement. For later versions, it does not. Use # string match to reduce the sensitivity to that. # list [catch { test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error" } msg] $msg [string match {some error ("eval" body line 1)* (object "::test_cd_foobar0" method "::test_cd_foobar::do" body line 1) invoked from within "test_cd_foobar0 do error test {some error}" ("eval" body line 1) invoked from within "eval $args" (object "::test_cd_mongrel0" method "::test_cd_mongrel::do" body line 1) invoked from within "test_cd_mongrel0 do test_cd_foobar0 do error "test" "some error""} [set ::errorInfo]] } {1 test 1} test inherit-6.10 {errors codes are preserved across class boundaries} { list [catch { test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" CODE-BLUE } msg] $msg [set ::errorCode] } {1 test CODE-BLUE} test inherit-6.11 {multi-value error codes are preserved across class boundaries} { list [catch { test_cd_mongrel0 do test_cd_foobar0 do error "test" "problem" "CODE BLUE 123" } msg] $msg [set ::errorCode] } {1 test {CODE BLUE 123}} eval namespace delete [itcl::find classes test_cd_*] # ---------------------------------------------------------------------- # Test inheritance errors # ---------------------------------------------------------------------- test inherit-7.1 {cannot inherit from non-existant class} { list [catch { itcl::class bogus { inherit non_existant_class_xyzzy } } msg] $msg } {1 {cannot inherit from "non_existant_class_xyzzy" (class "non_existant_class_xyzzy" not found in context "::")}} test inherit-7.2 {cannot inherit from procs} { proc inherit_test_proc {x y} { error "never call this" } list [catch { itcl::class bogus { inherit inherit_test_proc } } msg] $msg } {1 {cannot inherit from "inherit_test_proc" (class "inherit_test_proc" not found in context "::")}} test inherit-7.3 {cannot inherit from yourself} { list [catch { itcl::class bogus { inherit bogus } } msg] $msg } {1 {class "bogus" cannot inherit from itself}} test inherit-7.4 {cannot have more than one inherit statement} { list [catch { itcl::class test_inherit_base1 { } itcl::class test_inherit_base2 { } itcl::class bogus { inherit test_inherit_base1 inherit test_inherit_base2 } } msg] $msg } {1 {inheritance "test_inherit_base1 " already defined for class "::bogus"}} ::itcl::delete class test_inherit_base1 test_inherit_base2 # ---------------------------------------------------------------------- # Multiple base class error detection # ---------------------------------------------------------------------- test inherit-8.1 {cannot inherit from the same base class more than once} { itcl::class test_mi_base {} itcl::class test_mi_foo {inherit test_mi_base} itcl::class test_mi_bar {inherit test_mi_base} list [catch { itcl::class test_mi_foobar {inherit test_mi_foo test_mi_bar} } msg] $msg } {1 {class "::test_mi_foobar" inherits base class "::test_mi_base" more than once: test_mi_foobar->test_mi_foo->test_mi_base test_mi_foobar->test_mi_bar->test_mi_base}} itcl::delete class test_mi_base ::tcltest::cleanupTests return itcl4.2.2/tests/info.test0000644003604700454610000003711314137636151014002 0ustar dgp771div# # Tests for information accessed by the "info" command # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Class definition with one of everything # ---------------------------------------------------------------------- test info-1.1 {define a simple class} { itcl::class test_info_base { method base {} {return "default"} variable base {} method do {args} {eval $args} } itcl::class test_info { inherit test_info_base constructor {args} { foreach v [info variable] { catch {set $v "new-[set $v]"} } } destructor {} method defm {} {return "default method"} public method pubm {x} {return "public method"} protected method prom {x y} {return "protected method"} private method prim {x y z} {return "private method"} proc defp {} {return "default proc"} public proc pubp {x} {return "public proc"} protected proc prop {x y} {return "protected proc"} private proc prip {x y z} {return "private proc"} variable defv "default" public variable pubv "public" {set pubv "public: $pubv"} protected variable prov "protected" private variable priv "private" common defc "default" public common pubc "public" protected common proc "protected" private common pric "private" method uninitm proc uninitp {x y} variable uninitv common uninitc set uninitc(0) zero set uninitc(1) one } } "" test info-1.2 {info: errors trigger usage info} { list [catch {namespace eval test_info {info}} msg] $msg } {1 {wrong # args: should be one of... info args procname info body procname info class info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.3 {info: errors trigger usage info} { test_info ti list [catch {ti info} msg] $msg } {1 {wrong # args: should be one of... info args procname info body procname info class info function ?name? ?-protection? ?-type? ?-name? ?-args? ?-body? info heritage info inherit info variable ?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config? ?-scope? ...and others described on the man page}} test info-1.4 {info: info class works on class itself} { namespace eval test_info { info class } } {::test_info} # ---------------------------------------------------------------------- # Data members # ---------------------------------------------------------------------- test info-2.1 {info: all variables} { lsort [ti info variable] } {::test_info::defc ::test_info::defv ::test_info::pric ::test_info::priv ::test_info::proc ::test_info::prov ::test_info::pubc ::test_info::pubv ::test_info::this ::test_info::uninitc ::test_info::uninitv ::test_info_base::base} test info-2.2a {info: public variables} { ti info variable pubv } {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} test info-2.2b {info: public variables} -body { list [ti info variable pubv -protection] \ [ti info variable pubv -type] \ [ti info variable pubv -name] \ [ti info variable pubv -init] \ [ti info variable pubv -config] \ [ti info variable pubv -value] \ [ti info variable pubv -scope] \ } -match glob -result {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public ::itcl::internal::variables::oo::Obj*::test_info::pubv} test info-2.3a {info: protected variables} { ti info variable prov } {protected variable ::test_info::prov protected new-protected} test info-2.3b {info: protected variables} -body { list [ti info variable prov -protection] \ [ti info variable prov -type] \ [ti info variable prov -name] \ [ti info variable prov -init] \ [ti info variable prov -value] \ [ti info variable prov -scope] \ } -match glob -result {protected variable ::test_info::prov protected new-protected ::itcl::internal::variables::oo::Obj*::test_info::prov} test info-2.4a {info: private variables} { ti info variable priv } {private variable ::test_info::priv private new-private} test info-2.4b {info: private variables} -body { list [ti info variable priv -protection] \ [ti info variable priv -type] \ [ti info variable priv -name] \ [ti info variable priv -init] \ [ti info variable priv -value] \ [ti info variable priv -scope] \ } -match glob -result {private variable ::test_info::priv private new-private ::itcl::internal::variables::oo::Obj*::test_info::priv} test info-2.5 {"this" variable is built in} { ti info variable this } {protected variable ::test_info::this ::ti ::ti} test info-2.6 {info: protected/private variables have no "config" code} { list [ti info variable prov -config] [ti info variable priv -config] } {{} {}} test info-2.7 {by default, variables are "protected"} { ti info variable defv } {protected variable ::test_info::defv default new-default} test info-2.8 {data members may be uninitialized} { ti info variable uninitv } {protected variable ::test_info::uninitv } test info-2.9a {info: public common variables} { ti info variable pubc } {public common ::test_info::pubc public new-public} test info-2.9b {info: public common variables} { list [ti info variable pubc -protection] \ [ti info variable pubc -type] \ [ti info variable pubc -name] \ [ti info variable pubc -init] \ [ti info variable pubc -value] \ [ti info variable pubc -scope] \ } {public common ::test_info::pubc public new-public ::test_info::pubc} test info-2.10a {info: protected common variables} { ti info variable proc } {protected common ::test_info::proc protected new-protected} test info-2.10b {info: protected common variables} { list [ti info variable proc -protection] \ [ti info variable proc -type] \ [ti info variable proc -name] \ [ti info variable proc -init] \ [ti info variable proc -value] \ [ti info variable proc -scope] \ } {protected common ::test_info::proc protected new-protected ::itcl::internal::variables::test_info::proc} test info-2.11a {info: private common variables} { ti info variable pric } {private common ::test_info::pric private new-private} test info-2.11b {info: private common variables} { list [ti info variable pric -protection] \ [ti info variable pric -type] \ [ti info variable pric -name] \ [ti info variable pric -init] \ [ti info variable pric -value] \ [ti info variable pric -scope] \ } {private common ::test_info::pric private new-private ::itcl::internal::variables::test_info::pric} test info-2.12 {info: public/protected/private vars have no "config" code} { list [ti info variable pubc -config] \ [ti info variable proc -config] \ [ti info variable pric -config] } {{} {} {}} test info-2.13 {by default, variables are "protected"} { ti info variable defc } {protected common ::test_info::defc default new-default} test info-2.14 {data members may be uninitialized} { ti info variable uninitc } {protected common ::test_info::uninitc } test info-2.15 {common vars can be initialized within class definition} { list [namespace eval test_info {lsort [array names uninitc]}] \ [namespace eval test_info {set uninitc(0)}] \ [namespace eval test_info {set uninitc(1)}] } {{0 1} zero one} test info-2.16 {flag syntax errors} { list [catch {ti info variable defv -xyzzy} msg] $msg } {1 {bad option "-xyzzy": must be -config, -init, -name, -protection, -type, -value, or -scope}} # ---------------------------------------------------------------------- # Member functions # ---------------------------------------------------------------------- test info-3.1 {info: all functions} { lsort [ti info function] } {::test_info::constructor ::test_info::defm ::test_info::defp ::test_info::destructor ::test_info::prim ::test_info::prip ::test_info::prom ::test_info::prop ::test_info::pubm ::test_info::pubp ::test_info::uninitm ::test_info::uninitp ::test_info_base::base ::test_info_base::cget ::test_info_base::configure ::test_info_base::do ::test_info_base::isa} test info-3.2a {info: public methods} { ti info function pubm } {public method ::test_info::pubm x {return "public method"}} test info-3.2b {info: public methods} { list [ti info function pubm -protection] \ [ti info function pubm -type] \ [ti info function pubm -name] \ [ti info function pubm -args] \ [ti info function pubm -body] } {public method ::test_info::pubm x {return "public method"}} test info-3.3a {info: protected methods} { ti info function prom } {protected method ::test_info::prom {x y} {return "protected method"}} test info-3.3b {info: protected methods} { list [ti info function prom -protection] \ [ti info function prom -type] \ [ti info function prom -name] \ [ti info function prom -args] \ [ti info function prom -body] } {protected method ::test_info::prom {x y} {return "protected method"}} test info-3.4a {info: private methods} { ti info function prim } {private method ::test_info::prim {x y z} {return "private method"}} test info-3.4b {info: private methods} { list [ti info function prim -protection] \ [ti info function prim -type] \ [ti info function prim -name] \ [ti info function prim -args] \ [ti info function prim -body] } {private method ::test_info::prim {x y z} {return "private method"}} test info-3.5 {"configure" function is built in} { ti info function configure } {public method ::test_info_base::configure {?-option? ?value -option value...?} @itcl-builtin-configure} test info-3.6 {by default, methods are "public"} { ti info function defm } {public method ::test_info::defm {} {return "default method"}} test info-3.7 {methods may not have arg lists or bodies defined} { ti info function uninitm } {public method ::test_info::uninitm } test info-3.8a {info: public procs} { ti info function pubp } {public proc ::test_info::pubp x {return "public proc"}} test info-3.8b {info: public procs} { list [ti info function pubp -protection] \ [ti info function pubp -type] \ [ti info function pubp -name] \ [ti info function pubp -args] \ [ti info function pubp -body] } {public proc ::test_info::pubp x {return "public proc"}} test info-3.9a {info: protected procs} { ti info function prop } {protected proc ::test_info::prop {x y} {return "protected proc"}} test info-3.9b {info: protected procs} { list [ti info function prop -protection] \ [ti info function prop -type] \ [ti info function prop -name] \ [ti info function prop -args] \ [ti info function prop -body] } {protected proc ::test_info::prop {x y} {return "protected proc"}} test info-3.10a {info: private procs} { ti info function prip } {private proc ::test_info::prip {x y z} {return "private proc"}} test info-3.10b {info: private procs} { list [ti info function prip -protection] \ [ti info function prip -type] \ [ti info function prip -name] \ [ti info function prip -args] \ [ti info function prip -body] } {private proc ::test_info::prip {x y z} {return "private proc"}} test info-3.11 {by default, procs are "public"} { ti info function defp } {public proc ::test_info::defp {} {return "default proc"}} test info-3.12 {procs may not have arg lists or bodies defined} { ti info function uninitp } {public proc ::test_info::uninitp {x y} } test info-3.13 {flag syntax errors} { list [catch {ti info function defm -xyzzy} msg] $msg } {1 {bad option "-xyzzy": must be -args, -body, -name, -protection, or -type}} # ---------------------------------------------------------------------- # Other object-related queries # ---------------------------------------------------------------------- test info-4.1a {query class (wrong # args)} { list [catch {ti info class x} result] $result } {1 {wrong # args: should be "info class"}} test info-4.1b {query most-specific class} { list [ti info class] [ti do info class] } {::test_info ::test_info} test info-4.2a {query inheritance info (wrong # args)} { list [catch {ti info inherit x} result] $result } {1 {wrong # args: should be "info inherit"}} test info-4.2b {query inheritance info} { list [ti info inherit] [ti do info inherit] } {::test_info_base {}} test info-4.2c {query inheritance info} { ti do ti info inherit } {::test_info_base} test info-4.3a {query heritage info (wrong # args)} { list [catch {ti info heritage x} result] $result } {1 {wrong # args: should be "info heritage"}} test info-4.3b {query heritage info} { list [ti info heritage] [ti do info heritage] } {{::test_info ::test_info_base} ::test_info_base} test info-4.3c {query heritage info} { ti do ti info heritage } {::test_info ::test_info_base} test info-4.4a {query argument list (wrong # args)} { list [catch {ti info args} result] $result \ [catch {ti info args x y} result] $result } {1 {wrong # args: should be "info args function"} 1 {wrong # args: should be "info args function"}} test info-4.4b {query argument list} { ti info args prim } {x y z} test info-4.4c {query argument list (undefined)} { ti info args uninitm } {} test info-4.4d {query argument list of real proc} { ti info args ::unknown } {args} test info-4.4e {query argument list of real proc} { itcl::builtin::Info args ::unknown } {args} test info-4.5a {query body (wrong # args)} { list [catch {ti info body} result] $result \ [catch {ti info body x y} result] $result } {1 {wrong # args: should be "info body function"} 1 {wrong # args: should be "info body function"}} test info-4.5b {query body} { ti info body prim } {return "private method"} test info-4.5c {query body (undefined)} { ti info body uninitm } {} # ---------------------------------------------------------------------- # Other parts of the usual "info" command # ---------------------------------------------------------------------- test info-5.1 {info vars} { ti do info vars } {args} test info-5.2 {info exists} { list [ti do info exists args] [ti do info exists xyzzy] } {1 0} test info-6.0 {Bug a03f579f7d} -setup { # Must not segfault itcl::class C { proc p {} {info vars} } } -body { C::p } -cleanup { itcl::delete class C } -result {} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_info test_info_base ::tcltest::cleanupTests return itcl4.2.2/tests/import.test0000644003604700454610000001507214137636151014361 0ustar dgp771div# # Tests for "auto_import" and autoloading facility # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl set ::itcllib [lindex [lsearch -exact -index 1 -inline [info loaded] Itcl] 0] # ---------------------------------------------------------------------- # Test "itcl::import::stub" command # ---------------------------------------------------------------------- test import-1.1 {basic syntax for "stub" command} { list [catch {itcl::import::stub} result] $result } {1 {wrong # args: should be "itcl::import::stub subcommand ?arg ...?"}} test import-1.1a {basic syntax for "stub" command } -body { list [catch {itcl::import::stub} result] $result } -constraints { needs_frq_1773103 } -result {1 {wrong # args: should be one of... stub create name stub exists name}} test import-1.2 {"stub create" requires one argument} { list [catch {itcl::import::stub create} result] $result \ [catch {itcl::import::stub create x y} result] $result } {1 {wrong # args: should be "itcl::import::stub create name"} 1 {wrong # args: should be "itcl::import::stub create name"}} test import-1.3 {"stub exists" requires one argument} { list [catch {itcl::import::stub exists} result] $result \ [catch {itcl::import::stub exists x y} result] $result } {1 {wrong # args: should be "itcl::import::stub exists name"} 1 {wrong # args: should be "itcl::import::stub exists name"}} set interp [interp create] $interp eval {set ::tcl::inl_mem_test 0} $interp eval " [list ::load $::itcllib Itcl] [::tcltest::configure -load] proc auto_load {cmd {namespace {}}} { global debug proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\] append debug \"(auto_load: \$cmd)\" return 1 } " test import-1.4 {"stub create" creates a stub that triggers autoloading} { $interp eval { set debug "" list [itcl::import::stub create foo::bar::test] \ [info commands ::foo::bar::test] \ [::foo::bar::test 1 2 3] \ $debug } } {{} ::foo::bar::test {::foo::bar::test: 1 2 3} {(auto_load: ::foo::bar::test)}} test import-1.5 {"stub exists" recognizes stubs created by "stub create"} { $interp eval { set debug "" itcl::import::stub create foo::bar::stub1 proc foo::bar::proc1 {{args {}}} {return "proc1: $args"} list [itcl::import::stub exists foo::bar::stub1] \ [itcl::import::stub exists foo::bar::proc1] } } {1 0} test import-1.6 {stubs can be autoloaded and replaced} { $interp eval { set debug "" itcl::import::stub create foo::bar::stub2 list [itcl::import::stub exists foo::bar::stub2] \ [::foo::bar::stub2 a b c] \ [itcl::import::stub exists foo::bar::stub2] \ [::foo::bar::stub2 a b c] \ $debug } } {1 {::foo::bar::stub2: a b c} 0 {::foo::bar::stub2: a b c} {(auto_load: ::foo::bar::stub2)}} catch {interp delete $interp} # ---------------------------------------------------------------------- # Test "itcl::import::stub" command # ---------------------------------------------------------------------- set interp [interp create] $interp eval {set ::tcl::inl_mem_test 0} $interp eval " [list ::load $::itcllib Itcl] [::tcltest::configure -load] proc auto_load {cmd {namespace {}}} { proc \$cmd {args} \[format {return \"%s: \$args\"} \$cmd\] return 1 } " test import-2.1 {initialize some commands for autoloading} { $interp eval { namespace eval test { namespace export foo* } itcl::import::stub create ::test::foo1 itcl::import::stub create ::test::foo2 lsort [info commands ::test::*] } } {::test::foo1 ::test::foo2} test import-2.2 {stubs can be imported into other namespaces} { $interp eval { namespace eval user1 { namespace import ::test::* } namespace eval user2 { namespace import ::test::* } namespace eval user3 { namespace import ::test::* } list [lsort [info commands ::user1::*]] \ [namespace origin ::user1::foo1] \ [namespace origin ::user1::foo2] } } {{::user1::foo1 ::user1::foo2} ::test::foo1 ::test::foo2} test import-2.3 {stubs can be autoloaded and imported links remain} { $interp eval { list [::user1::foo1 1 2 3 4] \ [namespace origin ::user1::foo1] \ [namespace origin ::user2::foo1] \ [namespace origin ::user3::foo1] \ [itcl::import::stub exists ::test::foo1] } } {{::test::foo1: 1 2 3 4} ::test::foo1 ::test::foo1 ::test::foo1 0} test import-2.4 {itcl::class handles stubs correctly } -body { $interp eval { proc auto_load {cmd {namespace {}}} { itcl::class $cmd { } return 1 } list [::user2::foo2 x] \ [x info class] \ [namespace origin ::user1::foo2] \ [namespace origin ::user2::foo2] \ [namespace origin ::user3::foo2] \ [itcl::import::stub exists ::test::foo2] } } -constraints { only_working_in_itcl3.4 } -result {x ::test::foo2 ::test::foo2 ::test::foo2 ::test::foo2 0} test import-2.5 {itcl::class will overwrite stubs in an existing namespace} { $interp eval { proc auto_load {cmd {namespace {}}} { itcl::class $cmd { } return 1 } namespace eval test::buried { } itcl::import::stub create ::test::buried itcl::import::stub create ::test::buried::stub list [catch {::test::buried xx} result] $result [xx info class] } } {0 xx ::test::buried} test import-2.6 {itcl::class will overwrite stubs} { $interp eval { proc auto_load {cmd {namespace {}}} { itcl::class $cmd { } return 1 } itcl::import::stub create ::test::zonk list [catch {::test::zonk yy} result] $result [yy info class] } } {0 yy ::test::zonk} catch {interp delete $interp} ::tcltest::cleanupTests return itcl4.2.2/tests/helpers.tcl0000644003604700454610000000240514137636151014310 0ustar dgp771div# helpers.tcl -- # # This file contains helper scripts for all tests, like a mem-leak checker, etc. # -loadfile overwrites -load, so restore it from ::env(TESTFLAGS): if {[info exists ::env(TESTFLAGS)]} { array set testargs $::env(TESTFLAGS) if {[info exists ::testargs(-load)]} { eval $::testargs(-load) } unset testargs } package require itcl if {[namespace which -command memory] ne "" && ( ![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test ) } { proc getbytes {} {lindex [split [memory info] \n] 3 3} proc leaktest {script {iterations 3}} { set end [getbytes] for {set i 0} {$i < $iterations} {incr i} { uplevel 1 $script set tmp $end set end [getbytes] } return [expr {$end - $tmp}] } proc itcl_leaktest {testfile} { set leak [leaktest [string map [list \ @test@ $testfile \ @testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}] ] { interp create i load {} Itcl i i eval {set ::tcl::inl_mem_test 0} i eval {package require tcltest; @testargv@} i eval [list source @test@] interp delete i }]] if {$leak} { puts "LEAKED: $leak bytes" } } itcl_leaktest [info script] return -code return } itcl4.2.2/tests/general1.test0000644003604700454610000001772014137636151014547 0ustar dgp771div# # Tests for general class handling # ---------------------------------------------------------------------- # AUTHOR: Wolfgang Großer, Arnulf Wiedemann # wolfgang@grosser-erding.de, arnulf@wiedemann-pri.de # ---------------------------------------------------------------------- # Copyright (c) Wolfgang Großer, Arnulf Wiedemann # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Test protection with inheritance # ---------------------------------------------------------------------- test general1-1.1 {define classes with different protection} { variable ::test_cd_watch "" itcl::class ClassA { private variable priv privA private variable privA privAA protected variable prov provA public variable pubv pubvA constructor {args} { lappend ::test_cd_watch constructorA } private method primA {} { lappend ::test_cd_watch primA set privA Hallo lappend ::test_cd_watch [set priv] } protected method promA {} { lappend ::test_cd_watch promA lappend ::test_cd_watch [set prov] } public method pubmA {} { lappend ::test_cd_watch pubmA lappend ::test_cd_watch [set pubv] } public method doA {args} {eval $args} } itcl::class ClassB { inherit ClassA private variable priv privB private variable privB privBB protected variable prov provB public variable pubv pubvB constructor {args} { lappend ::test_cd_watch [list constructorB $args] } destructor { lappend ::test_cd_watch destructorB } private method primB {} { lappend ::test_cd_watch primB lappend ::test_cd_watch [set priv] } protected method promB {} { lappend ::test_cd_watch promB lappend ::test_cd_watch [set prov] } public method pubmB {} { lappend ::test_cd_watch pubmB lappend ::test_cd_watch [set pubv] } public method doB {args} {eval $args} public method chkThis {} { set prov $this } } itcl::class ClassC { inherit ClassB private variable priv privC protected variable prov provC public variable pubv pubvC constructor {args} { eval ClassB::constructor $args } { lappend ::test_cd_watch [list "start constructorC" $args] ClassA::constructor $args lappend ::test_cd_watch [list "end constructorC"] } private method primC {} { lappend ::test_cd_watch primC lappend ::test_cd_watch [set priv] } protected method promC {} { lappend ::test_cd_watch promC lappend ::test_cd_watch [set prov] } public method pubmC {} { lappend ::test_cd_watch pubmC lappend ::test_cd_watch [set pubv] $this primC } public method pubmC2 {arg1 {arg2 {}} {arg3 xxx}} { lappend ::test_cd_watch "orig pubmC2" } public method doC {args} { eval $args } } } {} test general1-1.2 {constructor of classA should be called twice} { set ::test_cd_watch "" list [ClassC #auto] [set ::test_cd_watch] } {classC0 {constructorA {constructorB {}} {{start constructorC} {}} constructorA {{end constructorC}}}} test general1-1.3 {body command should not produce error} { set ::test_cd_watch "" list [catch { itcl::body ClassC::pubmC2 {aarg1 {aarg2 {}} {arg3 {xxx}}} { lappend ::test_cd_watch "new body command for pubmC2 [list $aarg1 $aarg2 $arg3]" } } msg] $msg [classC0 pubmC2 Hallo] } {0 {} {{new body command for pubmC2 Hallo {} xxx}}} test general1-1.4 {call of configure} { set ::test_cd_watch "" list [lsort [classC0 configure]] } {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC pubvC}}} test general1-1.5 {call of configure with variable} { set ::test_cd_watch "" list [classC0 configure -pubv Arnulf] } {{}} test general1-1.6 {call of configure to check for changes} { set ::test_cd_watch "" list [lsort [classC0 configure]] } {{{-ClassA::pubv pubvA pubvA} {-ClassB::pubv pubvB pubvB} {-pubv pubvC Arnulf}}} test general1-1.7 {call of cget} { set ::test_cd_watch "" list [classC0 cget -pubv] } {Arnulf} test general1-1.8 {private method may not be called} { set ::test_cd_watch "" list [catch {classC0 primC} msg] $msg } {1 {bad option "primC": should be one of... classC0 cget -option classC0 chkThis classC0 configure ?-option? ?value -option value...? classC0 doA ?arg arg ...? classC0 doB ?arg arg ...? classC0 doC ?arg arg ...? classC0 isa className classC0 pubmA classC0 pubmB classC0 pubmC classC0 pubmC2 aarg1 ?aarg2? ?arg3?}} test general1-1.9 {protected method may not be called} { set ::test_cd_watch "" list [catch {classC0 promC} msg] $msg } {1 {bad option "promC": should be one of... classC0 cget -option classC0 chkThis classC0 configure ?-option? ?value -option value...? classC0 doA ?arg arg ...? classC0 doB ?arg arg ...? classC0 doC ?arg arg ...? classC0 isa className classC0 pubmA classC0 pubmB classC0 pubmC classC0 pubmC2 aarg1 ?aarg2? ?arg3?}} test general1-1.10 {can call private and protected methods from within the class} { set ::test_cd_watch "" list [catch {classC0 doC primC} msg] $msg [catch {classC0 doC promC} msg] $msg } {0 {primC privC} 0 {primC privC promC provC}} test general1-1.11 {*cannot* call private methods of inherited classes} { set ::test_cd_watch "" list [catch {classC0 doC primB} msg] $msg [catch {classC0 doC primA} msg] $msg } {1 {invalid command name "primB"} 1 {invalid command name "primA"}} test general1-1.12 {can call protected and public methods of inherited classes} { set ::test_cd_watch "" list [catch {classC0 doC promB} msg] $msg [catch {classC0 doC pubmC} msg] $msg [catch {classC0 doC promA} msg] $msg [catch {classC0 doC pubmA} msg] $msg } {0 {promB provB} 0 {promB provB pubmC Arnulf primC privC} 0 {promB provB pubmC Arnulf primC privC promA provA} 0 {promB provB pubmC Arnulf primC privC promA provA pubmA pubvA}} test general1-1.13 {"this" variable} { set ::test_cd_watch "" list [catch {classC0 doC doB set $this} msg] $msg } {1 {can't read "this": no such variable}} test general1-1.14 {can indirect calls through middle class} { set ::test_cd_watch "" list [catch {classC0 doC doB doA primA} msg] $msg [catch {classC0 doC doB doA promA} msg] $msg [catch {classC0 doC doB doA pubmA} msg] $msg } {0 {primA privA} 0 {primA privA promA provA} 0 {primA privA promA provA pubmA pubvA}} test general1-1.15 {*cannot* indirect private calls through middle class} { set ::test_cd_watch "" list [catch {classC0 doC doB primA} msg] $msg [catch {classC0 doC doB primC} msg] $msg } {1 {invalid command name "primA"} 1 {invalid command name "primC"}} test general1-1.16 {*cannot* indirect protected calls through middle class} { set ::test_cd_watch "" list [catch {classC0 doC doB promA} msg] $msg [catch {classC0 doC doB promC} msg] $msg } {0 {promA provA} 1 {invalid command name "promC"}} test general1-1.17 {access variables through calls through middle class} { set ::test_cd_watch "" list [catch {classC0 doC doB set privB} msg] $msg [catch {classC0 doC doB doA set pubv} msg] $msg } {0 privBB 0 pubvA} test general1-1.18 {"this" variable} { set ::test_cd_watch "" list [catch {classC0 doB set prov $this} msg] $msg \ [catch {classC0 chkThis} msg] $msg } {1 {can't read "this": no such variable} 0 ::classC0} test general1-1.20 {*cannot* read private variable from inherited class} { set ::test_cd_watch "" list [catch {classC0 doC set privA} msg] $msg [catch {classC0 doA set privA} msg] $msg [catch {classC0 doC set privB} msg] $msg [catch {classC0 doB set privB} msg] $msg } {1 {can't read "privA": no such variable} 0 Hallo 1 {can't read "privB": no such variable} 0 privBB} if {0} { c publicC } ::itcl::delete class ClassA ::tcltest::cleanupTests return itcl4.2.2/tests/ensemble.test0000644003604700454610000001575514137636151014651 0ustar dgp771div# # Tests for the "ensemble" compound command facility # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl test ensemble-1.1 {ensemble name must be specified} { list [catch {itcl::ensemble} msg] $msg } {1 {wrong # args: should be "itcl::ensemble name ?command arg arg...?"}} test ensemble-1.2 {creating a new ensemble} { itcl::ensemble test_numbers { part one {x} { return "one: $x" } part two {x y} { return "two: $x $y" } } } "" test ensemble-1.3 {adding to an existing ensemble} { itcl::ensemble test_numbers part three {x y z} { return "three: $x $y $z" } } "" test ensemble-1.4 {invoking ensemble parts} { list [test_numbers one 1] [test_numbers two 2 3] [test_numbers three 3 4 5] } {{one: 1} {two: 2 3} {three: 3 4 5}} test ensemble-1.5 {invoking parts with improper arguments} { set res [catch "test_numbers three x" msg] lappend res [string match "wrong # args*" $msg] } {1 1} test ensemble-1.6 {errors trigger a usage summary} { list [catch "test_numbers foo x y" msg] $msg } {1 {bad option "foo": should be one of... test_numbers one x test_numbers three x y z test_numbers two x y}} test ensemble-1.7 {one part can't overwrite another} { set cmd { itcl::ensemble test_numbers part three {} { return "three: new version" } } list [catch $cmd msg] $msg } {1 {part "three" already exists in ensemble}} test ensemble-1.8 {an ensemble can't overwrite another part} { set cmd { itcl::ensemble test_numbers ensemble three part new {} { return "three: new version" } } list [catch $cmd msg] $msg } {1 {part "three" is not an ensemble}} test ensemble-1.9 {body errors are handled gracefully} { list [catch "itcl::ensemble test_numbers {foo bar baz}" msg] $msg $errorInfo } {1 {invalid command name "foo"} {invalid command name "foo" while executing "foo bar baz" ("ensemble" body line 1) invoked from within "itcl::ensemble test_numbers {foo bar baz}"}} test ensemble-1.10 {part errors are handled gracefully} { list [catch "itcl::ensemble test_numbers {part foo}" msg] $msg $errorInfo } {1 {wrong # args: should be "part name args body"} {wrong # args: should be "part name args body" while executing "part foo" ("ensemble" body line 1) invoked from within "itcl::ensemble test_numbers {part foo}"}} test ensemble-1.11 {part argument errors are handled gracefully} { list [catch "itcl::ensemble test_numbers {part foo {{}} {}}" msg] $msg $errorInfo } {1 {procedure "foo" has argument with no name} {procedure "foo" has argument with no name while executing "part foo {{}} {}" ("ensemble" body line 1) invoked from within "itcl::ensemble test_numbers {part foo {{}} {}}"}} test ensemble-2.0 {defining subensembles} { itcl::ensemble test_numbers { ensemble hex { part base {} { return 16 } part digits {args} { foreach num $args { lappend result "0x$num" } return $result } } ensemble octal { part base {} { return 8 } part digits {{prefix 0} args} { foreach num $args { lappend result "$prefix$num" } return $result } } } list [catch "test_numbers foo" msg] $msg } {1 {bad option "foo": should be one of... test_numbers hex option ?arg arg ...? test_numbers octal option ?arg arg ...? test_numbers one x test_numbers three x y z test_numbers two x y}} test ensemble-2.1 {invoking sub-ensemble parts} { list [catch "test_numbers hex base" msg] $msg } {0 16} test ensemble-2.2 {invoking sub-ensemble parts} { list [catch "test_numbers hex digits 3 a f" msg] $msg } {0 {0x3 0xa 0xf}} test ensemble-2.3 {errors from sub-ensembles} { list [catch "test_numbers hex" msg] $msg } {1 {wrong # args: should be "test_numbers hex subcommand ?arg ...?"}} test ensemble-2.3a {errors from sub-ensembles } -body { list [catch "test_numbers hex" msg] $msg } -constraints { needs_frq_1773103 } -result {1 {wrong # args: should be one of... test_numbers hex base test_numbers hex digits ?arg arg ...?}} test ensemble-2.4 {invoking sub-ensemble parts} { list [catch "test_numbers octal base" msg] $msg } {0 8} test ensemble-2.5 {invoking sub-ensemble parts} { list [catch "test_numbers octal digits 0o 3 5 10" msg] $msg } {0 {0o3 0o5 0o10}} test ensemble-2.6 {errors from sub-ensembles} { list [catch "test_numbers octal" msg] $msg } {1 {wrong # args: should be "test_numbers octal subcommand ?arg ...?"}} test ensemble-2.6a {errors from sub-ensembles } -body { list [catch "test_numbers octal" msg] $msg } -constraints { needs_frq_1773103 } -result {1 {wrong # args: should be one of... test_numbers octal base test_numbers octal digits ?prefix? ?arg arg ...?}} test ensemble-2.7 {sub-ensembles can't be accidentally redefined} { set cmd { itcl::ensemble test_numbers part octal {args} { return "octal: $args" } } list [catch $cmd msg] $msg } {1 {part "octal" already exists in ensemble}} test ensemble-3.0 {an error handler part can be used to handle errors} { itcl::ensemble test_numbers { part @error {args} { return "error: $args" } } list [catch {test_numbers foo 1 2 3} msg] $msg } {0 {error: foo 1 2 3}} test ensemble-3.1 {the error handler part shows up as generic "...and"} { list [catch {test_numbers} msg] $msg } {1 {wrong # args: should be "test_numbers subcommand ?arg ...?"}} test ensemble-3.1a {the error handler part shows up as generic "...and" } -body { list [catch {test_numbers} msg] $msg } -constraints { needs_frq_1773103 } -result {1 {wrong # args: should be one of... test_numbers hex option ?arg arg ...? test_numbers octal option ?arg arg ...? test_numbers one x test_numbers three x y z test_numbers two x y ...and others described on the man page}} ::itcl::delete ensemble test_numbers test ensemble-4.0 {SF Bug 119} -setup { itcl::ensemble foo part sub {} {error bar} } -cleanup { unset -nocomplain m o rename foo {} } -body { catch {foo sub} m o dict get $o -errorinfo } -match glob -result {*itcl ensemble part*} ::tcltest::cleanupTests return itcl4.2.2/tests/eclasscomponent.test0000644003604700454610000001663114137636151016246 0ustar dgp771div#--------------------------------------------------------------------- # TITLE: # eclasscomponent.test # # AUTHOR: # Arnulf Wiedemann with a lot of code form the snit tests by # Will Duquette # # DESCRIPTION: # Test cases for ::itcl::extendedclass component command. # Uses the ::tcltest:: harness. # # The tests assume tcltest 2.2 #----------------------------------------------------------------------- package require tcltest 2.2 namespace import ::tcltest::* ::tcltest::loadTestedCommands package require itcl #--------------------------------------------------------------------- loadTestedCommands test component-1.1 {component defines variable} -body { ::itcl::extendedclass dog { protected component mycomp public proc test {} { return $mycomp } } dog fido fido test } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {} test component-1.2 {component -inherit} -body { ::itcl::extendedclass dog { component mycomp -inherit constructor {} { set mycomp string } } dog fido fido length foo } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {3} test component-1.3 {component -inherit can only have one of it} -body { ::itcl::extendedclass dogbase { component mycompbase -inherit } ::itcl::extendedclass dog { inherit dogbase component mycomp -inherit constructor {} { set mycomp string } } dog fido fido length foo } -cleanup { ::itcl::delete class dog ::itcl::delete class dogbase } -returnCodes { error } -result {object "fido" can only have one component with inherit. Had already component "mycomp" now component "mycompbase"} #----------------------------------------------------------------------- # Typemethod delegation test delegatemethod-1.1 {delegate method to non-existent component} -body { set result "" ::itcl::extendedclass dog { delegate method foo to bar } dog fido } -returnCodes { error } -cleanup { dog destroy } -result {::dog ::fido delegates method "foo" to undefined component "bar"} test delegatemethod-1.2 {delegating to existing component} -body { ::itcl::extendedclass dog { component string delegate method length to string constructor {} { set string string } } dog fido fido length foo } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {3} test delegatemethod-1.3 {delegating to existing component with error} -body { ::itcl::extendedclass dog { # component string delegate method length to string constructor {} { set string string } } dog fido fido length foo bar } -cleanup { ::itcl::delete class dog } -returnCodes { error } -result {wrong # args: should be "fido length string"} test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body { ::itcl::extendedclass dog { # component string delegate method * to string constructor {} { set string string } } dog fido fido length foo } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {3} test delegatemethod-1.6a {delegating unknown method to existing component with error} -body { ::itcl::extendedclass dog { component stringhandler delegate method * to stringhandler constructor {} { set stringhandler string } } dog fido fido foo bar } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -returnCodes { error } -match glob -result {unknown or ambiguous subcommand "foo": must be *} test delegatemethod-1.7 {can't delegate local method: order 1} -body { ::itcl::extendedclass dog { component bar method foo {} {} delegate method foo to bar } } -returnCodes { error } -result {method "foo" has been defined locally} test delegatemethod-1.8 {can't delegate local method: order 2} -body { ::itcl::extendedclass dog { component bar delegate method foo to bar method foo {} {} } } -returnCodes { error } -result {method "foo" has been delegated} test delegatemethod-1.9 {can't delegate local method: order 2} -body { ::itcl::extendedclass dog { component bar delegate method foo to bar method foo {} {} } } -cleanup { } -returnCodes { error } -result {method "foo" has been delegated} # should be same as above if {0} { #----------------------------------------------------------------------- # Typemethod delegation test delegatemethod-1.1 {delegate method to non-existent component} -body { set result "" ::itcl::extendedclass dog { delegate method foo to bar } dog fido } -returnCodes { error } -cleanup { ::itcl::delete class dog } -result {::dog ::fido delegates method "foo" to undefined component "bar"} test delegatemethod-1.2 {delegating to existing component} -body { ::itcl::extendedclass dog { component string delegate method length to string constructor {} { set string string } } dog fido fido length foo } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {3} test delegatemethod-1.3 {delegating to existing component with error} -body { ::itcl::extendedclass dog { # component string delegate method length to string constructor {} { set string string } } dog fido fido length foo bar } -cleanup { ::itcl::delete class dog } -returnCodes { error } -result {wrong # args: should be "fido length string"} test delegatemethod-1.5 {delegating unknown methods to existing typecomponent} -body { ::itcl::extendedclass dog { # component string delegate method * to string constructor {} { set string string } } dog fido fido length foo } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -result {3} test delegatemethod-1.6a {delegating unknown method to existing component with error} -body { ::itcl::extendedclass dog { component stringhandler delegate method * to stringhandler constructor {} { set stringhandler string } } dog fido fido foo bar } -cleanup { ::itcl::delete object fido ::itcl::delete class dog } -returnCodes { error } -result {unknown or ambiguous subcommand "foo": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart} test delegatemethod-1.7 {can't delegate local method: order 1} -body { ::itcl::extendedclass dog { component bar method foo {} {} delegate method foo to bar } } -cleanup { } -returnCodes { error } -result {method "foo" has been defined locally} test delegatemethod-1.8 {can't delegate local method: order 2} -body { ::itcl::extendedclass dog { component bar delegate method foo to bar method foo {} {} } } -cleanup { } -returnCodes { error } -result {method "foo" has been delegated} # end } #--------------------------------------------------------------------- # Clean up cleanupTests return itcl4.2.2/tests/delete.test0000644003604700454610000001713514137636151014313 0ustar dgp771div# # Tests for deleting classes and objects # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Deleting classes and objects # ---------------------------------------------------------------------- test delete-1.1 {define a simple classes with inheritance} { itcl::class test_delete_base { variable num 0 method show {} { return $num } } } "" test delete-1.2 {create some base class objects} { for {set i 0} {$i < 5} {incr i} { test_delete_base #auto } lsort [itcl::find objects -class test_delete_base] } {test_delete_base0 test_delete_base1 test_delete_base2 test_delete_base3 test_delete_base4} test delete-1.3 {delete the base class--class and all objects go away} { list [itcl::delete class test_delete_base] \ [itcl::find classes test_delete_base] \ [namespace children :: test_delete_base] \ [namespace which -command test_delete_base] \ [itcl::find objects test_delete_base*] } {{} {} {} {} {}} # ---------------------------------------------------------------------- # Deleting classes and objects with inheritance # ---------------------------------------------------------------------- test delete-2.1 {define a simple classes with inheritance} { variable ::test_delete_watch "" itcl::class test_delete_base { variable num 0 method show {} { return $num } destructor { global ::test_delete_watch lappend test_delete_watch $this } } itcl::class test_delete { inherit test_delete_base method show {} { return ">$num<" } } } "" test delete-2.2 {create some base and derived class objects} { for {set i 0} {$i < 3} {incr i} { test_delete_base #auto } for {set i 0} {$i < 3} {incr i} { test_delete #auto } lsort [itcl::find objects -isa test_delete_base] } {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2} test delete-2.3 {delete the base class--class and all objects go away} { list [itcl::delete class test_delete_base] \ [itcl::find classes test_delete*] \ [namespace children :: test_delete*] \ [namespace which -command test_delete_base] \ [namespace which -command test_delete] \ [itcl::find objects test_delete*] } {{} {} {} {} {} {}} test delete-2.4 {object destructors get invoked properly} { lsort $test_delete_watch } {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2} # ---------------------------------------------------------------------- # Deleting class namespaces # ---------------------------------------------------------------------- test delete-3.1 {redefine classes with inheritance} { variable ::test_delete_watch "" itcl::class test_delete_base { variable num 0 method show {} { return $num } destructor { global test_delete_watch lappend test_delete_watch $this } } itcl::class test_delete { inherit test_delete_base method show {} { return ">$num<" } } } "" test delete-3.2 {create some base and derived class objects} { for {set i 0} {$i < 3} {incr i} { test_delete_base #auto } for {set i 0} {$i < 3} {incr i} { test_delete #auto } lsort [itcl::find objects -isa test_delete_base] } {test_delete0 test_delete1 test_delete2 test_delete_base0 test_delete_base1 test_delete_base2} test delete-3.3 {deleting a class namespace is like deleting a class} { list [namespace delete test_delete_base] \ [itcl::find classes test_delete*] \ [namespace children :: test_delete*] \ [namespace which -command test_delete_base] \ [namespace which -command test_delete] \ [itcl::find objects test_delete*] } {{} {} {} {} {} {}} test delete-3.4 {object destructors get invoked, even during catastrophe} { lsort $test_delete_watch } {::test_delete0 ::test_delete1 ::test_delete2 ::test_delete_base0 ::test_delete_base1 ::test_delete_base2} # ---------------------------------------------------------------------- # Self-destructing objects # ---------------------------------------------------------------------- test delete-4.1 {define a class where objects destroy themselves} { itcl::class test_delete { public variable x "" public variable deletecommand "" constructor {args} { eval configure $args } destructor { eval $deletecommand } method killme {code} { itcl::delete object $this eval $code } } } {} test delete-4.2 {an object can delete itself } -body { set obj [test_delete #auto -x "data stays"] list [$obj killme {return $x}] [itcl::find objects -isa test_delete] } -constraints { only_working_in_itcl3.4 } -result {{data stays} {}} test delete-4.3 {the "this" variable becomes null after delete} { set obj [test_delete #auto] list [$obj killme {return $this}] [itcl::find objects -isa test_delete] } {{} {}} test delete-4.4 {an object being destructed can't be deleted} { set obj [test_delete #auto -deletecommand {itcl::delete object $this}] list [catch {itcl::delete object $obj} msg] $msg } {1 {can't delete an object while it is being destructed}} if {[namespace which [namespace current]::test_delete] ne {}} { namespace delete test_delete } # ---------------------------------------------------------------------- # Delete objects using path names and scoped values # ---------------------------------------------------------------------- test delete-5.1 {define a simple class} { itcl::class test_delete_name { private variable x 0 method test {x} { return $x } } } {} test delete-5.2 {delete using a qualified name} { namespace eval test_delete2 {test_delete_name #auto} set cmd {itcl::delete object test_delete2::test_delete_name0} list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name] } {0 {} {}} test delete-5.3 {delete using a scoped value} { set obj [namespace eval test_delete2 {itcl::code [test_delete_name #auto]}] set cmd [list itcl::delete object $obj] list [catch $cmd msg] $msg [itcl::find objects -isa test_delete_name] } {0 {} {}} test delete-5.4 {scoped command names are decoded properly} { list [catch {itcl::delete object {namespace inscope ::xyzzy xxx}} msg] $msg \ [catch {itcl::delete object {namespace inscope :: xxx yyy}} msg] $msg \ [catch {itcl::delete object {namespace inscope :: xyzzy}} msg] $msg } {1 {unknown namespace "::xyzzy"} 1 {malformed command "namespace inscope :: xxx yyy": should be "namespace inscope namesp command"} 1 {object "namespace inscope :: xyzzy" not found}} namespace delete test_delete_name test_delete2 ::tcltest::cleanupTests return itcl4.2.2/tests/chain.test0000644003604700454610000001253314137636151014130 0ustar dgp771div# # Tests for chaining methods and procs # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Chaining methods and procs # ---------------------------------------------------------------------- test chain-1.1 {define simple classes with inheritance} { itcl::class test_chain_a { constructor {args} { # eval chain $args } { global ::test_chain_status lappend test_chain_status "a::constructor $args" } method show {mesg} { chain $mesg global ::test_chain_status lappend test_chain_status "a::show $mesg" } proc tell {mesg} { global ::test_chain_status lappend test_chain_status "a::tell $mesg" chain $mesg } } itcl::class test_chain_b { constructor {args} { # eval chain $args } { global ::test_chain_status lappend test_chain_status "b::constructor $args" } method show {mesg} { chain $mesg global ::test_chain_status lappend test_chain_status "b::show $mesg" } proc tell {mesg} { global ::test_chain_status lappend test_chain_status "b::tell $mesg" chain $mesg } } itcl::class test_chain_c { inherit test_chain_a test_chain_b constructor {args} { eval chain $args } { global ::test_chain_status lappend test_chain_status "c::constructor $args" } proc tell {mesg} { global ::test_chain_status lappend test_chain_status "c::tell $mesg" chain $mesg } } itcl::class test_chain_d { inherit test_chain_c constructor {args} { eval chain $args } { global ::test_chain_status lappend test_chain_status "d::constructor $args" } method show {mesg} { chain $mesg global ::test_chain_status lappend test_chain_status "d::show $mesg" } proc tell {mesg} { global ::test_chain_status lappend test_chain_status "d::tell $mesg" chain $mesg } } } "" test chain-1.2 {create a test object} { set test_chain_status "" set testobj [test_chain_d #auto 1 2 3] set test_chain_status } {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}} test chain-1.3 {invoke a chained method} { set test_chain_status "" $testobj show "hello there" set test_chain_status } {{b::show hello there} {a::show hello there} {d::show hello there}} test chain-1.4 {invoke a chained method with a specific name} { set test_chain_status "" $testobj test_chain_d::show "hello there" set test_chain_status } {{b::show hello there} {a::show hello there} {d::show hello there}} test chain-1.5 {chained methods can cross multiple-inheritance branches} { set test_chain_status "" $testobj test_chain_a::show "hello there" set test_chain_status } {{b::show hello there} {a::show hello there}} test chain-1.6 {invoke a chained proc} { set test_chain_status "" test_chain_d::tell "testing 1 2 3" set test_chain_status } {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}} test chain-1.7 {invoke a chained proc} { set test_chain_status "" test_chain_c::tell "testing 1 2 3" set test_chain_status } {{c::tell testing 1 2 3} {a::tell testing 1 2 3}} test chain-2.1 {create a test object in a base class} { set test_chain_status "" set testobj [test_chain_c #auto 4 5 6] set test_chain_status } {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}} test chain-2.2 {invoke a chained method} { set test_chain_status "" $testobj show "hello there" set test_chain_status } {{b::show hello there} {a::show hello there}} test chain-3.0 {invoke "chain" outside of a class} { list [catch {itcl::builtin::chain 1 2 3} err] $err } {1 {cannot chain functions outside of a class context}} test chain-4.0 {[35a5baca67]} -setup { unset -nocomplain ::answer itcl::class B {method act args {lappend ::answer B}} itcl::class D {inherit B; method act args {lappend ::answer D; chain}} } -body { [D d] act Now! set ::answer } -cleanup { itcl::delete class B unset -nocomplain ::answer } -result {D B} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a ::tcltest::cleanupTests return itcl4.2.2/tests/body.test0000644003604700454610000002326114137636151014003 0ustar dgp771div# # Tests for "body" and "configbody" commands # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl # ---------------------------------------------------------------------- # Test "body" command # ---------------------------------------------------------------------- test body-1.1 {define a class with missing bodies and arg lists} { itcl::class test_body { constructor {args} {} destructor {} method any method zero {} method one {x} method two {x y} method defvals {x {y 0} {z 1}} method varargs {x args} method override {mesg} { return "override: $mesg" } } } "" test body-1.2 {cannot use methods without a body} { test_body #auto list [catch "test_body0 any" msg] $msg } {1 {member function "::test_body::any" is not defined and cannot be autoloaded}} test body-1.3 {check syntax of "body" command} { list [catch "itcl::body test_body::any" msg] $msg } {1 {wrong # args: should be "itcl::body class::func arglist body"}} test body-1.4 {make sure members are found correctly} { list [catch "itcl::body test_body::xyzzyxyzzyxyzzy {} {}" msg] $msg } {1 {function "xyzzyxyzzyxyzzy" is not defined in class "::test_body"}} test body-1.5a {members without an argument list can have any args} { itcl::body test_body::any {} {return "any"} list [catch "test_body0 any" msg] $msg } {0 any} test body-1.5b {members without an argument list can have any args} { itcl::body test_body::any {x} {return "any: $x"} list [catch "test_body0 any 1" msg] $msg } {0 {any: 1}} test body-1.5c {members without an argument list can have any args} { itcl::body test_body::any {x {y 2}} {return "any: $x $y"} list [catch "test_body0 any 1" msg] $msg } {0 {any: 1 2}} test body-1.6a {an empty argument list must stay empty} { list [catch {itcl::body test_body::zero {x y} {return "zero: $x $y"}} msg] $msg } {1 {argument list changed for function "::test_body::zero": should be ""}} test body-1.6b {an empty argument list must stay empty} { list [catch {itcl::body test_body::zero {} {return "zero"}} msg] $msg } {0 {}} test body-1.7a {preserve argument list: fixed arguments} { list [catch {itcl::body test_body::one {x y} {return "one: $x $y"}} msg] $msg } {1 {argument list changed for function "::test_body::one": should be "x"}} test body-1.7b {preserve argument list: fixed arguments} { list [catch {itcl::body test_body::one {a} {return "one: $a"}} msg] $msg } {0 {}} test body-1.7c {preserve argument list: fixed arguments} { list [catch "test_body0 one 1.0" msg] $msg } {0 {one: 1.0}} test body-1.8a {preserve argument list: fixed arguments} { list [catch {itcl::body test_body::two {x} {return "two: $x"}} msg] $msg } {1 {argument list changed for function "::test_body::two": should be "x y"}} test body-1.8b {preserve argument list: fixed arguments} { list [catch {itcl::body test_body::two {a b} {return "two: $a $b"}} msg] $msg } {0 {}} test body-1.8c {preserve argument list: fixed arguments} { list [catch "test_body0 two 2.0 3.0" msg] $msg } {0 {two: 2.0 3.0}} test body-1.9a {preserve argument list: default arguments} { list [catch {itcl::body test_body::defvals {x} {}} msg] $msg } {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} test body-1.9b {preserve argument list: default arguments} { list [catch {itcl::body test_body::defvals {a {b 0} {c 2}} {}} msg] $msg } {1 {argument list changed for function "::test_body::defvals": should be "x {y 0} {z 1}"}} test body-1.9c {preserve argument list: default arguments} { list [catch {itcl::body test_body::defvals {a {b 0} {c 1}} {}} msg] $msg } {0 {}} test body-1.10a {preserve argument list: variable arguments} { list [catch {itcl::body test_body::varargs {} {}} msg] $msg } {1 {argument list changed for function "::test_body::varargs": should be "x args"}} test body-1.10b {preserve argument list: variable arguments} { list [catch {itcl::body test_body::varargs {a} {}} msg] $msg } {0 {}} test body-1.10c {preserve argument list: variable arguments} { list [catch {itcl::body test_body::varargs {a b c} {}} msg] $msg } {0 {}} test body-1.11 {redefined body really does change} { list [test_body0 override "test #1"] \ [itcl::body test_body::override {text} {return "new: $text"}] \ [test_body0 override "test #2"] } {{override: test #1} {} {new: test #2}} # ---------------------------------------------------------------------- # Test "body" command with inheritance # ---------------------------------------------------------------------- test body-2.1 {inherit from a class with missing bodies} { itcl::class test_ibody { inherit test_body method zero {} } test_ibody #auto } {test_ibody0} test body-2.2 {redefine a method in a derived class} { itcl::body test_ibody::zero {} {return "ibody zero"} list [test_ibody0 info function zero] \ [test_ibody0 info function test_body::zero] } {{public method ::test_ibody::zero {} {return "ibody zero"}} {public method ::test_body::zero {} {return "zero"}}} test body-2.3 {try to redefine a method that was not declared} { list [catch {itcl::body test_ibody::one {x} {return "new"}} msg] $msg } {1 {function "one" is not defined in class "::test_ibody"}} ::itcl::delete class test_body # ---------------------------------------------------------------------- # Test "configbody" command # ---------------------------------------------------------------------- test body-3.1 {define a class with public variables} { itcl::class test_cbody { private variable priv protected variable prot public variable option {} { lappend messages "option: $option" } public variable nocode {} public common messages } } "" test body-3.2 {check syntax of "configbody" command} { list [catch "itcl::configbody test_cbody::option" msg] $msg } {1 {wrong # args: should be "itcl::configbody class::option body"}} test body-3.3 {make sure that members are found correctly} { list [catch "itcl::configbody test_cbody::xyzzy {}" msg] $msg } {1 {option "xyzzy" is not defined in class "::test_cbody"}} test body-3.4 {private variables have no config code} { list [catch "itcl::configbody test_cbody::priv {bogus}" msg] $msg } {1 {option "::test_cbody::priv" is not a public configuration option}} test body-3.5 {protected variables have no config code} { list [catch "itcl::configbody test_cbody::prot {bogus}" msg] $msg } {1 {option "::test_cbody::prot" is not a public configuration option}} test body-3.6 {can use public variables without a body} { test_cbody #auto list [catch "test_cbody0 configure -nocode 1" msg] $msg } {0 {}} test body-3.7 {redefined body really does change} { list [test_cbody0 configure -option "hello"] \ [itcl::configbody test_cbody::option {lappend messages "new: $option"}] \ [test_cbody0 configure -option "goodbye"] \ [set test_cbody::messages] \ } {{} {} {} {{option: hello} {new: goodbye}}} # ---------------------------------------------------------------------- # Test "configbody" command with inheritance # ---------------------------------------------------------------------- test body-4.1 {inherit from a class with missing config bodies} { itcl::class test_icbody { inherit test_cbody public variable option "icbody" } test_icbody #auto } {test_icbody0} test body-4.2 {redefine a body in a derived class} { itcl::configbody test_icbody::option {lappend messages "test_icbody: $option"} list [test_icbody0 info variable option] \ [test_icbody0 info variable test_cbody::option] } {{public variable ::test_icbody::option icbody {lappend messages "test_icbody: $option"} icbody} {public variable ::test_cbody::option {} {lappend messages "new: $option"} {}}} test body-4.3 {try to redefine a body for a variable that was not declared} { list [catch {itcl::configbody test_icbody::nocode {return "new"}} msg] $msg } {1 {option "nocode" is not defined in class "::test_icbody"}} test body-5.1 {redefine constructors} -setup { unset -nocomplain answer itcl::class B {constructor {} {lappend ::answer B}} itcl::class D {inherit B; constructor {} {lappend ::answer A}} } -body { D d1 itcl::body D::constructor {} {lappend ::answer D} D d2 set ::answer } -cleanup { itcl::delete class B unset -nocomplain answer } -result {B A B D} test body-6.1 {redefine class proc body} -setup { unset -nocomplain ::answer itcl::class C { proc cheshire {} { lappend ::answer x itcl::body ::C::cheshire {} {} } constructor {args} {cheshire} } } -body { itcl::delete object [C #auto] itcl::delete object [C #auto] itcl::delete object [C #auto] set ::answer } -cleanup { itcl::delete class C unset -nocomplain ::answer } -result x # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_cbody ::tcltest::cleanupTests return itcl4.2.2/tests/basic.test0000644003604700454610000004311414137636232014126 0ustar dgp771div# # Basic tests for class definition and method/proc access # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.2 namespace import ::tcltest::test ::tcltest::loadTestedCommands package require itcl test basic-1.0 {empty string as class name should fail but not crash } -body { list [catch {itcl::class "" {}} err] $err } -result {1 {invalid class name ""}} # ---------------------------------------------------------------------- # Simple class definition # ---------------------------------------------------------------------- variable setup { itcl::class Counter { constructor {args} { incr num eval configure $args } destructor { if {![info exists num]} { lappend ::tcltest::itcl_basic_errors "unexpected: common deleted before destructor got called" } incr num -1 } method ++ {} { return [incr val $by] } proc num {} { return $num } public variable by 1 protected variable val 0 private common num 0 } } variable cleanup { itcl::delete class Counter } variable setup2 $setup append setup2 { set x [Counter x] } variable cleanup2 $cleanup append cleanup2 { unset x } variable setup3 $setup append setup3 { Counter -foo } variable setup4 $setup append setup4 { Counter c } proc check_itcl_basic_errors {} { if {[info exists ::tcltest::itcl_basic_errors] && [llength $::tcltest::itcl_basic_errors]} { error "following errors occurs during tests:\n [join $::tcltest::itcl_basic_errors "\n "]" } } test basic-1.1 {define a simple class } -setup $setup -body { } -cleanup $cleanup -result {} test basic-1.2 {class is now defined } -setup $setup -body { itcl::find classes Counter } -cleanup $cleanup -result Counter test basic-1.3 {access command exists with class name } -setup $setup -body { namespace which -command Counter } -cleanup $cleanup -result ::Counter test basic-1.4 {create a simple object } -setup $setup2 -body { return $x } -cleanup $cleanup2 -result x test basic-1.5a {object names cannot be duplicated } -setup $setup2 -body { list [catch "Counter x" msg] $msg } -cleanup $cleanup2 -result {1 {command "x" already exists in namespace "::"}} test basic-1.5b {built-in commands cannot be clobbered } -setup $setup -body { list [catch "Counter info" msg] $msg } -cleanup $cleanup -result {1 {command "info" already exists in namespace "::"}} test basic-1.6 {objects have an access command } -setup $setup2 -body { namespace which -command x } -cleanup $cleanup2 -result ::x test basic-1.7a {objects are added to the global list } -setup $setup2 -body { itcl::find objects x } -cleanup $cleanup2 -result x test basic-1.7b {objects are added to the global list } -setup $setup2 -body { itcl::find objects -class Counter x } -cleanup $cleanup2 -result x test basic-1.8 {objects can be deleted } -setup $setup2 -body { list [itcl::delete object x] [namespace which -command x] } -cleanup $cleanup2 -result {{} {}} test basic-1.9 {objects can be recreated with the same name } -setup $setup2 -body { itcl::delete object x Counter x } -cleanup $cleanup2 -result x test basic-1.10 {objects can be destroyed by deleting their access command } -setup $setup2 -body { rename ::x {} itcl::find objects x } -cleanup $cleanup2 -result {} test basic-1.11 {find command supports object names starting with - } -setup $setup3 -body { itcl::find objects -class Counter -foo } -cleanup $cleanup -result -foo test basic-1.12 {is command with class argument } -setup $setup -body { itcl::is class Counter } -cleanup $cleanup -result 1 test basic-1.13 {is command with class argument (global namespace) } -setup $setup -body { itcl::is class ::Counter } -cleanup $cleanup -result 1 test basic-1.14 {is command with class argument (wrapped in code command) } -setup $setup -body { itcl::is class [itcl::code Counter] } -cleanup $cleanup -result 1 test basic-1.15 {is command with class argument (class does not exist) } -body { itcl::is class Count } -result 0 test basic-1.16 {is command with object argument } -setup $setup3 -body { itcl::is object -foo } -cleanup $cleanup -result 1 test basic-1.17 {is command with object argument (object does not exist) } -body { itcl::is object xxx } -result 0 test basic-1.18 {is command with object argument (with code command) } -setup $setup3 -body { itcl::is object [itcl::code -- -foo] } -cleanup $cleanup -result 1 test basic-1.19 {classes can be unicode } -body { itcl::class \u6210bcd { method foo args { return "bar" } } \u6210bcd #auto } -result "\u6210bcd0" test basic-1.20 { classes can be unicode } -body { \u6210bcd0 foo } -cleanup { ::itcl::delete class \u6210bcd } -result {bar} test basic-1.21 {error on empty class name } -body { itcl::class {} {} } -returnCodes error -result {invalid class name ""} test basic-1.22 {error on empty object name } -setup { itcl::class ::A {} } -body { ::A {} } -cleanup { ::itcl::delete class ::A } -returnCodes error -result {object name must not be empty} # ---------------------------------------------------------------------- # #auto names # ---------------------------------------------------------------------- test basic-2.1 {create an object with an automatic name } -setup $setup -body { Counter #auto } -cleanup $cleanup -result {counter0} test basic-2.2 {bury "#auto" within object name } -setup $setup -body { Counter x#autoy } -cleanup $cleanup -result {xcounter0y} test basic-2.3 {bury "#auto" within object name } -setup $setup -body { Counter a#aut#autob } -cleanup $cleanup -result {a#autcounter0b} test basic-2.4 {"#auto" is smart enough to skip names that are taken } -setup $setup -body { Counter counter3 Counter #auto } -cleanup $cleanup -result {counter0} test basic-2.5 {"#auto" with :: at front of name } -body { itcl::class AutoCheck {} set result [AutoCheck ::#auto] rename AutoCheck {} set result } -result {::autoCheck0} test basic-2.6 {"#auto" with :: at front of name inside method } -body { itcl::class AutoCheck { proc new {} { return [AutoCheck ::#auto] } } set result [AutoCheck::new] rename AutoCheck {} set result } -result {::autoCheck0} test basic-2.7 {"#auto" with :: at front of name inside method inside namespace } -body { namespace eval AutoCheckNs {} itcl::class AutoCheckNs::AutoCheck { proc new {} { return [AutoCheckNs::AutoCheck ::#auto] } } set result [AutoCheckNs::AutoCheck::new] namespace delete AutoCheckNs set result } -cleanup { namespace delete ::itcl::internal::variables::AutoCheckNs } -result {::autoCheck0} test basic-3.1 {object access command works } -setup $setup4 -body { list [c ++] [c ++] [c ++] } -cleanup $cleanup -result {1 2 3} test basic-3.2 {errors produce usage info } -setup $setup4 -body { list [catch "c xyzzy" msg] $msg } -cleanup $cleanup -result {1 {bad option "xyzzy": should be one of... c ++ c cget -option c configure ?-option? ?value -option value...? c isa className}} test basic-3.3 {built-in configure can query public variables } -setup $setup4 -body { c configure } -cleanup $cleanup -result {{-by 1 1}} test basic-3.4 {built-in configure can query one public variable } -setup $setup4 -body { c configure -by } -cleanup $cleanup -result {-by 1 1} test basic-3.5 {built-in configure can set public variable } -setup $setup4 -body { list [c configure -by 2] [c cget -by] } -cleanup $cleanup -result {{} 2} test basic-3.6 {configure actually changes public variable } -setup $setup4 -body { list [c ++] [c ++] } -cleanup $cleanup -result {1 2} test basic-3.7 {class procs can be accessed } -setup $setup -body { Counter::num } -cleanup $cleanup -result 0 test basic-3.8 {obsolete syntax is no longer allowed } -setup $setup -body { list [catch "Counter :: num" msg] $msg } -cleanup $cleanup -result {1 {syntax "class :: proc" is an anachronism [incr Tcl] no longer supports this syntax. Instead, remove the spaces from your procedure invocations: Counter::num ?args?}} # ---------------------------------------------------------------------- # Classes can be destroyed and redefined # ---------------------------------------------------------------------- test basic-4.1 {classes can be destroyed } -setup $setup -body { list [itcl::delete class Counter] \ [itcl::find classes Counter] \ [namespace children :: Counter] \ [namespace which -command Counter] } -result {{} {} {} {}} test basic-4.2 {classes can be redefined } -body { itcl::class Counter { method ++ {} { return [incr val $by] } public variable by 1 protected variable val 0 } } -result {} test basic-4.3 {the redefined class is actually different } -body { list [catch "Counter::num" msg] $msg } -result {1 {invalid command name "Counter::num"}} test basic-4.4 {objects can be created from the new class } -body { list [Counter #auto] [Counter #auto] } -result {counter0 counter1} test basic-4.5 {namespaces for #auto are prepended to the command name } -body { namespace eval someNS1 {} namespace eval someNS2 {} list [Counter someNS1::#auto] [Counter someNS2::#auto] } -cleanup { ::itcl::delete object someNS1::counter2 someNS2::counter3 } -result "[list someNS1::counter2 someNS2::counter3]" test basic-4.6 {when a class is destroyed, its objects are deleted } -body { list [lsort [itcl::find objects counter*]] \ [itcl::delete class Counter] \ [lsort [itcl::find objects counter*]] } -result {{counter0 counter1} {} {}} check_itcl_basic_errors test basic-4.7 {clean-up of internal facilities } -setup $setup4 -body { # check callbacks are called if class gets removed using all possible ways: # objects are properly destroyed, # callback removing the namespace for the common private and protected variables # (in ITCL_VARIABLES_NAMESPACE) is called, etc set ::tcltest::itcl_basic_errors {} set ivns ::itcl::internal::variables[namespace which Counter] set result {} lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] eval $cleanup lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] eval $setup4 lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] rename Counter {} lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] eval $setup4 lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] namespace delete Counter lappend result [namespace exists $ivns] [expr {[namespace which -command c] ne ""}] lappend result {*}$::tcltest::itcl_basic_errors } -cleanup { unset -nocomplain ivns ::tcltest::itcl_basic_errors } -result [lrepeat 3 1 1 0 0] # ---------------------------------------------------------------------- # Namespace variables # ---------------------------------------------------------------------- test basic-5.1 {define a simple class with variables in the namespace } -body { itcl::class test_globals { common g1 "global1" proc getval {name} { variable $name return [set [namespace tail $name]] } proc setval {name val} { variable $name return [set [namespace tail $name] $val] } method do {args} { return [eval $args] } } namespace eval test_globals { variable g2 "global2" } } -result {} test basic-5.2 {create an object for the tests } -body { test_globals #auto } -result {test_globals0} test basic-5.3 {common variables live in the namespace } -body { lsort [info vars ::test_globals::*] } -result {::test_globals::g1 ::test_globals::g2} test basic-5.4 {common variables can be referenced transparently } -body { list [catch {test_globals0 do set g1} msg] $msg } -result {0 global1} test basic-5.5 {namespace variables require a declaration } -body { list [catch {test_globals0 do set g2} msg] $msg } -result {1 {can't read "g2": no such variable}} test basic-5.6a {variable accesses variables within namespace } -body { list [catch {test_globals::getval g1} msg] $msg } -result {0 global1} test basic-5.6b {variable accesses variables within namespace } -body { list [catch {test_globals::getval g2} msg] $msg } -result {0 global2} test basic-5.7 {variable command will not find vars in other namespaces } -body { set ::test_global_0 "g0" list [catch {test_globals::getval test_global_0} msg] $msg \ [catch {test_globals::getval ::test_global_0} msg] $msg \ } -result {1 {can't read "test_global_0": no such variable} 0 g0} test basic-5.8 {to create globals in a namespace, use the full path } -body { test_globals::setval ::test_global_1 g1 namespace eval :: {lsort [info globals test_global_*]} } -result {test_global_0 test_global_1} test basic-5.9 {variable names can have ":" in them } -body { test_globals::setval ::test:global:2 g2 namespace eval :: {info globals test:global:2} } -result {test:global:2} if {[namespace which [namespace current]::test_globals] ne {}} { ::itcl::delete class test_globals } # ---------------------------------------------------------------------- # Array variables # ---------------------------------------------------------------------- test basic-6.1 {set up a class definition with array variables } -body { proc test_arrays_get {name} { upvar $name x set rlist {} foreach index [lsort [array names x]] { lappend rlist [list $index $x($index)] } return $rlist } itcl::class test_arrays { variable nums common undefined common colors set colors(red) #ff0000 set colors(green) #00ff00 set colors(blue) #0000ff constructor {} { set nums(one) 1 set nums(two) 2 set nums(three) 3 set undefined(a) A set undefined(b) B } method do {args} { return [eval $args] } } test_arrays #auto } -result {test_arrays0} test basic-6.2 {test array access for instance variables } -body { lsort [test_arrays0 do array get nums] } -result {1 2 3 one three two} test basic-6.3 {test array access for commons } -body { lsort [test_arrays0 do array get colors] } -result [list #0000ff #00ff00 #ff0000 blue green red] test basic-6.4 {test array access for instance variables via "upvar" } -body { test_arrays0 do test_arrays_get nums } -result {{one 1} {three 3} {two 2}} test basic-6.5 {test array access for commons via "upvar" } -body { test_arrays0 do test_arrays_get colors } -result {{blue #0000ff} {green #00ff00} {red #ff0000}} test basic-6.6a {test array access for commons defined in constructor } -body { lsort [test_arrays0 do array get undefined] } -result {A B a b} test basic-6.6b {test array access for commons defined in constructor } -body { test_arrays0 do test_arrays_get undefined } -result {{a A} {b B}} test basic-6.6c {test array access for commons defined in constructor } -body { list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)] } -result {A B} test basic-6.7 {common variables can be unset } -body { test_arrays0 do unset undefined test_arrays0 do array names undefined } -result {} test basic-6.8 {common variables can be redefined } -body { test_arrays0 do set undefined "scalar" } -result {scalar} proc testVarResolver {{access private} {init 0}} { eval [string map [list \$access $access \$init $init] { itcl::class A { $access common cv "A::cv" public proc cv {} {set cv} } itcl::class B { inherit A public common res {} lappend res [info exists cv] if {$init} { $access common cv "" } else { $access common cv } lappend res [info exists cv] lappend cv "B::cv-add" public proc cv {} {set cv} } lappend B::res [A::cv] [B::cv] set B::res }] } test basic-7.1-a {variable lookup before a common creation (bug [777ae99cfb])} -body { # private uninitialized var: testVarResolver private 0 } -result {0 0 A::cv B::cv-add} -cleanup { itcl::delete class B A } test basic-7.1-b {variable lookup before a common creation (bug [777ae99cfb])} -body { # public uninitialized var: testVarResolver public 0 } -result {1 0 A::cv B::cv-add} -cleanup { itcl::delete class B A } test basic-7.2-a {variable lookup before a common creation (bug [777ae99cfb])} -body { # private initialized var: testVarResolver private 1 } -result {0 1 A::cv B::cv-add} -cleanup { itcl::delete class B A } test basic-7.2-b {variable lookup before a common creation (bug [777ae99cfb])} -body { # public initialized var: testVarResolver public 1 } -result {1 1 A::cv B::cv-add} -cleanup { itcl::delete class B A } if {[namespace which test_arrays] ne {}} { ::itcl::delete class test_arrays } check_itcl_basic_errors rename check_itcl_basic_errors {} ::tcltest::cleanupTests return itcl4.2.2/tests/all.tcl0000644003604700454610000000152714137636151013422 0ustar dgp771div# all.tcl -- # # This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all.test" when running tcltest # in this directory. # # Copyright (c) 1998-2000 by Ajuba Solutions # All rights reserved. if {"-testdir" ni $argv} { lappend argv -testdir [file dir [info script]] } if {[namespace which -command memory] ne "" && "-loadfile" ni $argv} { puts "Tests running in sub-interpreters of leaktest circuit" # -loadfile overwrites -load, so save it for helper in ::env(TESTFLAGS): if {![info exists ::env(TESTFLAGS)] && [llength $argv]} { set ::env(TESTFLAGS) $argv } lappend argv -loadfile [file join [file dirname [info script]] helpers.tcl] } package prefer latest package require Tcl 8.6- package require tcltest 2.2 tcltest::configure {*}$argv tcltest::runAllTests return itcl4.2.2/library/0000755003604700454610000000000014140773323012440 5ustar dgp771divitcl4.2.2/library/test_Itcl_CreateObject.tcl0000644003604700454610000000143514137636151017516 0ustar dgp771div# this is a program for testing the stubs interface ItclCreateObject. # it uses itclTestRegisterC.c with the call C function functionality, # so it also tests that feature. # you need to define in Makefile CFLAGS: -DITCL_DEBUG_C_INTERFACE # for makeing that work. package require itcl ::itcl::class ::c1 { public method c0 {args} @cArgFunc public method m1 { args } { puts "Hello Tcl $args" } } set obj1 [::c1 #auto ] $obj1 m1 World # C method cargFunc implements a call to Itcl_CreateObject! # # args for method c0 of class ::c1 # arg1 does not matter # arg2 is the class name # arg3 is the full class name (full path name) # arg4 is the object name of the created Itcl object set obj2 [$obj1 c0 ::itcl::parser::handleClass ::c1 ::c1 ::c1::c11] # test, if it is working! $obj2 m1 Folks itcl4.2.2/library/itclWidget.tcl0000644003604700454610000003055314137636151015254 0ustar dgp771div# # itclWidget.tcl # ---------------------------------------------------------------------- # Invoked automatically upon startup to customize the interpreter # for [incr Tcl] when one of ::itcl::widget or ::itcl::widgetadaptor is called. # ---------------------------------------------------------------------- # AUTHOR: Arnulf P. Wiedemann # # ---------------------------------------------------------------------- # Copyright (c) 2008 Arnulf P. Wiedemann # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tk 8.6 # package require itclwidget [set ::itcl::version] namespace eval ::itcl { proc widget {name args} { set result [uplevel 1 ::itcl::internal::commands::genericclass widget $name $args] # we handle create by owerselfs !! allow classunknown to handle that oo::objdefine $result unexport create return $result } proc widgetadaptor {name args} { set result [uplevel 1 ::itcl::internal::commands::genericclass widgetadaptor $name $args] # we handle create by owerselfs !! allow classunknown to handle that oo::objdefine $result unexport create return $result } } ; # end ::itcl namespace eval ::itcl::internal::commands { proc initWidgetOptions {varNsName widgetName className} { set myDict [set ::itcl::internal::dicts::classOptions] if {$myDict eq ""} { return } if {![dict exists $myDict $className]} { return } set myDict [dict get $myDict $className] foreach option [dict keys $myDict] { set infos [dict get $myDict $option] set resource [dict get $infos -resource] set class [dict get $infos -class] set value [::option get $widgetName $resource $class] if {$value eq ""} { if {[dict exists $infos -default]} { set defaultValue [dict get $infos -default] uplevel 1 set ${varNsName}::itcl_options($option) $defaultValue } } else { uplevel 1 set ${varNsName}::itcl_options($option) $value } } } proc initWidgetDelegatedOptions {varNsName widgetName className args} { set myDict [set ::itcl::internal::dicts::classDelegatedOptions] if {$myDict eq ""} { return } if {![dict exists $myDict $className]} { return } set myDict [dict get $myDict $className] foreach option [dict keys $myDict] { set infos [dict get $myDict $option] if {![dict exists $infos -resource]} { # this is the case when delegating "*" continue } if {![dict exists $infos -component]} { # nothing to do continue } # check if not in the command line options # these have higher priority set myOption $option if {[dict exists $infos -as]} { set myOption [dict get $infos -as] } set noOptionSet 0 foreach {optName optVal} $args { if {$optName eq $myOption} { set noOptionSet 1 break } } if {$noOptionSet} { continue } set resource [dict get $infos -resource] set class [dict get $infos -class] set component [dict get $infos -component] set value [::option get $widgetName $resource $class] if {$component ne ""} { if {$value ne ""} { set compVar [namespace eval ${varNsName}${className} "set $component"] if {$compVar ne ""} { uplevel 1 $compVar configure $myOption $value } } } } } proc widgetinitobjectoptions {varNsName widgetName className} { #puts stderr "initWidgetObjectOptions!$varNsName!$widgetName!$className!" } proc deletehull {newName oldName what} { if {$what eq "delete"} { set name [namespace tail $newName] regsub {hull[0-9]+} $name {} name rename $name {} } if {$what eq "rename"} { set name [namespace tail $newName] regsub {hull[0-9]+} $name {} name rename $name {} } } proc hullandoptionsinstall {objectName className widgetClass hulltype args} { if {$hulltype eq ""} { set hulltype frame } set idx 0 set found 0 foreach {optName optValue} $args { if {$optName eq "-class"} { set found 1 set widgetClass $optValue break } incr idx } if {$found} { set args [lreplace $args $idx [expr {$idx + 1}]] } if {$widgetClass eq ""} { set widgetClass $className set widgetClass [string totitle $widgetClass] } set cmd "set win $objectName; ::itcl::builtin::installhull using $hulltype -class $widgetClass $args" uplevel 2 $cmd } } ; # end ::itcl::internal::commands namespace eval ::itcl::builtin { proc installhull {args} { set cmdPath ::itcl::internal::commands set className [uplevel 1 info class] set replace 0 switch -- [llength $args] { 0 { return -code error\ "wrong # args: should be \"[lindex [info level 0] 0]\ name|using ?arg ...?\"" } 1 { set widgetName [lindex $args 0] set varNsName $::itcl::internal::varNsName($widgetName) } default { upvar win win set widgetName $win set varNsName $::itcl::internal::varNsName($widgetName) set widgetType [lindex $args 1] incr replace if {[llength $args] > 3 && [lindex $args 2] eq "-class"} { set classNam [lindex $args 3] incr replace 2 } else { set classNam [string totitle $widgetType] } uplevel 1 [lreplace $args 0 $replace $widgetType $widgetName -class $classNam] uplevel 1 [list ${cmdPath}::initWidgetOptions $varNsName $widgetName $className] } } # initialize the itcl_hull variable set i 0 set nam ::itcl::internal::widgets::hull while {1} { incr i set hullNam ${nam}${i}$widgetName if {[::info command $hullNam] eq ""} { break } } uplevel 1 [list ${cmdPath}::sethullwindowname $widgetName] uplevel 1 [list ::rename $widgetName $hullNam] uplevel 1 [list ::trace add command $hullNam {delete rename} ::itcl::internal::commands::deletehull] catch {${cmdPath}::checksetitclhull [list] 0} namespace eval ${varNsName}${className} "set itcl_hull $hullNam" catch {${cmdPath}::checksetitclhull [list] 2} uplevel 1 [lreplace $args 0 $replace ${cmdPath}::initWidgetDelegatedOptions $varNsName $widgetName $className] } proc installcomponent {args} { upvar win win set className [uplevel 1 info class] set myType [${className}::info types [namespace tail $className]] set isType 0 if {$myType ne ""} { set isType 1 } set numArgs [llength $args] set usage "usage: installcomponent using ?-option value ...?" if {$numArgs < 4} { error $usage } foreach {componentName using widgetType widgetPath} $args break set opts [lrange $args 4 end] if {$using ne "using"} { error $usage } if {!$isType} { set hullExists [uplevel 1 ::info exists itcl_hull] if {!$hullExists} { error "cannot install \"$componentName\" before \"itcl_hull\" exists" } set hullVal [uplevel 1 set itcl_hull] if {$hullVal eq ""} { error "cannot install \"$componentName\" before \"itcl_hull\" exists" } } # check for delegated option and ask the option database for the values # first check for number of delegated options set numOpts 0 set starOption 0 set myDict [set ::itcl::internal::dicts::classDelegatedOptions] if {[dict exists $myDict $className]} { set myDict [dict get $myDict $className] foreach option [dict keys $myDict] { if {$option eq "*"} { set starOption 1 } incr numOpts } } set myOptionDict [set ::itcl::internal::dicts::classOptions] if {[dict exists $myOptionDict $className]} { set myOptionDict [dict get $myOptionDict $className] } set cmd [list $widgetPath configure] set cmd1 "set $componentName \[$widgetType $widgetPath\]" uplevel 1 $cmd1 if {$starOption} { upvar $componentName compName set cmd1 [list $compName configure] set configInfos [uplevel 1 $cmd1] foreach entry $configInfos { if {[llength $entry] > 2} { foreach {optName resource class defaultValue} $entry break set val "" catch { set val [::option get $win $resource $class] } if {$val ne ""} { set addOpt 1 if {[dict exists $myDict $$optName]} { set addOpt 0 } else { set starDict [dict get $myDict "*"] if {[dict exists $starDict -except]} { set exceptions [dict get $starDict -except] if {[lsearch $exceptions $optName] >= 0} { set addOpt 0 } } if {[dict exists $myOptionDict $optName]} { set addOpt 0 } } if {$addOpt} { lappend cmd $optName $val } } } } } else { foreach optName [dict keys $myDict] { set optInfos [dict get $myDict $optName] set resource [dict get $optInfos -resource] set class [namespace tail $className] set class [string totitle $class] set val "" catch { set val [::option get $win $resource $class] } if {$val ne ""} { if {[dict exists $optInfos -as] } { set optName [dict get $optInfos -as] } lappend cmd $optName $val } } } lappend cmd {*}$opts uplevel 1 $cmd } } ; # end ::itcl::builtin set ::itcl::internal::dicts::hullTypes [list \ frame \ toplevel \ labelframe \ ttk:frame \ ttk:toplevel \ ttk:labelframe \ ] namespace eval ::itcl::builtin::Info { proc hulltypes {args} { namespace upvar ::itcl::internal::dicts hullTypes hullTypes set numArgs [llength $args] if {$numArgs > 1} { error "wrong # args should be: info hulltypes ??" } set pattern "" if {$numArgs > 0} { set pattern [lindex $args 0] } if {$pattern ne ""} { return [lsearch -all -inline -glob $hullTypes $pattern] } return $hullTypes } proc widgetclasses {args} { set numArgs [llength $args] if {$numArgs > 1} { error "wrong # args should be: info widgetclasses ??" } set pattern "" if {$numArgs > 0} { set pattern [lindex $args 0] } set myDict [set ::itcl::internal::dicts::classes] if {![dict exists $myDict widget]} { return [list] } set myDict [dict get $myDict widget] set result [list] if {$pattern ne ""} { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] set value [dict get $myInfo -widget] if {[string match $pattern $value]} { lappend result $value } } } else { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] lappend result [dict get $myInfo -widget] } } return $result } proc widgets {args} { set numArgs [llength $args] if {$numArgs > 1} { error "wrong # args should be: info widgets ??" } set pattern "" if {$numArgs > 0} { set pattern [lindex $args 0] } set myDict [set ::itcl::internal::dicts::classes] if {![dict exists $myDict widget]} { return [list] } set myDict [dict get $myDict widget] set result [list] if {$pattern ne ""} { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] set value [dict get $myInfo -name] if {[string match $pattern $value]} { lappend result $value } } } else { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] lappend result [dict get $myInfo -name] } } return $result } proc widgetadaptors {args} { set numArgs [llength $args] if {$numArgs > 1} { error "wrong # args should be: info widgetadaptors ??" } set pattern "" if {$numArgs > 0} { set pattern [lindex $args 0] } set myDict [set ::itcl::internal::dicts::classes] if {![dict exists $myDict widgetadaptor]} { return [list] } set myDict [dict get $myDict widgetadaptor] set result [list] if {$pattern ne ""} { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] set value [dict get $myInfo -name] if {[string match $pattern $value]} { lappend result $value } } } else { foreach key [dict keys $myDict] { set myInfo [dict get $myDict $key] lappend result [dict get $myInfo -name] } } return $result } } ; # end ::itcl::builtin::Info itcl4.2.2/library/itcl.tcl0000644003604700454610000001204114137636151014100 0ustar dgp771div# # itcl.tcl # ---------------------------------------------------------------------- # Invoked automatically upon startup to customize the interpreter # for [incr Tcl]. # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. proc ::itcl::delete_helper { name args } { ::itcl::delete object $name } # ---------------------------------------------------------------------- # USAGE: local ? ...? # # Creates a new object called in class , passing # the remaining 's to the constructor. Unlike the usual # [incr Tcl] objects, however, an object created by this procedure # will be automatically deleted when the local call frame is destroyed. # This command is useful for creating objects that should only remain # alive until a procedure exits. # ---------------------------------------------------------------------- proc ::itcl::local {class name args} { set ptr [uplevel [list $class $name] $args] uplevel [list set itcl-local-$ptr $ptr] set cmd [uplevel namespace which -command $ptr] uplevel [list trace variable itcl-local-$ptr u \ "::itcl::delete_helper $cmd"] return $ptr } # ---------------------------------------------------------------------- # auto_mkindex # ---------------------------------------------------------------------- # Define Itcl commands that will be recognized by the auto_mkindex # parser in Tcl... # # # USAGE: itcl::class name body # Adds an entry for the given class declaration. # foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} { auto_mkindex_parser::command $__cmd {name body} { variable index variable scriptFile append index "set [list auto_index([fullname $name])]" append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" variable parser variable contextStack set contextStack [linsert $contextStack 0 $name] $parser eval $body set contextStack [lrange $contextStack 1 end] } } # # USAGE: itcl::body name arglist body # Adds an entry for the given method/proc body. # foreach __cmd {itcl::body body} { auto_mkindex_parser::command $__cmd {name arglist body} { variable index variable scriptFile append index "set [list auto_index([fullname $name])]" append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } } # # USAGE: itcl::configbody name arglist body # Adds an entry for the given method/proc body. # foreach __cmd {itcl::configbody configbody} { auto_mkindex_parser::command $__cmd {name body} { variable index variable scriptFile append index "set [list auto_index([fullname $name])]" append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } } # # USAGE: ensemble name ?body? # Adds an entry to the auto index list for the given ensemble name. # foreach __cmd {itcl::ensemble ensemble} { auto_mkindex_parser::command $__cmd {name {body ""}} { variable index variable scriptFile append index "set [list auto_index([fullname $name])]" append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } } # # USAGE: public arg ?arg arg...? # protected arg ?arg arg...? # private arg ?arg arg...? # # Evaluates the arguments as commands, so we can recognize proc # declarations within classes. # foreach __cmd {public protected private} { auto_mkindex_parser::command $__cmd {args} { variable parser $parser eval $args } } # SF bug #246 unset variable __cmd to avoid problems in user programs!! unset __cmd # ---------------------------------------------------------------------- # auto_import # ---------------------------------------------------------------------- # This procedure overrides the usual "auto_import" function in the # Tcl library. It is invoked during "namespace import" to make see # if the imported commands reside in an autoloaded library. If so, # stubs are created to represent the commands. Executing a stub # later on causes the real implementation to be autoloaded. # # Arguments - # pattern The pattern of commands being imported (like "foo::*") # a canonical namespace as returned by [namespace current] proc auto_import {pattern} { global auto_index set ns [uplevel namespace current] set patternList [auto_qualify $pattern $ns] auto_load_index foreach pattern $patternList { foreach name [array names auto_index $pattern] { if {"" == [info commands $name]} { ::itcl::import::stub create $name } } } } itcl4.2.2/library/itclHullCmds.tcl0000644003604700454610000005110014137636151015533 0ustar dgp771div# # itclHullCmds.tcl # ---------------------------------------------------------------------- # Invoked automatically upon startup to customize the interpreter # for [incr Tcl] when one of setupcomponent or createhull is called. # ---------------------------------------------------------------------- # AUTHOR: Arnulf P. Wiedemann # # ---------------------------------------------------------------------- # Copyright (c) 2008 Arnulf P. Wiedemann # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tk 8.6 namespace eval ::itcl::internal::commands { # ======================= widgetDeleted =========================== proc widgetDeleted {oldName newName op} { # The widget is beeing deleted, so we have to delete the object # which had the widget as itcl_hull too! # We have to get the real name from for example # ::itcl::internal::widgets::hull1.lw # we need only .lw here #puts stderr "widgetDeleted!$oldName!$newName!$op!" set cmdName [namespace tail $oldName] set flds [split $cmdName {.}] set cmdName .[join [lrange $flds 1 end] {.}] #puts stderr "DELWIDGET![namespace current]!$cmdName![::info command $cmdName]!" rename $cmdName {} } } namespace eval ::itcl::builtin { # ======================= createhull =========================== # the hull widget is a tk widget which is the (mega) widget handled behind the itcl # extendedclass/itcl widget. # It is created be renaming the itcl class object to a temporary name _ # creating the widget with the # appropriate options and the installing that as the "hull" widget (the container) # All the options in args and the options delegated to component itcl_hull are used # Then a unique name (hull_widget_name) in the itcl namespace is created for widget: # ::itcl::internal::widgets::hull # and widget is renamed to that name # Finally the _ is renamed to the original again # Component itcl_hull is created if not existent # itcl_hull is set to the hull_widget_name and the # is returned to the caller # ============================================================== proc createhull {widget_type path args} { variable hullCount upvar this this upvar win win #puts stderr "il-1![::info level -1]!$this!" #puts stderr "createhull!$widget_type!$path!$args!$this![::info command $this]!" #puts stderr "ns1![uplevel 1 namespace current]!" #puts stderr "ns2![uplevel 2 namespace current]!" #puts stderr "ns3![uplevel 3 namespace current]!" #puts stderr "level-1![::info level -1]!" #puts stderr "level-2![::info level -2]!" # set my_this [namespace tail $this] set my_this $this set tmp $my_this #puts stderr "II![::info command $this]![::info command $tmp]!" #puts stderr "rename1!rename $my_this ${tmp}_!" rename ::$my_this ${tmp}_ set options [list] foreach {option_name value} $args { switch -glob -- $option_name { -class { lappend options $option_name [namespace tail $value] } -* { lappend options $option_name $value } default { return -code error "bad option name\"$option_name\" options must start with a \"-\"" } } } set my_win [namespace tail $path] set cmd [list $widget_type $my_win] #puts stderr "my_win!$my_win!cmd!$cmd!$path!" if {[llength $options] > 0} { lappend cmd {*}$options } set widget [uplevel 1 $cmd] #puts stderr "widget!$widget!" trace add command $widget delete ::itcl::internal::commands::widgetDeleted set opts [uplevel 1 info delegated options] foreach entry $opts { foreach {optName compName} $entry break if {$compName eq "itcl_hull"} { set optInfos [uplevel 1 info delegated option $optName] set realOptName [lindex $optInfos 4] # strip off the "-" at the beginning set myOptName [string range $realOptName 1 end] set my_opt_val [option get $my_win $myOptName *] if {$my_opt_val ne ""} { $my_win configure -$myOptName $my_opt_val } } } set idx 1 while {1} { set widgetName ::itcl::internal::widgets::hull${idx}$my_win #puts stderr "widgetName!$widgetName!" if {[string length [::info command $widgetName]] == 0} { break } incr idx } #puts stderr "rename2!rename $widget $widgetName!" set dorename 0 rename $widget $widgetName #puts stderr "rename3!rename ${tmp}_ $tmp![::info command ${tmp}_]!my_this!$my_this!" rename ${tmp}_ ::$tmp set exists [uplevel 1 ::info exists itcl_hull] if {!$exists} { # that does not yet work, beacause of problems with resolving ::itcl::addcomponent $my_this itcl_hull } upvar itcl_hull itcl_hull ::itcl::setcomponent $my_this itcl_hull $widgetName #puts stderr "IC![::info command $my_win]!" set exists [uplevel 1 ::info exists itcl_interior] if {!$exists} { # that does not yet work, beacause of problems with resolving ::itcl::addcomponent $this itcl_interior } upvar itcl_interior itcl_interior set itcl_interior $my_win #puts stderr "hull end!win!$win!itcl_hull!$itcl_hull!itcl_interior!$itcl_interior!" return $my_win } # ======================= addToItclOptions =========================== proc addToItclOptions {my_class my_win myOptions argsDict} { upvar win win upvar itcl_hull itcl_hull set opt_lst [list configure] foreach opt [lsort $myOptions] { #puts stderr "IOPT!$opt!$my_class!$my_win![::itcl::is class $my_class]!" set isClass [::itcl::is class $my_class] set found 0 if {$isClass} { if {[catch { set resource [namespace eval $my_class info option $opt -resource] set class [namespace eval $my_class info option $opt -class] set default_val [uplevel 2 info option $opt -default] set found 1 } msg]} { # puts stderr "MSG!$opt!$my_class!$msg!" } } else { set tmp_win [uplevel #0 $my_class .___xx] set my_info [$tmp_win configure $opt] set resource [lindex $my_info 1] set class [lindex $my_info 2] set default_val [lindex $my_info 3] uplevel #0 destroy $tmp_win set found 1 } if {$found} { if {[catch { set val [uplevel #0 ::option get $win $resource $class] } msg]} { set val "" } if {[::dict exists $argsDict $opt]} { # we have an explicitly set option set val [::dict get $argsDict $opt] } else { if {[string length $val] == 0} { set val $default_val } } set ::itcl::internal::variables::${my_win}::itcl_options($opt) $val set ::itcl::internal::variables::${my_win}::__itcl_option_infos($opt) [list $resource $class $default_val] #puts stderr "OPT1!$opt!$val!" # uplevel 1 [list set itcl_options($opt) [list $val]] if {[catch {uplevel 1 $win configure $opt [list $val]} msg]} { #puts stderr "addToItclOptions ERR!$msg!$my_class!$win!configure!$opt!$val!" } } } } # ======================= setupcomponent =========================== proc setupcomponent {comp using widget_type path args} { upvar this this upvar win win upvar itcl_hull itcl_hull #puts stderr "setupcomponent!$comp!$widget_type!$path!$args!$this!$win!$itcl_hull!" #puts stderr "CONT![uplevel 1 info context]!" #puts stderr "ns1![uplevel 1 namespace current]!" #puts stderr "ns2![uplevel 2 namespace current]!" #puts stderr "ns3![uplevel 3 namespace current]!" set my_comp_object [lindex [uplevel 1 info context] 1] if {[::info exists ::itcl::internal::component_objects($my_comp_object)]} { set my_comp_object [set ::itcl::internal::component_objects($my_comp_object)] } else { set ::itcl::internal::component_objects($path) $my_comp_object } set options [list] foreach {option_name value} $args { switch -glob -- $option_name { -* { lappend options $option_name $value } default { return -code error "bad option name\"$option_name\" options must start with a \"-\"" } } } if {[llength $args]} { set argsDict [dict create {*}$args] } else { set argsDict [dict create] } set cmd [list $widget_type $path] if {[llength $options] > 0} { lappend cmd {*}$options } #puts stderr "cmd0![::info command $widget_type]!$path![::info command $path]!" #puts stderr "cmd1!$cmd!" # set my_comp [uplevel 3 $cmd] set my_comp [uplevel #0 $cmd] #puts stderr 111![::info command $path]! ::itcl::setcomponent $this $comp $my_comp set opts [uplevel 1 info delegated options] foreach entry $opts { foreach {optName compName} $entry break if {$compName eq $my_comp} { set optInfos [uplevel 1 info delegated option $optName] set realOptName [lindex $optInfos 4] # strip off the "-" at the beginning set myOptName [string range $realOptName 1 end] set my_opt_val [option get $my_win $myOptName *] if {$my_opt_val ne ""} { $my_comp configure -$myOptName $my_opt_val } } } set my_class $widget_type set my_parent_class [uplevel 1 namespace current] if {[catch { set myOptions [namespace eval $my_class {info classoptions}] } msg]} { set myOptions [list] } foreach entry [$path configure] { foreach {opt dummy1 dummy2 dummy3} $entry break lappend myOptions $opt } #puts stderr "OPTS!$myOptions!" addToItclOptions $widget_type $my_comp_object $myOptions $argsDict #puts stderr END!$path![::info command $path]! } proc itcl_initoptions {args} { puts stderr "ITCL_INITOPT!$args!" } # ======================= initoptions =========================== proc initoptions {args} { upvar win win upvar itcl_hull itcl_hull upvar itcl_option_components itcl_option_components #puts stderr "INITOPT!!$win!" if {[llength $args]} { set argsDict [dict create {*}$args] } else { set argsDict [dict create] } set my_class [uplevel 1 namespace current] set myOptions [namespace eval $my_class {info classoptions}] if {[dict exists $::itcl::internal::dicts::classComponents $my_class]} { set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class] # set myOptions [lsort -unique [namespace eval $my_class {info options}]] foreach comp [uplevel 1 info components] { if {[dict exists $class_info_dict $comp -keptoptions]} { foreach my_opt [dict get $class_info_dict $comp -keptoptions] { if {[lsearch $myOptions $my_opt] < 0} { #puts stderr "KEOPT!$my_opt!" lappend myOptions $my_opt } } } } } else { set class_info_dict [list] } #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!" set opt_lst [list configure] set my_win $win foreach opt [lsort $myOptions] { set found 0 if {[catch { set resource [uplevel 1 info option $opt -resource] set class [uplevel 1 info option $opt -class] set default_val [uplevel 1 info option $opt -default] set found 1 } msg]} { # puts stderr "MSG!$opt!$msg!" } #puts stderr "OPT!$opt!$found!" if {$found} { if {[catch { set val [uplevel #0 ::option get $my_win $resource $class] } msg]} { set val "" } if {[::dict exists $argsDict $opt]} { # we have an explicitly set option set val [::dict get $argsDict $opt] } else { if {[string length $val] == 0} { set val $default_val } } set ::itcl::internal::variables::${win}::itcl_options($opt) $val set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val] #puts stderr "OPT1!$opt!$val!" # uplevel 1 [list set itcl_options($opt) [list $val]] if {[catch {uplevel 1 $my_win configure $opt [list $val]} msg]} { puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!" } } foreach comp [dict keys $class_info_dict] { #puts stderr "OPT1!$opt!$comp![dict get $class_info_dict $comp]!" if {[dict exists $class_info_dict $comp -keptoptions]} { if {[lsearch [dict get $class_info_dict $comp -keptoptions] $opt] >= 0} { if {$found == 0} { # we use the option value of the first component for setting # the option, as the components are traversed in the dict # depending on the ordering of the component creation!! set my_info [uplevel 1 \[set $comp\] configure $opt] set resource [lindex $my_info 1] set class [lindex $my_info 2] set default_val [lindex $my_info 3] set found 2 set val [uplevel #0 ::option get $my_win $resource $class] if {[::dict exists $argsDict $opt]} { # we have an explicitly set option set val [::dict get $argsDict $opt] } else { if {[string length $val] == 0} { set val $default_val } } #puts stderr "OPT2!$opt!$val!" set ::itcl::internal::variables::${win}::itcl_options($opt) $val set ::itcl::internal::variables::${win}::__itcl_option_infos($opt) [list $resource $class $default_val] # uplevel 1 [list set itcl_options($opt) [list $val]] } if {[catch {uplevel 1 \[set $comp\] configure $opt [list $val]} msg]} { puts stderr "initoptions ERR2!$msg!$my_class!$comp!configure!$opt!$val!" } if {![uplevel 1 info exists itcl_option_components($opt)]} { set itcl_option_components($opt) [list] } if {[lsearch [set itcl_option_components($opt)] $comp] < 0} { if {![catch { set optval [uplevel 1 [list set itcl_options($opt)]] } msg3]} { uplevel 1 \[set $comp\] configure $opt $optval } lappend itcl_option_components($opt) $comp } } } } } # uplevel 1 $opt_lst } # ======================= setoptions =========================== proc setoptions {args} { #puts stderr "setOPT!!$args!" if {[llength $args]} { set argsDict [dict create {*}$args] } else { set argsDict [dict create] } set my_class [uplevel 1 namespace current] set myOptions [namespace eval $my_class {info options}] #puts stderr "OPTS!$win!$my_class![join [lsort $myOptions]] \n]!" set opt_lst [list configure] foreach opt [lsort $myOptions] { set found 0 if {[catch { set resource [uplevel 1 info option $opt -resource] set class [uplevel 1 info option $opt -class] set default_val [uplevel 1 info option $opt -default] set found 1 } msg]} { # puts stderr "MSG!$opt!$msg!" } #puts stderr "OPT!$opt!$found!" if {$found} { set val "" if {[::dict exists $argsDict $opt]} { # we have an explicitly set option set val [::dict get $argsDict $opt] } else { if {[string length $val] == 0} { set val $default_val } } set myObj [uplevel 1 set this] #puts stderr "myObj!$myObj!" set ::itcl::internal::variables::${myObj}::itcl_options($opt) $val set ::itcl::internal::variables::${myObj}::__itcl_option_infos($opt) [list $resource $class $default_val] #puts stderr "OPT1!$opt!$val!" uplevel 1 [list set itcl_options($opt) [list $val]] # if {[catch {uplevel 1 $myObj configure $opt [list $val]} msg]} { #puts stderr "initoptions ERR!$msg!$my_class!$my_win!configure!$opt!$val!" # } } } # uplevel 1 $opt_lst } # ========================= keepcomponentoption ====================== # Invoked by Tcl during evaluating constructor whenever # the "keepcomponentoption" command is invoked to list the options # to be kept when an ::itcl::extendedclass component has been setup # for an object. # # It checks, for all arguments, if the opt is an option of that class # and of that component. If that is the case it adds the component name # to the list of components for that option. # The variable is the object variable: itcl_option_components($opt) # # Handles the following syntax: # # keepcomponentoption ? ...? # # ====================================================================== proc keepcomponentoption {args} { upvar win win upvar itcl_hull itcl_hull set usage "wrong # args, should be: keepcomponentoption componentName optionName ?optionName ...?" #puts stderr "KEEP!$args![uplevel 1 namespace current]!" if {[llength $args] < 2} { puts stderr $usage return -code error } set my_hull [uplevel 1 set itcl_hull] set my_class [uplevel 1 namespace current] set comp [lindex $args 0] set args [lrange $args 1 end] set class_info_dict [dict get $::itcl::internal::dicts::classComponents $my_class] if {![dict exists $class_info_dict $comp]} { puts stderr "keepcomponentoption cannot find component \"$comp\"" return -code error } set class_comp_dict [dict get $class_info_dict $comp] if {![dict exists $class_comp_dict -keptoptions]} { dict set class_comp_dict -keptoptions [list] } foreach opt $args { #puts stderr "KEEP!$opt!" if {[string range $opt 0 0] ne "-"} { puts stderr "keepcomponentoption: option must begin with a \"-\"!" return -code error } if {[lsearch [dict get $class_comp_dict -keptoptions] $opt] < 0} { dict lappend class_comp_dict -keptoptions $opt } } if {![info exists ::itcl::internal::component_objects([lindex [uplevel 1 info context] 1])]} { set comp_object $::itcl::internal::component_objects([lindex [uplevel 1 info context] 1]) } else { set comp_object "unknown_comp_obj_$comp!" } dict set class_info_dict $comp $class_comp_dict dict set ::itcl::internal::dicts::classComponents $my_class $class_info_dict puts stderr "CLDI!$class_comp_dict!" addToItclOptions $my_class $comp_object $args [list] } proc ignorecomponentoption {args} { puts stderr "IGNORE_COMPONENT_OPTION!$args!" } proc renamecomponentoption {args} { puts stderr "rename_COMPONENT_OPTION!$args!" } proc addoptioncomponent {args} { puts stderr "ADD_OPTION_COMPONENT!$args!" } proc ignoreoptioncomponent {args} { puts stderr "IGNORE_OPTION_COMPONENT!$args!" } proc renameoptioncomponent {args} { puts stderr "RENAME_OPTION_COMPONENT!$args!" } proc getEclassOptions {args} { upvar win win #puts stderr "getEclassOptions!$args!$win![uplevel 1 namespace current]!" #parray ::itcl::internal::variables::${win}::itcl_options set result [list] foreach opt [array names ::itcl::internal::variables::${win}::itcl_options] { if {[catch { foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break lappend result [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]] } msg]} { } } return $result } proc eclassConfigure {args} { upvar win win #puts stderr "+++ eclassConfigure!$args!" if {[llength $args] > 1} { foreach {opt val} $args break if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} { set ::itcl::internal::variables::${win}::itcl_options($opt) $val return } } else { foreach {opt} $args break if {[::info exists ::itcl::internal::variables::${win}::itcl_options($opt)]} { #puts stderr "OP![set ::itcl::internal::variables::${win}::itcl_options($opt)]!" foreach {res cls def} [set ::itcl::internal::variables::${win}::__itcl_option_infos($opt)] break return [list $opt $res $cls $def [set ::itcl::internal::variables::${win}::itcl_options($opt)]] } } return -code error } } itcl4.2.2/generic/0000755003604700454610000000000014140773323012410 5ustar dgp771divitcl4.2.2/generic/itclUtil.c0000644003604700454610000010120314137636151014345 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * This segment provides common utility functions used throughout * the other [incr Tcl] source files. * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * overhauled version author: Arnulf Wiedemann * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" #include /* * POOL OF LIST ELEMENTS FOR LINKED LIST */ static Itcl_ListElem *listPool = NULL; static int listPoolLen = 0; #define ITCL_VALID_LIST 0x01face10 /* magic bit pattern for validation */ #define ITCL_LIST_POOL_SIZE 200 /* max number of elements in listPool */ /* * This structure is used to take a snapshot of the interpreter * state in Itcl_SaveInterpState. You can snapshot the state, * execute a command, and then back up to the result or the * error that was previously in progress. */ typedef struct InterpState { int validate; /* validation stamp */ int status; /* return code status */ Tcl_Obj *objResult; /* result object */ char *errorInfo; /* contents of errorInfo variable */ char *errorCode; /* contents of errorCode variable */ } InterpState; #define TCL_STATE_VALID 0x01233210 /* magic bit pattern for validation */ /* * ------------------------------------------------------------------------ * Itcl_Assert() * * Called whenever an assert() test fails. Prints a diagnostic * message and abruptly exits. * ------------------------------------------------------------------------ */ void Itcl_Assert( const char *testExpr, /* string representing test expression */ const char *fileName, /* file name containing this call */ int lineNumber) /* line number containing this call */ { Tcl_Panic("Itcl Assertion failed: \"%s\" (line %d of %s)", testExpr, lineNumber, fileName); } /* * ------------------------------------------------------------------------ * Itcl_InitStack() * * Initializes a stack structure, allocating a certain amount of memory * for the stack and setting the stack length to zero. * ------------------------------------------------------------------------ */ void Itcl_InitStack( Itcl_Stack *stack) /* stack to be initialized */ { stack->values = stack->space; stack->max = sizeof(stack->space)/sizeof(ClientData); stack->len = 0; } /* * ------------------------------------------------------------------------ * Itcl_DeleteStack() * * Destroys a stack structure, freeing any memory that may have been * allocated to represent it. * ------------------------------------------------------------------------ */ void Itcl_DeleteStack( Itcl_Stack *stack) /* stack to be deleted */ { /* * If memory was explicitly allocated (instead of using the * built-in buffer) then free it. */ if (stack->values != stack->space) { ckfree((char*)stack->values); } stack->values = NULL; stack->len = stack->max = 0; } /* * ------------------------------------------------------------------------ * Itcl_PushStack() * * Pushes a piece of client data onto the top of the given stack. * If the stack is not large enough, it is automatically resized. * ------------------------------------------------------------------------ */ void Itcl_PushStack( ClientData cdata, /* data to be pushed onto stack */ Itcl_Stack *stack) /* stack */ { ClientData *newStack; if (stack->len+1 >= stack->max) { stack->max = 2*stack->max; newStack = (ClientData*) ckalloc((unsigned)(stack->max*sizeof(ClientData))); if (stack->values) { memcpy((char*)newStack, (char*)stack->values, (size_t)(stack->len*sizeof(ClientData))); if (stack->values != stack->space) ckfree((char*)stack->values); } stack->values = newStack; } stack->values[stack->len++] = cdata; } /* * ------------------------------------------------------------------------ * Itcl_PopStack() * * Pops a bit of client data from the top of the given stack. * ------------------------------------------------------------------------ */ ClientData Itcl_PopStack( Itcl_Stack *stack) /* stack to be manipulated */ { if (stack->values && (stack->len > 0)) { stack->len--; return stack->values[stack->len]; } return NULL; } /* * ------------------------------------------------------------------------ * Itcl_PeekStack() * * Gets the current value from the top of the given stack. * ------------------------------------------------------------------------ */ ClientData Itcl_PeekStack( Itcl_Stack *stack) /* stack to be examined */ { if (stack->values && (stack->len > 0)) { return stack->values[stack->len-1]; } return NULL; } /* * ------------------------------------------------------------------------ * Itcl_GetStackValue() * * Gets a value at some index within the stack. Index "0" is the * first value pushed onto the stack. * ------------------------------------------------------------------------ */ ClientData Itcl_GetStackValue( Itcl_Stack *stack, /* stack to be examined */ int pos) /* get value at this index */ { if (stack->values && (stack->len > 0)) { assert(pos < stack->len); return stack->values[pos]; } return NULL; } /* * ------------------------------------------------------------------------ * Itcl_InitList() * * Initializes a linked list structure, setting the list to the empty * state. * ------------------------------------------------------------------------ */ void Itcl_InitList( Itcl_List *listPtr) /* list to be initialized */ { listPtr->validate = ITCL_VALID_LIST; listPtr->num = 0; listPtr->head = NULL; listPtr->tail = NULL; } /* * ------------------------------------------------------------------------ * Itcl_DeleteList() * * Destroys a linked list structure, deleting all of its elements and * setting it to an empty state. If the elements have memory associated * with them, this memory must be freed before deleting the list or it * will be lost. * ------------------------------------------------------------------------ */ void Itcl_DeleteList( Itcl_List *listPtr) /* list to be deleted */ { Itcl_ListElem *elemPtr; assert(listPtr->validate == ITCL_VALID_LIST); elemPtr = listPtr->head; while (elemPtr) { elemPtr = Itcl_DeleteListElem(elemPtr); } listPtr->validate = 0; } /* * ------------------------------------------------------------------------ * Itcl_CreateListElem() * * Low-level routined used by procedures like Itcl_InsertList() and * Itcl_AppendList() to create new list elements. If elements are * available, one is taken from the list element pool. Otherwise, * a new one is allocated. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_CreateListElem( Itcl_List *listPtr) /* list that will contain this new element */ { Itcl_ListElem *elemPtr; if (listPoolLen > 0) { elemPtr = listPool; listPool = elemPtr->next; --listPoolLen; } else { elemPtr = (Itcl_ListElem*)ckalloc((unsigned)sizeof(Itcl_ListElem)); } elemPtr->owner = listPtr; elemPtr->value = NULL; elemPtr->next = NULL; elemPtr->prev = NULL; return elemPtr; } /* * ------------------------------------------------------------------------ * Itcl_DeleteListElem() * * Destroys a single element in a linked list, returning it to a pool of * elements that can be later reused. Returns a pointer to the next * element in the list. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_DeleteListElem( Itcl_ListElem *elemPtr) /* list element to be deleted */ { Itcl_List *listPtr; Itcl_ListElem *nextPtr; nextPtr = elemPtr->next; if (elemPtr->prev) { elemPtr->prev->next = elemPtr->next; } if (elemPtr->next) { elemPtr->next->prev = elemPtr->prev; } listPtr = elemPtr->owner; if (elemPtr == listPtr->head) { listPtr->head = elemPtr->next; } if (elemPtr == listPtr->tail) { listPtr->tail = elemPtr->prev; } --listPtr->num; if (listPoolLen < ITCL_LIST_POOL_SIZE) { elemPtr->next = listPool; listPool = elemPtr; ++listPoolLen; } else { ckfree((char*)elemPtr); } return nextPtr; } /* * ------------------------------------------------------------------------ * Itcl_InsertList() * * Creates a new list element containing the given value and returns * a pointer to it. The element is inserted at the beginning of the * specified list. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_InsertList( Itcl_List *listPtr, /* list being modified */ ClientData val) /* value associated with new element */ { Itcl_ListElem *elemPtr; assert(listPtr->validate == ITCL_VALID_LIST); elemPtr = Itcl_CreateListElem(listPtr); elemPtr->value = val; elemPtr->next = listPtr->head; elemPtr->prev = NULL; if (listPtr->head) { listPtr->head->prev = elemPtr; } listPtr->head = elemPtr; if (listPtr->tail == NULL) { listPtr->tail = elemPtr; } ++listPtr->num; return elemPtr; } /* * ------------------------------------------------------------------------ * Itcl_InsertListElem() * * Creates a new list element containing the given value and returns * a pointer to it. The element is inserted in the list just before * the specified element. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_InsertListElem( Itcl_ListElem *pos, /* insert just before this element */ ClientData val) /* value associated with new element */ { Itcl_List *listPtr; Itcl_ListElem *elemPtr; listPtr = pos->owner; assert(listPtr->validate == ITCL_VALID_LIST); assert(pos != NULL); elemPtr = Itcl_CreateListElem(listPtr); elemPtr->value = val; elemPtr->prev = pos->prev; if (elemPtr->prev) { elemPtr->prev->next = elemPtr; } elemPtr->next = pos; pos->prev = elemPtr; if (listPtr->head == pos) { listPtr->head = elemPtr; } if (listPtr->tail == NULL) { listPtr->tail = elemPtr; } ++listPtr->num; return elemPtr; } /* * ------------------------------------------------------------------------ * Itcl_AppendList() * * Creates a new list element containing the given value and returns * a pointer to it. The element is appended at the end of the * specified list. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_AppendList( Itcl_List *listPtr, /* list being modified */ ClientData val) /* value associated with new element */ { Itcl_ListElem *elemPtr; assert(listPtr->validate == ITCL_VALID_LIST); elemPtr = Itcl_CreateListElem(listPtr); elemPtr->value = val; elemPtr->prev = listPtr->tail; elemPtr->next = NULL; if (listPtr->tail) { listPtr->tail->next = elemPtr; } listPtr->tail = elemPtr; if (listPtr->head == NULL) { listPtr->head = elemPtr; } ++listPtr->num; return elemPtr; } /* * ------------------------------------------------------------------------ * Itcl_AppendListElem() * * Creates a new list element containing the given value and returns * a pointer to it. The element is inserted in the list just after * the specified element. * ------------------------------------------------------------------------ */ Itcl_ListElem* Itcl_AppendListElem( Itcl_ListElem *pos, /* insert just after this element */ ClientData val) /* value associated with new element */ { Itcl_List *listPtr; Itcl_ListElem *elemPtr; listPtr = pos->owner; assert(listPtr->validate == ITCL_VALID_LIST); assert(pos != NULL); elemPtr = Itcl_CreateListElem(listPtr); elemPtr->value = val; elemPtr->next = pos->next; if (elemPtr->next) { elemPtr->next->prev = elemPtr; } elemPtr->prev = pos; pos->next = elemPtr; if (listPtr->tail == pos) { listPtr->tail = elemPtr; } if (listPtr->head == NULL) { listPtr->head = elemPtr; } ++listPtr->num; return elemPtr; } /* * ------------------------------------------------------------------------ * Itcl_SetListValue() * * Modifies the value associated with a list element. * ------------------------------------------------------------------------ */ void Itcl_SetListValue( Itcl_ListElem *elemPtr, /* list element being modified */ ClientData val) /* new value associated with element */ { assert(elemPtr != NULL); assert(elemPtr->owner->validate == ITCL_VALID_LIST); elemPtr->value = val; } /* * ------------------------------------------------------------------------ * Itcl_FinishList() * * free all memory used in the list pool * ------------------------------------------------------------------------ */ void Itcl_FinishList() { Itcl_ListElem *listPtr; Itcl_ListElem *elemPtr; listPtr = listPool; while (listPtr != NULL) { elemPtr = listPtr; listPtr = elemPtr->next; ckfree((char *)elemPtr); elemPtr = NULL; } listPool = NULL; listPoolLen = 0; } /* * ======================================================================== * REFERENCE-COUNTED DATA * * The following procedures manage generic reference-counted data. * They are similar in spirit to the Tcl_Preserve/Tcl_Release * procedures defined in the Tcl/Tk core. But these procedures attach a * refcount directly to the allocated memory, and then use it to govern * shared access and properly timed release. */ typedef struct PresMemoryPrefix { Tcl_FreeProc *freeProc; /* called by last Itcl_ReleaseData */ size_t refCount; /* refernce (resp preserving) counter */ } PresMemoryPrefix; /* * ------------------------------------------------------------------------ * Itcl_EventuallyFree() * * Asscociates with cdata (allocated by Itcl_Alloc()) a routine to * be called when cdata should be freed. This routine will be called * when the number of Itcl_ReleaseData() calls on cdata matches the * number of Itcl_PreserveData() calls on cdata. * ------------------------------------------------------------------------ */ void Itcl_EventuallyFree( ClientData cdata, /* data to be freed when not in use */ Tcl_FreeProc *fproc) /* procedure called to free data */ { PresMemoryPrefix *blk; if (cdata == NULL) { return; } /* Itcl memory block to ckalloc block */ blk = ((PresMemoryPrefix *)cdata)-1; /* Set new free proc */ blk->freeProc = fproc; } /* * ------------------------------------------------------------------------ * Itcl_PreserveData() * * Increases the usage count for a piece of data that will be freed * later when no longer needed. Each call to Itcl_PreserveData() * puts one claim on a piece of data, and subsequent calls to * Itcl_ReleaseData() remove those claims. When Itcl_EventuallyFree() * is called, and when the usage count reaches zero, the data is * freed. * ------------------------------------------------------------------------ */ void Itcl_PreserveData( ClientData cdata) /* data to be preserved */ { PresMemoryPrefix *blk; if (cdata == NULL) { return; } /* Itcl memory block to ckalloc block */ blk = ((PresMemoryPrefix *)cdata)-1; /* Increment preservation count */ ++blk->refCount; } /* * ------------------------------------------------------------------------ * Itcl_ReleaseData() * * Decreases the usage count for a piece of data that was registered * previously via Itcl_PreserveData(). After Itcl_EventuallyFree() * is called and the usage count reaches zero, the data is * automatically freed. * ------------------------------------------------------------------------ */ void Itcl_ReleaseData( ClientData cdata) /* data to be released */ { PresMemoryPrefix *blk; Tcl_FreeProc *freeProc; if (cdata == NULL) { return; } /* Itcl memory block to ckalloc block */ blk = ((PresMemoryPrefix *)cdata)-1; /* Usage sanity check */ assert(blk->refCount != 0); /* must call Itcl_PreserveData() first */ assert(blk->freeProc); /* must call Itcl_EventuallyFree() first */ /* Decrement preservation count */ if (--blk->refCount) { return; } /* Free cdata now */ freeProc = blk->freeProc; blk->freeProc = NULL; freeProc((char *)cdata); } /* * ------------------------------------------------------------------------ * Itcl_Alloc() * * Allocate preservable memory. In opposite to ckalloc the result can be * supplied to preservation facilities of Itcl (Itcl_PreserveData). * * Results: * Pointer to new allocated memory. * ------------------------------------------------------------------------ */ void * Itcl_Alloc( size_t size) /* Size of memory to allocate */ { size_t numBytes; PresMemoryPrefix *blk; /* The ckalloc() in Tcl 8 can alloc at most UINT_MAX bytes */ assert (size <= UINT_MAX - sizeof(PresMemoryPrefix)); numBytes = size + sizeof(PresMemoryPrefix); /* This will panic on allocation failure. No need to check return value. */ blk = (PresMemoryPrefix *)ckalloc(numBytes); /* Itcl_Alloc defined to zero-init memory it allocates */ memset(blk, 0, numBytes); /* ckalloc block to Itcl memory block */ return blk+1; } /* * ------------------------------------------------------------------------ * ItclFree() * * Release memory allocated by Itcl_Alloc() that was never preserved. * * Results: * None. * * ------------------------------------------------------------------------ */ void Itcl_Free(void *ptr) { PresMemoryPrefix *blk; if (ptr == NULL) { return; } /* Itcl memory block to ckalloc block */ blk = ((PresMemoryPrefix *)ptr)-1; assert(blk->refCount == 0); /* it should be not preserved */ assert(blk->freeProc == NULL); /* it should be released */ ckfree(blk); } /* * ------------------------------------------------------------------------ * Itcl_SaveInterpState() * * Takes a snapshot of the current result state of the interpreter. * The snapshot can be restored at any point by Itcl_RestoreInterpState. * So if you are in the middle of building a return result, you can * snapshot the interpreter, execute a command that might generate an * error, restore the snapshot, and continue building the result string. * * Once a snapshot is saved, it must be restored by calling * Itcl_RestoreInterpState, or discarded by calling * Itcl_DiscardInterpState. Otherwise, memory will be leaked. * * Returns a token representing the state of the interpreter. * ------------------------------------------------------------------------ */ Itcl_InterpState Itcl_SaveInterpState( Tcl_Interp* interp, /* interpreter being modified */ int status) /* integer status code for current operation */ { return (Itcl_InterpState) Tcl_SaveInterpState(interp, status); } /* * ------------------------------------------------------------------------ * Itcl_RestoreInterpState() * * Restores the state of the interpreter to a snapshot taken by * Itcl_SaveInterpState. This affects variables such as "errorInfo" * and "errorCode". After this call, the token for the interpreter * state is no longer valid. * * Returns the status code that was pending at the time the state was * captured. * ------------------------------------------------------------------------ */ int Itcl_RestoreInterpState( Tcl_Interp* interp, /* interpreter being modified */ Itcl_InterpState state) /* token representing interpreter state */ { return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state); } /* * ------------------------------------------------------------------------ * Itcl_DiscardInterpState() * * Frees the memory associated with an interpreter snapshot taken by * Itcl_SaveInterpState. If the snapshot is not restored, this * procedure must be called to discard it, or the memory will be lost. * After this call, the token for the interpreter state is no longer * valid. * ------------------------------------------------------------------------ */ void Itcl_DiscardInterpState( Itcl_InterpState state) /* token representing interpreter state */ { Tcl_DiscardInterpState((Tcl_InterpState)state); return; } /* * ------------------------------------------------------------------------ * Itcl_Protection() * * Used to query/set the protection level used when commands/variables * are defined within a class. The default protection level (when * no public/protected/private command is active) is ITCL_DEFAULT_PROTECT. * In the default case, new commands are treated as public, while new * variables are treated as protected. * * If the specified level is 0, then this procedure returns the * current value without changing it. Otherwise, it sets the current * value to the specified protection level, and returns the previous * value. * ------------------------------------------------------------------------ */ int Itcl_Protection( Tcl_Interp *interp, /* interpreter being queried */ int newLevel) /* new protection level or 0 */ { int oldVal; ItclObjectInfo *infoPtr; /* * If a new level was specified, then set the protection level. * In any case, return the protection level as it stands right now. */ infoPtr = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); assert(infoPtr != NULL); oldVal = infoPtr->protection; if (newLevel != 0) { assert(newLevel == ITCL_PUBLIC || newLevel == ITCL_PROTECTED || newLevel == ITCL_PRIVATE || newLevel == ITCL_DEFAULT_PROTECT); infoPtr->protection = newLevel; } return oldVal; } /* * ------------------------------------------------------------------------ * Itcl_ParseNamespPath() * * Parses a reference to a namespace element of the form: * * namesp::namesp::namesp::element * * Returns pointers to the head part ("namesp::namesp::namesp") * and the tail part ("element"). If the head part is missing, * a NULL pointer is returned and the rest of the string is taken * as the tail. * * Both head and tail point to locations within the given dynamic * string buffer. This buffer must be uninitialized when passed * into this procedure, and it must be freed later on, when the * strings are no longer needed. * ------------------------------------------------------------------------ */ void Itcl_ParseNamespPath( const char *name, /* path name to class member */ Tcl_DString *buffer, /* dynamic string buffer (uninitialized) */ const char **head, /* returns "namesp::namesp::namesp" part */ const char **tail) /* returns "element" part */ { char *sep, *newname; Tcl_DStringInit(buffer); /* * Copy the name into the buffer and parse it. Look * backward from the end of the string to the first '::' * scope qualifier. */ Tcl_DStringAppend(buffer, name, -1); newname = Tcl_DStringValue(buffer); for (sep=newname; *sep != '\0'; sep++) ; while (--sep > newname) { if (*sep == ':' && *(sep-1) == ':') { break; } } /* * Found head/tail parts. If there are extra :'s, keep backing * up until the head is found. This supports the Tcl namespace * behavior, which allows names like "foo:::bar". */ if (sep > newname) { *tail = sep+1; while (sep > newname && *(sep-1) == ':') { sep--; } *sep = '\0'; *head = newname; } else { /* * No :: separators--the whole name is treated as a tail. */ *tail = newname; *head = NULL; } } /* * ------------------------------------------------------------------------ * Itcl_CanAccess2() * * Checks to see if a class member can be accessed from a particular * namespace context. Public things can always be accessed. Protected * things can be accessed if the "from" namespace appears in the * inheritance hierarchy of the class namespace. Private things * can be accessed only if the "from" namespace is the same as the * class that contains them. * * Returns 1/0 indicating true/false. * ------------------------------------------------------------------------ */ int Itcl_CanAccess2( ItclClass *iclsPtr, /* class being tested */ int protection, /* protection level being tested */ Tcl_Namespace* fromNsPtr) /* namespace requesting access */ { ItclClass* fromIclsPtr; Tcl_HashEntry *entry; /* * If the protection level is "public" or "private", then the * answer is known immediately. */ if (protection == ITCL_PUBLIC) { return 1; } else { if (protection == ITCL_PRIVATE) { entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, fromNsPtr); if (entry == NULL) { return 0; } return (iclsPtr == Tcl_GetHashValue(entry)); } } /* * If the protection level is "protected", then check the * heritage of the namespace requesting access. If cdefnPtr * is in the heritage, then access is allowed. */ assert (protection == ITCL_PROTECTED); if (Itcl_IsClassNamespace(fromNsPtr)) { entry = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, fromNsPtr); if (entry == NULL) { return 0; } fromIclsPtr = (ItclClass *)Tcl_GetHashValue(entry); entry = Tcl_FindHashEntry(&fromIclsPtr->heritage, (char*)iclsPtr); if (entry) { return 1; } } return 0; } /* * ------------------------------------------------------------------------ * Itcl_CanAccess() * * Checks to see if a class member can be accessed from a particular * namespace context. Public things can always be accessed. Protected * things can be accessed if the "from" namespace appears in the * inheritance hierarchy of the class namespace. Private things * can be accessed only if the "from" namespace is the same as the * class that contains them. * * Returns 1/0 indicating true/false. * ------------------------------------------------------------------------ */ int Itcl_CanAccess( ItclMemberFunc* imPtr, /* class member being tested */ Tcl_Namespace* fromNsPtr) /* namespace requesting access */ { return Itcl_CanAccess2(imPtr->iclsPtr, imPtr->protection, fromNsPtr); } /* * ------------------------------------------------------------------------ * Itcl_CanAccessFunc() * * Checks to see if a member function with the specified protection * level can be accessed from a particular namespace context. This * follows the same rules enforced by Itcl_CanAccess, but adds one * special case: If the function is a protected method, and if the * current context is a base class that has the same method, then * access is allowed. * * Returns 1/0 indicating true/false. * ------------------------------------------------------------------------ */ int Itcl_CanAccessFunc( ItclMemberFunc* imPtr, /* member function being tested */ Tcl_Namespace* fromNsPtr) /* namespace requesting access */ { ItclClass *iclsPtr; ItclClass *fromIclsPtr; ItclMemberFunc *ovlfunc; Tcl_HashEntry *entry; /* * Apply the usual rules first. */ if (Itcl_CanAccess(imPtr, fromNsPtr)) { return 1; } /* * As a last resort, see if the namespace is really a base * class of the class containing the method. Look for a * method with the same name in the base class. If there * is one, then this method overrides it, and the base class * has access. */ if ((imPtr->flags & ITCL_COMMON) == 0 && Itcl_IsClassNamespace(fromNsPtr)) { Tcl_HashEntry *hPtr; iclsPtr = imPtr->iclsPtr; hPtr = Tcl_FindHashEntry(&iclsPtr->infoPtr->namespaceClasses, (char *)fromNsPtr); if (hPtr == NULL) { return 0; } fromIclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); if (Tcl_FindHashEntry(&iclsPtr->heritage, (char*)fromIclsPtr)) { entry = Tcl_FindHashEntry(&fromIclsPtr->resolveCmds, (char *)imPtr->namePtr); if (entry) { ItclCmdLookup *clookup; clookup = (ItclCmdLookup *)Tcl_GetHashValue(entry); ovlfunc = clookup->imPtr; if ((ovlfunc->flags & ITCL_COMMON) == 0 && ovlfunc->protection < ITCL_PRIVATE) { return 1; } } } } return 0; } /* * ------------------------------------------------------------------------ * Itcl_DecodeScopedCommand() * * Decodes a scoped command of the form: * * namespace inscope * * If the given string is not a scoped value, this procedure does * nothing and returns TCL_OK. If the string is a scoped value, * then it is decoded, and the namespace, and the simple command * string are returned as arguments; the simple command should * be freed when no longer in use. If anything goes wrong, this * procedure returns TCL_ERROR, along with an error message in * the interpreter. * ------------------------------------------------------------------------ */ int Itcl_DecodeScopedCommand( Tcl_Interp *interp, /* current interpreter */ const char *name, /* string to be decoded */ Tcl_Namespace **rNsPtr, /* returns: namespace for scoped value */ char **rCmdPtr) /* returns: simple command word */ { Tcl_Namespace *nsPtr; char *cmdName; const char *pos; const char **listv; int listc; int result; int len; nsPtr = NULL; len = strlen(name); cmdName = (char *)ckalloc(strlen(name)+1); strcpy(cmdName, name); if ((*name == 'n') && (len > 17) && (strncmp(name, "namespace", 9) == 0)) { for (pos = (name + 9); (*pos == ' '); pos++) { /* empty body: skip over spaces */ } if ((*pos == 'i') && ((pos + 7) <= (name + len)) && (strncmp(pos, "inscope", 7) == 0)) { result = Tcl_SplitList(interp, (const char *)name, &listc, &listv); if (result == TCL_OK) { if (listc != 4) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "malformed command \"", name, "\": should be \"", "namespace inscope namesp command\"", NULL); result = TCL_ERROR; } else { nsPtr = Tcl_FindNamespace(interp, listv[2], NULL, TCL_LEAVE_ERR_MSG); if (nsPtr == NULL) { result = TCL_ERROR; } else { ckfree(cmdName); cmdName = (char *)ckalloc(strlen(listv[3])+1); strcpy(cmdName, listv[3]); } } } ckfree((char*)listv); if (result != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while decoding scoped command \"%s\")", name)); ckfree(cmdName); return TCL_ERROR; } } } *rNsPtr = nsPtr; *rCmdPtr = cmdName; return TCL_OK; } itcl4.2.2/generic/itclTestRegisterC.c0000644003604700454610000001061014137636151016160 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * This part adds a mechanism for integrating C procedures into * [incr Tcl] classes as methods and procs. Each C procedure must * either be declared via Itcl_RegisterC() or dynamically loaded. * * ======================================================================== * AUTHOR: Arnulf Wiedemann * ======================================================================== * Copyright (c) Arnulf Wiedemann * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef ITCL_DEBUG_C_INTERFACE #include #include "itclInt.h" Tcl_CmdProc cArgFunc; Tcl_ObjCmdProc cObjFunc; int cArgFunc( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv) { int result; ItclObjectInfo * infoPtr = NULL; ItclClass *iclsPtr = NULL; ItclClass * classPtr; ItclObject * rioPtr = (ItclObject *)1; Tcl_Obj * objv[4]; FOREACH_HASH_DECLS; //fprintf(stderr, "argc: %d\n", argc); if (argc != 4) { Tcl_AppendResult(interp, "wrong #args: should be ::itcl::parser::handleClass className className objectName", NULL); return TCL_ERROR; } objv[0] = Tcl_NewStringObj(argv[0], -1); objv[1] = Tcl_NewStringObj(argv[1], -1); /* class name */ objv[2] = Tcl_NewStringObj(argv[2], -1); /* full class name */ objv[3] = Tcl_NewStringObj(argv[3], -1); /* object name */ Tcl_IncrRefCount(objv[0]); Tcl_IncrRefCount(objv[1]); Tcl_IncrRefCount(objv[2]); Tcl_IncrRefCount(objv[3]); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { iclsPtr = classPtr; break; } } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "no such class: ", Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } /* try to create an object for a class as a test for calling a C function from * an Itcl class. See file CreateItclObjectWithC_example.tcl in library directory */ result = Itcl_CreateObject(interp, Tcl_GetString(objv[3]), iclsPtr, 4, objv, &rioPtr); return result; } int cObjFunc( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tcl_Namespace *nsPtr; ItclObjectInfo * infoPtr = NULL; ItclClass *iclsPtr = NULL; ItclClass * classPtr; FOREACH_HASH_DECLS; int i; ItclShowArgs(0, "cObjFunc called", objc, objv); fprintf(stderr, "objv: %d %p\n", objc, objv); for(i = 0; ifullName); infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); FOREACH_HASH_VALUE(classPtr,&infoPtr->nameClasses) { if (strcmp(Tcl_GetString(objv[1]), Tcl_GetString(classPtr->fullNamePtr)) == 0 || strcmp(Tcl_GetString(objv[2]), Tcl_GetString(classPtr->fullNamePtr)) == 0) { iclsPtr = classPtr; break; } } fprintf(stderr, "IP2:%p %p %p\n",interp, clientData, iclsPtr); return TCL_OK; } void RegisterDebugCFunctions(Tcl_Interp *interp) { int result; /* args: interp, name, c-function, clientdata, deleteproc */ result = Itcl_RegisterC(interp, "cArgFunc", cArgFunc, NULL, NULL); result = Itcl_RegisterObjC(interp, "cObjFunc", cObjFunc, NULL, NULL); if (result != 0) { } } #endif itcl4.2.2/generic/itclTclIntStubsFcn.h0000644003604700454610000000326714137636151016315 0ustar dgp771div/* these functions are Tcl internal stubs so make an Itcl_* wrapper */ MODULE_SCOPE void Itcl_GetVariableFullName (Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr); MODULE_SCOPE Tcl_Var Itcl_FindNamespaceVar (Tcl_Interp * interp, const char * name, Tcl_Namespace * contextNsPtr, int flags); MODULE_SCOPE void Itcl_SetNamespaceResolvers (Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc); #ifndef _TCL_PROC_DEFINED typedef struct Tcl_Proc_ *Tcl_Proc; #define _TCL_PROC_DEFINED 1 #endif #ifndef _TCL_RESOLVE_DEFINED struct Tcl_Resolve; #endif #define Tcl_GetOriginalCommand _Tcl_GetOriginalCommand #define Tcl_CreateProc _Tcl_CreateProc #define Tcl_ProcDeleteProc _Tcl_ProcDeleteProc #define Tcl_GetObjInterpProc _Tcl_GetObjInterpProc MODULE_SCOPE Tcl_Command _Tcl_GetOriginalCommand(Tcl_Command command); MODULE_SCOPE int _Tcl_CreateProc(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Tcl_Proc *procPtrPtr); MODULE_SCOPE void _Tcl_ProcDeleteProc(ClientData clientData); MODULE_SCOPE Tcl_ObjCmdProc *_Tcl_GetObjInterpProc(void); MODULE_SCOPE int Tcl_RenameCommand(Tcl_Interp *interp, const char *oldName, const char *newName); MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceChildTable(Tcl_Namespace *nsPtr); MODULE_SCOPE Tcl_HashTable *Itcl_GetNamespaceCommandTable(Tcl_Namespace *nsPtr); MODULE_SCOPE int Itcl_InitRewriteEnsemble(Tcl_Interp *interp, int numRemoved, int numInserted, int objc, Tcl_Obj *const *objv); MODULE_SCOPE void Itcl_ResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble); itcl4.2.2/generic/itclTclIntStubsFcn.c0000644003604700454610000000622314137636151016303 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * This file contains procedures that use the internal Tcl core stubs * entries. * * ======================================================================== * AUTHOR: Arnulf Wiedemann * * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include #include "itclInt.h" Tcl_Command _Tcl_GetOriginalCommand( Tcl_Command command) { return TclGetOriginalCommand(command); } int _Tcl_CreateProc( Tcl_Interp *interp, /* Interpreter containing proc. */ Tcl_Namespace *nsPtr, /* Namespace containing this proc. */ const char *procName, /* Unqualified name of this proc. */ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Tcl_Proc *procPtrPtr) /* Returns: pointer to proc data. */ { int code = TclCreateProc(interp, (Namespace *)nsPtr, procName, argsPtr, bodyPtr, (Proc **)procPtrPtr); (*(Proc **)procPtrPtr)->cmdPtr = NULL; return code; } Tcl_ObjCmdProc * _Tcl_GetObjInterpProc( void) { return (Tcl_ObjCmdProc *)TclGetObjInterpProc(); } void _Tcl_ProcDeleteProc( ClientData clientData) { TclProcDeleteProc(clientData); } int Itcl_RenameCommand( Tcl_Interp *interp, const char *oldName, const char *newName) { return TclRenameCommand(interp, oldName, newName); } int Itcl_PushCallFrame( Tcl_Interp * interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame) { return Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame); } void Itcl_PopCallFrame( Tcl_Interp * interp) { Tcl_PopCallFrame(interp); } void Itcl_GetVariableFullName( Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr) { Tcl_GetVariableFullName(interp, variable, objPtr); } Tcl_Var Itcl_FindNamespaceVar( Tcl_Interp * interp, const char * name, Tcl_Namespace * contextNsPtr, int flags) { return Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags); } void Itcl_SetNamespaceResolvers ( Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc) { Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc); } Tcl_HashTable * Itcl_GetNamespaceCommandTable( Tcl_Namespace *nsPtr) { return TclGetNamespaceCommandTable(nsPtr); } Tcl_HashTable * Itcl_GetNamespaceChildTable( Tcl_Namespace *nsPtr) { return TclGetNamespaceChildTable(nsPtr); } int Itcl_InitRewriteEnsemble( Tcl_Interp *interp, int numRemoved, int numInserted, TCL_UNUSED(int) /* objc */, Tcl_Obj *const *objv) { return TclInitRewriteEnsemble(interp, numRemoved, numInserted, objv); } void Itcl_ResetRewriteEnsemble( Tcl_Interp *interp, int isRootEnsemble) { TclResetRewriteEnsemble(interp, isRootEnsemble); } itcl4.2.2/generic/itclStubs.c0000644003604700454610000001600614137636151014536 0ustar dgp771div/* * itclStubs.c -- * * This file contains the C-implemeted part of Itcl object-system * Itcl * * Copyright (c) 2006 by Arnulf P. Wiedemann * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" static void ItclDeleteStub(ClientData cdata); static int ItclHandleStubCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* * ------------------------------------------------------------------------ * Itcl_IsStub() * * Checks the given Tcl command to see if it represents an autoloading * stub created by the "stub create" command. Returns non-zero if * the command is indeed a stub. * ------------------------------------------------------------------------ */ int Itcl_IsStub( Tcl_Command cmdPtr) /* command being tested */ { Tcl_CmdInfo cmdInfo; /* * This may be an imported command, but don't try to get the * original. Just check to see if this particular command * is a stub. If we really want the original command, we'll * find it at a higher level. */ if (Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo) == 1) { if (cmdInfo.deleteProc == ItclDeleteStub) { return 1; } } return 0; } /* * ------------------------------------------------------------------------ * Itcl_StubCreateCmd() * * Invoked by Tcl whenever the user issues a "stub create" command to * create an autoloading stub for imported commands. Handles the * following syntax: * * stub create * * Creates a command called . Executing this command will cause * the real command to be autoloaded. * ------------------------------------------------------------------------ */ int Itcl_StubCreateCmd( TCL_UNUSED(ClientData), /* not used */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Command cmdPtr; char *cmdName; Tcl_CmdInfo cmdInfo; ItclShowArgs(1, "Itcl_StubCreateCmd", objc, objv); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } cmdName = Tcl_GetString(objv[1]); /* * Create a stub command with the characteristic ItclDeleteStub * procedure. That way, we can recognize this command later * on as a stub. Save the cmd token as client data, so we can * get the full name of this command later on. */ cmdPtr = Tcl_CreateObjCommand(interp, cmdName, ItclHandleStubCmd, NULL, (Tcl_CmdDeleteProc*)ItclDeleteStub); Tcl_GetCommandInfoFromToken(cmdPtr, &cmdInfo); cmdInfo.objClientData = cmdPtr; Tcl_SetCommandInfoFromToken(cmdPtr, &cmdInfo); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_StubExistsCmd() * * Invoked by Tcl whenever the user issues a "stub exists" command to * see if an existing command is an autoloading stub. Handles the * following syntax: * * stub exists * * Looks for a command called and checks to see if it is an * autoloading stub. Returns a boolean result. * ------------------------------------------------------------------------ */ int Itcl_StubExistsCmd( TCL_UNUSED(ClientData), /* not used */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Command cmdPtr; char *cmdName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } cmdName = Tcl_GetString(objv[1]); cmdPtr = Tcl_FindCommand(interp, cmdName, NULL, 0); if ((cmdPtr != NULL) && Itcl_IsStub(cmdPtr)) { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclHandleStubCmd() * * Invoked by Tcl to handle commands created by "stub create". * Calls "auto_load" with the full name of the current command to * trigger autoloading of the real implementation. Then, calls the * command to handle its function. If successful, this command * returns TCL_OK along with the result from the real implementation * of this command. Otherwise, it returns TCL_ERROR, along with an * error message in the interpreter. * ------------------------------------------------------------------------ */ static int ItclHandleStubCmd( ClientData clientData, /* command token for this stub */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Command cmdPtr; Tcl_Obj **cmdlinev; Tcl_Obj *objAutoLoad[2]; Tcl_Obj *objPtr; Tcl_Obj *cmdNamePtr; Tcl_Obj *cmdlinePtr; char *cmdName; int result; int loaded; int cmdlinec; ItclShowArgs(1, "ItclHandleStubCmd", objc, objv); cmdPtr = (Tcl_Command) clientData; cmdNamePtr = Tcl_NewStringObj(NULL, 0); Tcl_IncrRefCount(cmdNamePtr); Tcl_GetCommandFullName(interp, cmdPtr, cmdNamePtr); cmdName = Tcl_GetString(cmdNamePtr); /* * Try to autoload the real command for this stub. */ objAutoLoad[0] = Tcl_NewStringObj("::auto_load", -1); objAutoLoad[1] = cmdNamePtr; result = Tcl_EvalObjv(interp, 2, objAutoLoad, 0); if (result != TCL_OK) { Tcl_DecrRefCount(cmdNamePtr); return TCL_ERROR; } objPtr = Tcl_GetObjResult(interp); result = Tcl_GetIntFromObj(interp, objPtr, &loaded); if ((result != TCL_OK) || !loaded) { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't autoload \"", cmdName, "\"", NULL); Tcl_DecrRefCount(cmdNamePtr); return TCL_ERROR; } /* * At this point, the real implementation has been loaded. * Invoke the command again with the arguments passed in. */ cmdlinePtr = Itcl_CreateArgs(interp, cmdName, objc - 1, objv + 1); (void) Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); Tcl_DecrRefCount(cmdNamePtr); Tcl_ResetResult(interp); ItclShowArgs(1, "ItclHandleStubCmd", cmdlinec - 1, cmdlinev + 1); result = Tcl_EvalObjv(interp, cmdlinec - 1, cmdlinev + 1, TCL_EVAL_DIRECT); Tcl_DecrRefCount(cmdlinePtr); Tcl_DecrRefCount(objAutoLoad[0]); return result; } /* * ------------------------------------------------------------------------ * ItclDeleteStub() * * Invoked by Tcl whenever a stub command is deleted. This procedure * does nothing, but its presence identifies a command as a stub. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static void ItclDeleteStub( TCL_UNUSED(ClientData)) /* not used */ { /* do nothing */ } itcl4.2.2/generic/itclStubLib.c0000644003604700454610000000336614137636151015007 0ustar dgp771div/* * SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17 */ #define USE_TCL_STUBS 1 #define USE_ITCL_STUBS 1 #include "itclInt.h" #undef Itcl_InitStubs MODULE_SCOPE const ItclStubs *itclStubsPtr; MODULE_SCOPE const ItclIntStubs *itclIntStubsPtr; const ItclStubs *itclStubsPtr = NULL; const ItclIntStubs *itclIntStubsPtr = NULL; /* *---------------------------------------------------------------------- * * Itcl_InitStubs -- * Load the tclOO package, initialize stub table pointer. Do not call * this function directly, use Itcl_InitStubs() macro instead. * * Results: * The actual version of the package that satisfies the request, or * NULL to indicate that an error occurred. * * Side effects: * Sets the stub table pointer. * */ const char * Itcl_InitStubs( Tcl_Interp *interp, const char *version, int exact) { const char *packageName = "itcl"; const char *errMsg = NULL; ClientData clientData = NULL; const ItclStubs *stubsPtr; const ItclIntStubs *intStubsPtr; const char *actualVersion; actualVersion = Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData); stubsPtr = (const ItclStubs *)clientData; if ((actualVersion == NULL) || (clientData == NULL)) { return NULL; } intStubsPtr = stubsPtr->hooks ? stubsPtr->hooks->itclIntStubs : NULL; if (!stubsPtr || !intStubsPtr) { errMsg = "missing stub table pointer"; goto error; } itclStubsPtr = stubsPtr; itclIntStubsPtr = intStubsPtr; return actualVersion; error: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Error loading ", packageName, " package", " (requested version '", version, "', loaded version '", actualVersion, "'): ", errMsg, NULL); return NULL; } itcl4.2.2/generic/itclStubInit.c0000644003604700454610000001475714137636151015212 0ustar dgp771div/* * This file is (mostly) automatically generated from itcl.decls. * It is compiled and linked in with the itcl package proper. */ #include "itclInt.h" MODULE_SCOPE const ItclStubs itclStubs; /* !BEGIN!: Do not edit below this line. */ static const ItclIntStubs itclIntStubs = { TCL_STUB_MAGIC, ITCLINT_STUBS_EPOCH, ITCLINT_STUBS_REVISION, 0, Itcl_IsClassNamespace, /* 0 */ Itcl_IsClass, /* 1 */ Itcl_FindClass, /* 2 */ Itcl_FindObject, /* 3 */ Itcl_IsObject, /* 4 */ Itcl_ObjectIsa, /* 5 */ Itcl_Protection, /* 6 */ Itcl_ProtectionStr, /* 7 */ Itcl_CanAccess, /* 8 */ Itcl_CanAccessFunc, /* 9 */ 0, /* 10 */ Itcl_ParseNamespPath, /* 11 */ Itcl_DecodeScopedCommand, /* 12 */ Itcl_EvalArgs, /* 13 */ Itcl_CreateArgs, /* 14 */ 0, /* 15 */ 0, /* 16 */ Itcl_GetContext, /* 17 */ Itcl_InitHierIter, /* 18 */ Itcl_DeleteHierIter, /* 19 */ Itcl_AdvanceHierIter, /* 20 */ Itcl_FindClassesCmd, /* 21 */ Itcl_FindObjectsCmd, /* 22 */ 0, /* 23 */ Itcl_DelClassCmd, /* 24 */ Itcl_DelObjectCmd, /* 25 */ Itcl_ScopeCmd, /* 26 */ Itcl_CodeCmd, /* 27 */ Itcl_StubCreateCmd, /* 28 */ Itcl_StubExistsCmd, /* 29 */ Itcl_IsStub, /* 30 */ Itcl_CreateClass, /* 31 */ Itcl_DeleteClass, /* 32 */ Itcl_FindClassNamespace, /* 33 */ Itcl_HandleClass, /* 34 */ 0, /* 35 */ 0, /* 36 */ 0, /* 37 */ Itcl_BuildVirtualTables, /* 38 */ Itcl_CreateVariable, /* 39 */ Itcl_DeleteVariable, /* 40 */ Itcl_GetCommonVar, /* 41 */ 0, /* 42 */ 0, /* 43 */ Itcl_CreateObject, /* 44 */ Itcl_DeleteObject, /* 45 */ Itcl_DestructObject, /* 46 */ 0, /* 47 */ Itcl_GetInstanceVar, /* 48 */ 0, /* 49 */ Itcl_BodyCmd, /* 50 */ Itcl_ConfigBodyCmd, /* 51 */ Itcl_CreateMethod, /* 52 */ Itcl_CreateProc, /* 53 */ Itcl_CreateMemberFunc, /* 54 */ Itcl_ChangeMemberFunc, /* 55 */ Itcl_DeleteMemberFunc, /* 56 */ Itcl_CreateMemberCode, /* 57 */ Itcl_DeleteMemberCode, /* 58 */ Itcl_GetMemberCode, /* 59 */ 0, /* 60 */ Itcl_EvalMemberCode, /* 61 */ 0, /* 62 */ 0, /* 63 */ 0, /* 64 */ 0, /* 65 */ 0, /* 66 */ Itcl_GetMemberFuncUsage, /* 67 */ Itcl_ExecMethod, /* 68 */ Itcl_ExecProc, /* 69 */ 0, /* 70 */ Itcl_ConstructBase, /* 71 */ Itcl_InvokeMethodIfExists, /* 72 */ 0, /* 73 */ Itcl_ReportFuncErrors, /* 74 */ Itcl_ParseInit, /* 75 */ Itcl_ClassCmd, /* 76 */ Itcl_ClassInheritCmd, /* 77 */ Itcl_ClassProtectionCmd, /* 78 */ Itcl_ClassConstructorCmd, /* 79 */ Itcl_ClassDestructorCmd, /* 80 */ Itcl_ClassMethodCmd, /* 81 */ Itcl_ClassProcCmd, /* 82 */ Itcl_ClassVariableCmd, /* 83 */ Itcl_ClassCommonCmd, /* 84 */ Itcl_ParseVarResolver, /* 85 */ Itcl_BiInit, /* 86 */ Itcl_InstallBiMethods, /* 87 */ Itcl_BiIsaCmd, /* 88 */ Itcl_BiConfigureCmd, /* 89 */ Itcl_BiCgetCmd, /* 90 */ Itcl_BiChainCmd, /* 91 */ Itcl_BiInfoClassCmd, /* 92 */ Itcl_BiInfoInheritCmd, /* 93 */ Itcl_BiInfoHeritageCmd, /* 94 */ Itcl_BiInfoFunctionCmd, /* 95 */ Itcl_BiInfoVariableCmd, /* 96 */ Itcl_BiInfoBodyCmd, /* 97 */ Itcl_BiInfoArgsCmd, /* 98 */ 0, /* 99 */ Itcl_EnsembleInit, /* 100 */ Itcl_CreateEnsemble, /* 101 */ Itcl_AddEnsemblePart, /* 102 */ Itcl_GetEnsemblePart, /* 103 */ Itcl_IsEnsemble, /* 104 */ Itcl_GetEnsembleUsage, /* 105 */ Itcl_GetEnsembleUsageForObj, /* 106 */ Itcl_EnsembleCmd, /* 107 */ Itcl_EnsPartCmd, /* 108 */ Itcl_EnsembleErrorCmd, /* 109 */ 0, /* 110 */ 0, /* 111 */ 0, /* 112 */ 0, /* 113 */ 0, /* 114 */ Itcl_Assert, /* 115 */ Itcl_IsObjectCmd, /* 116 */ Itcl_IsClassCmd, /* 117 */ 0, /* 118 */ 0, /* 119 */ 0, /* 120 */ 0, /* 121 */ 0, /* 122 */ 0, /* 123 */ 0, /* 124 */ 0, /* 125 */ 0, /* 126 */ 0, /* 127 */ 0, /* 128 */ 0, /* 129 */ 0, /* 130 */ 0, /* 131 */ 0, /* 132 */ 0, /* 133 */ 0, /* 134 */ 0, /* 135 */ 0, /* 136 */ 0, /* 137 */ 0, /* 138 */ 0, /* 139 */ Itcl_FilterAddCmd, /* 140 */ Itcl_FilterDeleteCmd, /* 141 */ Itcl_ForwardAddCmd, /* 142 */ Itcl_ForwardDeleteCmd, /* 143 */ Itcl_MixinAddCmd, /* 144 */ Itcl_MixinDeleteCmd, /* 145 */ 0, /* 146 */ 0, /* 147 */ 0, /* 148 */ 0, /* 149 */ 0, /* 150 */ Itcl_BiInfoUnknownCmd, /* 151 */ Itcl_BiInfoVarsCmd, /* 152 */ Itcl_CanAccess2, /* 153 */ 0, /* 154 */ 0, /* 155 */ 0, /* 156 */ 0, /* 157 */ 0, /* 158 */ 0, /* 159 */ Itcl_SetCallFrameResolver, /* 160 */ ItclEnsembleSubCmd, /* 161 */ Itcl_GetUplevelNamespace, /* 162 */ Itcl_GetCallFrameClientData, /* 163 */ 0, /* 164 */ Itcl_SetCallFrameNamespace, /* 165 */ Itcl_GetCallFrameObjc, /* 166 */ Itcl_GetCallFrameObjv, /* 167 */ Itcl_NWidgetCmd, /* 168 */ Itcl_AddOptionCmd, /* 169 */ Itcl_AddComponentCmd, /* 170 */ Itcl_BiInfoOptionCmd, /* 171 */ Itcl_BiInfoComponentCmd, /* 172 */ Itcl_RenameCommand, /* 173 */ Itcl_PushCallFrame, /* 174 */ Itcl_PopCallFrame, /* 175 */ Itcl_GetUplevelCallFrame, /* 176 */ Itcl_ActivateCallFrame, /* 177 */ ItclSetInstanceVar, /* 178 */ ItclCapitalize, /* 179 */ ItclClassBaseCmd, /* 180 */ ItclCreateComponent, /* 181 */ Itcl_SetContext, /* 182 */ Itcl_UnsetContext, /* 183 */ ItclGetInstanceVar, /* 184 */ }; static const ItclStubHooks itclStubHooks = { &itclIntStubs }; const ItclStubs itclStubs = { TCL_STUB_MAGIC, ITCL_STUBS_EPOCH, ITCL_STUBS_REVISION, &itclStubHooks, 0, /* 0 */ 0, /* 1 */ Itcl_RegisterC, /* 2 */ Itcl_RegisterObjC, /* 3 */ Itcl_FindC, /* 4 */ Itcl_InitStack, /* 5 */ Itcl_DeleteStack, /* 6 */ Itcl_PushStack, /* 7 */ Itcl_PopStack, /* 8 */ Itcl_PeekStack, /* 9 */ Itcl_GetStackValue, /* 10 */ Itcl_InitList, /* 11 */ Itcl_DeleteList, /* 12 */ Itcl_CreateListElem, /* 13 */ Itcl_DeleteListElem, /* 14 */ Itcl_InsertList, /* 15 */ Itcl_InsertListElem, /* 16 */ Itcl_AppendList, /* 17 */ Itcl_AppendListElem, /* 18 */ Itcl_SetListValue, /* 19 */ Itcl_EventuallyFree, /* 20 */ Itcl_PreserveData, /* 21 */ Itcl_ReleaseData, /* 22 */ Itcl_SaveInterpState, /* 23 */ Itcl_RestoreInterpState, /* 24 */ Itcl_DiscardInterpState, /* 25 */ Itcl_Alloc, /* 26 */ Itcl_Free, /* 27 */ }; /* !END!: Do not edit above this line. */ itcl4.2.2/generic/itclResolve.c0000644003604700454610000005551714137636151015067 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * These procedures handle command and variable resolution * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" /* * This structure is a subclass of Tcl_ResolvedVarInfo that contains the * ItclVarLookup info needed at runtime. */ typedef struct ItclResolvedVarInfo { Tcl_ResolvedVarInfo vinfo; /* This must be the first element. */ ItclVarLookup *vlookup; /* Pointer to lookup info. */ } ItclResolvedVarInfo; static Tcl_Var ItclClassRuntimeVarResolver( Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr); /* * ------------------------------------------------------------------------ * Itcl_ClassCmdResolver() * * Used by the class namespaces to handle name resolution for all * commands. This procedure looks for references to class methods * and procs, and returns TCL_OK along with the appropriate Tcl * command in the rPtr argument. If a particular command is private, * this procedure returns TCL_ERROR and access to the command is * denied. If a command is not recognized, this procedure returns * TCL_CONTINUE, and lookup continues via the normal Tcl name * resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassCmdResolver( Tcl_Interp *interp, /* current interpreter */ const char* name, /* name of the command being accessed */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ int flags, /* TCL_LEAVE_ERR_MSG => leave error messages * in interp if anything goes wrong */ Tcl_Command *rPtr) /* returns: resolved command */ { Tcl_HashEntry *hPtr; Tcl_Obj *objPtr; Tcl_Obj *namePtr; ItclClass *iclsPtr; ItclObjectInfo *infoPtr; ItclMemberFunc *imPtr; int inOptionHandling; int isCmdDeleted; if ((name[0] == 't') && (strcmp(name, "this") == 0)) { return TCL_CONTINUE; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { return TCL_CONTINUE; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * If the command is a member function */ imPtr = NULL; objPtr = Tcl_NewStringObj(name, -1); hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); if (hPtr == NULL) { ItclCmdLookup *clookup; if ((iclsPtr->flags & ITCL_ECLASS)) { namePtr = Tcl_NewStringObj(name, -1); hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)namePtr); if (hPtr != NULL) { objPtr = Tcl_NewStringObj("unknown", -1); hPtr = Tcl_FindHashEntry(&iclsPtr->resolveCmds, (char *)objPtr); Tcl_DecrRefCount(objPtr); } Tcl_DecrRefCount(namePtr); } if (hPtr == NULL) { return TCL_CONTINUE; } clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr = clookup->imPtr; } else { ItclCmdLookup *clookup; clookup = (ItclCmdLookup *)Tcl_GetHashValue(hPtr); imPtr = clookup->imPtr; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { /* FIXME check if called from an (instance) method (not from a typemethod) and only then error */ int isOk = 0; if (strcmp(name, "info") == 0) { isOk = 1; } if (strcmp(name, "mytypemethod") == 0) { isOk = 1; } if (strcmp(name, "myproc") == 0) { isOk = 1; } if (strcmp(name, "mymethod") == 0) { isOk = 1; } if (strcmp(name, "mytypevar") == 0) { isOk = 1; } if (strcmp(name, "myvar") == 0) { isOk = 1; } if (strcmp(name, "itcl_hull") == 0) { isOk = 1; } if (strcmp(name, "callinstance") == 0) { isOk = 1; } if (strcmp(name, "getinstancevar") == 0) { isOk = 1; } if (strcmp(name, "installcomponent") == 0) { isOk = 1; } if (! isOk) { if ((imPtr->flags & ITCL_TYPE_METHOD) != 0) { Tcl_AppendResult(interp, "invalid command name \"", name, "\"", NULL); return TCL_ERROR; } inOptionHandling = imPtr->iclsPtr->infoPtr->inOptionHandling; if (((imPtr->flags & ITCL_COMMON) == 0) && !inOptionHandling) { /* a method cannot be called directly in ITCL_TYPE * so look, if there is a corresponding proc in the * namespace one level up (i.e. for example ::). If yes * use that. */ Tcl_Namespace *nsPtr2; Tcl_Command cmdPtr; nsPtr2 = Itcl_GetUplevelNamespace(interp, 1); cmdPtr = NULL; if (nsPtr != nsPtr2) { cmdPtr = Tcl_FindCommand(interp, name, nsPtr2, 0); } if (cmdPtr != NULL) { *rPtr = cmdPtr; return TCL_OK; } Tcl_AppendResult(interp, "invalid command name \"", name, "\"", NULL); return TCL_ERROR; } } } /* * Looks like we found an accessible member function. * * TRICKY NOTE: Check to make sure that the command handle * is still valid. If someone has deleted or renamed the * command, it may not be. This is just the time to catch * it--as it is being resolved again by the compiler. */ /* * The following #if is needed so itcl can be compiled with * all versions of Tcl. The integer "deleted" was renamed to * "flags" in tcl8.4a2. This #if is also found in itcl_ensemble.c . * We're using a runtime check with itclCompatFlags to adjust for * the behavior of this change, too. * */ /* FIXME !!! */ isCmdDeleted = 0; /* isCmdDeleted = (!imPtr->accessCmd || imPtr->accessCmd->flags); */ if (isCmdDeleted) { imPtr->accessCmd = NULL; if ((flags & TCL_LEAVE_ERR_MSG) != 0) { Tcl_AppendResult(interp, "can't access \"", name, "\": deleted or redefined\n", "(use the \"body\" command to redefine methods/procs)", NULL); } return TCL_ERROR; /* disallow access! */ } *rPtr = imPtr->accessCmd; return TCL_OK; } /* #define VAR_DEBUG */ /* * ------------------------------------------------------------------------ * Itcl_ClassVarResolver() * * Used by the class namespaces to handle name resolution for runtime * variable accesses. This procedure looks for references to both * common variables and instance variables at runtime. It is used as * a second line of defense, to handle references that could not be * resolved as compiled locals. * * If a variable is found, this procedure returns TCL_OK along with * the appropriate Tcl variable in the rPtr argument. If a particular * variable is private, this procedure returns TCL_ERROR and access * to the variable is denied. If a variable is not recognized, this * procedure returns TCL_CONTINUE, and lookup continues via the normal * Tcl name resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassVarResolver( Tcl_Interp *interp, /* current interpreter */ const char* name, /* name of the variable being accessed */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ int flags, /* TCL_LEAVE_ERR_MSG => leave error messages * in interp if anything goes wrong */ Tcl_Var *rPtr) /* returns: resolved variable */ { ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclObject *contextIoPtr; Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; contextIoPtr = NULL; /* * If this is a global variable, handle it in the usual * Tcl manner. */ if (flags & TCL_GLOBAL_ONLY) { return TCL_CONTINUE; } /* * See if this is a formal parameter in the current proc scope. * If so, that variable has precedence. */ if ((strstr(name,"::") == NULL) && Itcl_IsCallFrameArgument(interp, name)) { return TCL_CONTINUE; } infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { return TCL_CONTINUE; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * See if the variable is a known data member and accessible. */ hPtr = ItclResolveVarEntry(iclsPtr, name); if (hPtr == NULL) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (!vlookup->accessible) { return TCL_CONTINUE; } /* * If this is a common data member, then its variable * is easy to find. Return it directly. */ if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); return TCL_OK; } } /* * If this is an instance variable, then we have to * find the object context, */ if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr) || (contextIoPtr == NULL)) { return TCL_CONTINUE; } /* Check that the object hasn't already been destroyed. */ hPtr = Tcl_FindHashEntry(&infoPtr->objects, (char *)contextIoPtr); if (hPtr == NULL) { return TCL_CONTINUE; } if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } } } hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)vlookup->ivPtr); if (hPtr == NULL) { return TCL_CONTINUE; } if (strcmp(name, "this") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { /* deletion of class is running */ Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); } else { Tcl_DStringAppend(&buffer, vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::this", 6); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { *rPtr = varPtr; return TCL_OK; } } if (strcmp(name, "itcl_options") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); Tcl_DStringAppend(&buffer, "::itcl_options", -1); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); if (varPtr != NULL) { *rPtr = varPtr; return TCL_OK; } } if (strcmp(name, "itcl_option_components") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); Tcl_DStringAppend(&buffer, "::itcl_option_components", -1); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); if (varPtr != NULL) { *rPtr = varPtr; return TCL_OK; } } if (hPtr != NULL) { *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); return TCL_OK; } return TCL_CONTINUE; } /* * ------------------------------------------------------------------------ * Itcl_ClassCompiledVarResolver() * * Used by the class namespaces to handle name resolution for compile * time variable accesses. This procedure looks for references to * both common variables and instance variables at compile time. If * the variables are found, they are characterized in a generic way * by their ItclVarLookup record. At runtime, Tcl constructs the * compiled local variables by calling ItclClassRuntimeVarResolver. * * If a variable is found, this procedure returns TCL_OK along with * information about the variable in the rPtr argument. If a particular * variable is private, this procedure returns TCL_ERROR and access * to the variable is denied. If a variable is not recognized, this * procedure returns TCL_CONTINUE, and lookup continues via the normal * Tcl name resolution rules. * ------------------------------------------------------------------------ */ int Itcl_ClassCompiledVarResolver( Tcl_Interp *interp, /* current interpreter */ const char* name, /* name of the variable being accessed */ int length, /* number of characters in name */ Tcl_Namespace *nsPtr, /* namespace performing the resolution */ Tcl_ResolvedVarInfo **rPtr) /* returns: info that makes it possible to * resolve the variable at runtime */ { ItclClass *iclsPtr; ItclObjectInfo *infoPtr; Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; char *buffer; char storage[64]; infoPtr = (ItclObjectInfo *)Tcl_GetAssocData(interp, ITCL_INTERP_DATA, NULL); hPtr = Tcl_FindHashEntry(&infoPtr->namespaceClasses, (char *)nsPtr); if (hPtr == NULL) { return TCL_CONTINUE; } iclsPtr = (ItclClass *)Tcl_GetHashValue(hPtr); /* * Copy the name to local storage so we can NULL terminate it. * If the name is long, allocate extra space for it. */ if ((unsigned int)length < sizeof(storage)) { buffer = storage; } else { buffer = (char*)ckalloc((unsigned)(length+1)); } memcpy((void*)buffer, (void*)name, (size_t)length); buffer[length] = '\0'; hPtr = ItclResolveVarEntry(iclsPtr, buffer); if (buffer != storage) { ckfree(buffer); } /* * If the name is not found, or if it is inaccessible, * continue on with the normal Tcl name resolution rules. */ if (hPtr == NULL) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if (!vlookup->accessible) { return TCL_CONTINUE; } /* * Return the ItclVarLookup record. At runtime, Tcl will * call ItclClassRuntimeVarResolver with this record, to * plug in the appropriate variable for the current object * context. */ (*rPtr) = (Tcl_ResolvedVarInfo *) ckalloc(sizeof(ItclResolvedVarInfo)); (*rPtr)->fetchProc = ItclClassRuntimeVarResolver; (*rPtr)->deleteProc = NULL; ((ItclResolvedVarInfo*)(*rPtr))->vlookup = vlookup; return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclClassRuntimeVarResolver() * * Invoked when Tcl sets up the call frame for an [incr Tcl] method/proc * at runtime. Resolves data members identified earlier by * Itcl_ClassCompiledVarResolver. Returns the Tcl_Var representation * for the data member. * ------------------------------------------------------------------------ */ static Tcl_Var ItclClassRuntimeVarResolver( Tcl_Interp *interp, /* current interpreter */ Tcl_ResolvedVarInfo *resVarInfo) /* contains ItclVarLookup rep * for variable */ { ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; ItclClass *iclsPtr; ItclObject *contextIoPtr; Tcl_HashEntry *hPtr; /* * If this is a common data member, then the associated * variable is known directly. */ if ((vlookup->ivPtr->flags & ITCL_COMMON) != 0) { hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (hPtr != NULL) { return (Tcl_Var)Tcl_GetHashValue(hPtr); } } /* * Otherwise, get the current object context and find the * variable in its data table. * * TRICKY NOTE: Get the index for this variable using the * virtual table for the MOST-SPECIFIC class. */ if (TCL_ERROR == Itcl_GetContext(interp, &iclsPtr, &contextIoPtr) || (contextIoPtr == NULL)) { return NULL; } if (contextIoPtr->iclsPtr != vlookup->ivPtr->iclsPtr) { if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { /* only for the this variable we need the one of the * contextIoPtr class */ hPtr = ItclResolveVarEntry(contextIoPtr->iclsPtr, Tcl_GetString(vlookup->ivPtr->namePtr)); if (hPtr != NULL) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); } } } hPtr = Tcl_FindHashEntry(&contextIoPtr->objectVariables, (char *)vlookup->ivPtr); if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "this") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); if (vlookup->ivPtr->iclsPtr->nsPtr == NULL) { Tcl_DStringAppend(&buffer, Tcl_GetCurrentNamespace(interp)->fullName, -1); } else { Tcl_DStringAppend(&buffer, vlookup->ivPtr->iclsPtr->nsPtr->fullName, -1); } Tcl_DStringAppend(&buffer, "::this", 6); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); if (varPtr != NULL) { return varPtr; } } if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "itcl_options") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); Tcl_DStringAppend(&buffer, "::itcl_options", -1); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); if (varPtr != NULL) { return varPtr; } } if (strcmp(Tcl_GetString(vlookup->ivPtr->namePtr), "itcl_option_components") == 0) { Tcl_Var varPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(contextIoPtr->oPtr)->fullName), -1); Tcl_DStringAppend(&buffer, "::itcl_option_components", -1); varPtr = Itcl_FindNamespaceVar(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); if (varPtr != NULL) { return varPtr; } } if (hPtr != NULL) { return (Tcl_Var)Tcl_GetHashValue(hPtr); } return NULL; } /* * ------------------------------------------------------------------------ * Itcl_ParseVarResolver() * * Used by the "parser" namespace to resolve variable accesses to * common variables. The runtime resolver procedure is consulted * whenever a variable is accessed within the namespace. It can * deny access to certain variables, or perform special lookups itself. * * This procedure allows access only to "common" class variables that * have been declared within the class or inherited from another class. * A "set" command can be used to initialized common data members within * the body of the class definition itself: * * itcl::class Foo { * common colors * set colors(red) #ff0000 * set colors(green) #00ff00 * set colors(blue) #0000ff * ... * } * * itcl::class Bar { * inherit Foo * set colors(gray) #a0a0a0 * set colors(white) #ffffff * * common numbers * set numbers(0) zero * set numbers(1) one * } * * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ParseVarResolver( Tcl_Interp *interp, /* current interpreter */ const char* name, /* name of the variable being accessed */ Tcl_Namespace *contextNs, /* namespace context */ int flags, /* TCL_GLOBAL_ONLY => global variable * TCL_NAMESPACE_ONLY => namespace variable */ Tcl_Var* rPtr) /* returns: Tcl_Var for desired variable */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)contextNs->clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_HashEntry *hPtr; ItclVarLookup *vlookup; (void)flags; /* * See if the requested variable is a recognized "common" member. * If it is, make sure that access is allowed. */ hPtr = ItclResolveVarEntry(iclsPtr, name); if (!hPtr) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(hPtr); if ((vlookup->ivPtr->flags & ITCL_COMMON) == 0) { return TCL_CONTINUE; } if (!vlookup->accessible) { Tcl_AppendResult(interp, "can't access \"", name, "\": ", Itcl_ProtectionStr(vlookup->ivPtr->protection), " variable", NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&vlookup->ivPtr->iclsPtr->classCommons, (char *)vlookup->ivPtr); if (!hPtr) { return TCL_CONTINUE; } *rPtr = (Tcl_Var)Tcl_GetHashValue(hPtr); return TCL_OK; } int ItclSetParserResolver( Tcl_Namespace *nsPtr) { Itcl_SetNamespaceResolvers(nsPtr, NULL, Itcl_ParseVarResolver, NULL); return TCL_OK; } itcl4.2.2/generic/itclParse.c0000644003604700454610000041174714137636151014523 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tcl] * DESCRIPTION: Object-Oriented Extensions to Tcl * * [incr Tcl] provides object-oriented extensions to Tcl, much as * C++ provides object-oriented extensions to C. It provides a means * of encapsulating related procedures together with their shared data * in a local namespace that is hidden from the outside world. It * promotes code re-use through inheritance. More than anything else, * it encourages better organization of Tcl applications through the * object-oriented paradigm, leading to code that is easier to * understand and maintain. * * Procedures in this file support the new syntax for [incr Tcl] * class definitions: * * itcl_class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ?...? * protected ?...? * private ?...? * } * * ======================================================================== * AUTHOR: Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * http://www.tcltk.com/itcl * * overhauled version author: Arnulf Wiedemann * ======================================================================== * Copyright (c) 1993-1998 Lucent Technologies, Inc. * ------------------------------------------------------------------------ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "itclInt.h" static const char initWidgetScript[] = "namespace eval ::itcl {\n" " proc _find_widget_init {} {\n" " global env tcl_library\n" " variable library\n" " variable patchLevel\n" " rename _find_widget_init {}\n" " if {[info exists library]} {\n" " lappend dirs $library\n" " } else {\n" " set dirs {}\n" " if {[info exists env(ITCL_LIBRARY)]} {\n" " lappend dirs $env(ITCL_LIBRARY)\n" " }\n" " lappend dirs [file join [file dirname $tcl_library] itcl$patchLevel]\n" " set bindir [file dirname [info nameofexecutable]]\n" " lappend dirs [file join . library]\n" " lappend dirs [file join $bindir .. lib itcl$patchLevel]\n" " lappend dirs [file join $bindir .. library]\n" " lappend dirs [file join $bindir .. .. library]\n" " lappend dirs [file join $bindir .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. .. itcl library]\n" " lappend dirs [file join $bindir .. .. itcl-ng itcl library]\n" " # On MacOSX, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"] &&" " [string equal $::tcl_platform(os) \"Darwin\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " # On *nix, check the directories in the tcl_pkgPath\n" " if {[string equal $::tcl_platform(platform) \"unix\"]} {\n" " foreach d $::tcl_pkgPath {\n" " lappend dirs $d\n" " lappend dirs [file join $d itcl$patchLevel]\n" " }\n" " }\n" " }\n" " foreach i $dirs {\n" " set library $i\n" " set itclfile [file join $i itclWidget.tcl]\n" " if {![catch {uplevel #0 [list source $itclfile]} emsg]} {\n" " return\n" " }\n" " }\n" " set msg \"Can't find a usable itclWidget.tcl in the following directories:\n\"\n" " append msg \" $dirs\n\"\n" " append msg \"Last error:\n\"\n" " append msg \" $emsg\n\"\n" " append msg \"This probably means that Itcl/Tcl weren't installed properly.\n\"\n" " append msg \"If you know where the Itcl library directory was installed,\n\"\n" " append msg \"you can set the environment variable ITCL_LIBRARY to point\n\"\n" " append msg \"to the library directory.\n\"\n" " error $msg\n" " }\n" " _find_widget_init\n" "}"; /* * Info needed for public/protected/private commands: */ typedef struct ProtectionCmdInfo { int pLevel; /* protection level */ ItclObjectInfo *infoPtr; /* info regarding all known objects */ } ProtectionCmdInfo; /* * FORWARD DECLARATIONS */ static Tcl_CmdDeleteProc ItclFreeParserCommandData; static void ItclDelObjectInfo(char* cdata); static int ItclInitClassCommon(Tcl_Interp *interp, ItclClass *iclsPtr, ItclVariable *ivPtr, const char *initStr); static Tcl_ObjCmdProc Itcl_ClassTypeVariableCmd; static Tcl_ObjCmdProc Itcl_ClassTypeMethodCmd; static Tcl_ObjCmdProc Itcl_ClassFilterCmd; static Tcl_ObjCmdProc Itcl_ClassMixinCmd; static Tcl_ObjCmdProc Itcl_WidgetCmd; static Tcl_ObjCmdProc Itcl_WidgetAdaptorCmd; static Tcl_ObjCmdProc Itcl_ClassComponentCmd; static Tcl_ObjCmdProc Itcl_ClassTypeComponentCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateMethodCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateOptionCmd; static Tcl_ObjCmdProc Itcl_ClassDelegateTypeMethodCmd; static Tcl_ObjCmdProc Itcl_ClassForwardCmd; static Tcl_ObjCmdProc Itcl_ClassMethodVariableCmd; static Tcl_ObjCmdProc Itcl_ClassTypeConstructorCmd; static Tcl_ObjCmdProc ItclGenericClassCmd; static const struct { const char *name; Tcl_ObjCmdProc *objProc; } parseCmds[] = { {"common", Itcl_ClassCommonCmd}, {"component", Itcl_ClassComponentCmd}, {"constructor", Itcl_ClassConstructorCmd}, {"destructor", Itcl_ClassDestructorCmd}, {"filter", Itcl_ClassFilterCmd}, {"forward", Itcl_ClassForwardCmd}, {"handleClass", Itcl_HandleClass}, {"hulltype", Itcl_ClassHullTypeCmd}, {"inherit", Itcl_ClassInheritCmd}, {"method", Itcl_ClassMethodCmd}, {"methodvariable", Itcl_ClassMethodVariableCmd}, {"mixin", Itcl_ClassMixinCmd}, {"option", Itcl_ClassOptionCmd}, {"proc", Itcl_ClassProcCmd}, {"typecomponent", Itcl_ClassTypeComponentCmd }, {"typeconstructor", Itcl_ClassTypeConstructorCmd}, {"typemethod", Itcl_ClassTypeMethodCmd}, {"typevariable", Itcl_ClassTypeVariableCmd}, {"variable", Itcl_ClassVariableCmd}, {"widgetclass", Itcl_ClassWidgetClassCmd}, {NULL, NULL} }; static const struct { const char *name; Tcl_ObjCmdProc *objProc; int protection; } protectionCmds[] = { {"private", Itcl_ClassProtectionCmd, ITCL_PRIVATE}, {"protected", Itcl_ClassProtectionCmd, ITCL_PROTECTED}, {"public", Itcl_ClassProtectionCmd, ITCL_PUBLIC}, {NULL, NULL, 0} }; /* * ------------------------------------------------------------------------ * Itcl_ParseInit() * * Invoked by Itcl_Init() whenever a new interpeter is created to add * [incr Tcl] facilities. Adds the commands needed to parse class * definitions. * ------------------------------------------------------------------------ */ int Itcl_ParseInit( Tcl_Interp *interp, /* interpreter to be updated */ ItclObjectInfo *infoPtr) /* info regarding all known objects and classes */ { Tcl_Namespace *parserNs; ProtectionCmdInfo *pInfoPtr; Tcl_DString buffer; int i; /* * Create the "itcl::parser" namespace used to parse class * definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", infoPtr, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (cannot initialize itcl parser)", NULL); return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add commands for parsing class definitions. */ Tcl_DStringInit(&buffer); for (i=0 ; parseCmds[i].name ; i++) { Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); Tcl_DStringAppend(&buffer, parseCmds[i].name, -1); Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), parseCmds[i].objProc, infoPtr, NULL); Tcl_DStringFree(&buffer); } for (i=0 ; protectionCmds[i].name ; i++) { Tcl_DStringAppend(&buffer, "::itcl::parser::", 16); Tcl_DStringAppend(&buffer, protectionCmds[i].name, -1); pInfoPtr = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfoPtr->pLevel = protectionCmds[i].protection; pInfoPtr->infoPtr = infoPtr; Tcl_CreateObjCommand(interp, Tcl_DStringValue(&buffer), protectionCmds[i].objProc, pInfoPtr, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); Tcl_DStringFree(&buffer); } /* * Set the runtime variable resolver for the parser namespace, * to control access to "common" data members while parsing * the class definition. */ if (infoPtr->useOldResolvers) { ItclSetParserResolver(parserNs); } /* * Install the "class" command for defining new classes. */ Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::body", Itcl_BodyCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::configbody", Itcl_ConfigBodyCmd, NULL, NULL); Itcl_EventuallyFree(infoPtr, (Tcl_FreeProc *) ItclDelObjectInfo); /* * Create the "itcl::find" command for high-level queries. */ if (Itcl_CreateEnsemble(interp, "::itcl::find") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::find", "classes", "?pattern?", Itcl_FindClassesCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::find", "objects", "?-class className? ?-isa className? ?pattern?", Itcl_FindObjectsCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Create the "itcl::delete" command to delete objects * and classes. */ if (Itcl_CreateEnsemble(interp, "::itcl::delete") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "class", "name ?name...?", Itcl_DelClassCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "object", "name ?name...?", Itcl_DelObjectCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::delete", "ensemble", "name ?name...?", Itcl_EnsembleDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Create the "itcl::is" command to test object * and classes existence. */ if (Itcl_CreateEnsemble(interp, "::itcl::is") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::is", "class", "name", Itcl_IsClassCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::is", "object", "?-class classname? name", Itcl_IsObjectCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add "code" and "scope" commands for handling scoped values. */ Tcl_CreateObjCommand(interp, "::itcl::code", Itcl_CodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::itcl::scope", Itcl_ScopeCmd, NULL, NULL); /* * Add the "filter" commands (add/delete) */ if (Itcl_CreateEnsemble(interp, "::itcl::filter") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "add", "objectOrClass filter ? ... ?", Itcl_FilterAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::filter", "delete", "objectOrClass filter ? ... ?", Itcl_FilterDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add the "forward" commands (add/delete) */ if (Itcl_CreateEnsemble(interp, "::itcl::forward") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "add", "objectOrClass srcCommand targetCommand ? options ... ?", Itcl_ForwardAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::forward", "delete", "objectOrClass targetCommand ? ... ?", Itcl_ForwardDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add the "mixin" (add/delete) commands. */ if (Itcl_CreateEnsemble(interp, "::itcl::mixin") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "add", "objectOrClass class ? class ... ?", Itcl_MixinAddCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::mixin", "delete", "objectOrClass class ? class ... ?", Itcl_MixinDeleteCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); /* * Add commands for handling import stubs at the Tcl level. */ if (Itcl_CreateEnsemble(interp, "::itcl::import::stub") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "create", "name", Itcl_StubCreateCmd, NULL, NULL) != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::import::stub", "exists", "name", Itcl_StubExistsCmd, NULL, NULL) != TCL_OK) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "::itcl::type", Itcl_TypeClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widget", Itcl_WidgetCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::widgetadaptor", Itcl_WidgetAdaptorCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::nwidget", Itcl_NWidgetCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addoption", Itcl_AddOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addobjectoption", Itcl_AddObjectOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedoption", Itcl_AddDelegatedOptionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::adddelegatedmethod", Itcl_AddDelegatedFunctionCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::addcomponent", Itcl_AddComponentCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::setcomponent", Itcl_SetComponentCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, "::itcl::extendedclass", Itcl_ExtendedClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); Tcl_CreateObjCommand(interp, ITCL_COMMANDS_NAMESPACE "::genericclass", ItclGenericClassCmd, infoPtr, Itcl_ReleaseData); Itcl_PreserveData(infoPtr); /* * Add the "delegate" (method/option) commands. */ if (Itcl_CreateEnsemble(interp, "::itcl::parser::delegate") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "method", "name to targetName as scipt using script", Itcl_ClassDelegateMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "typemethod", "name to targetName as scipt using script", Itcl_ClassDelegateTypeMethodCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); if (Itcl_AddEnsemblePart(interp, "::itcl::parser::delegate", "option", "option to targetOption as script", Itcl_ClassDelegateOptionCmd, infoPtr, Itcl_ReleaseData) != TCL_OK) { return TCL_ERROR; } Itcl_PreserveData(infoPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::class" command to * specify a class definition. Handles the following syntax: * * itcl::class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ... * protected ... * private ... * } * * ------------------------------------------------------------------------ */ static int ItclGenericClassCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclComponent *icPtr; const char *typeStr; int result; ItclShowArgs(1, "ItclGenericClassCmd", objc-1, objv); if (objc != 4) { Tcl_AppendResult(interp, "usage: genericclass ", "", NULL); return TCL_ERROR; } infoPtr = (ItclObjectInfo *)clientData; typeStr = Tcl_GetString(objv[1]); hPtr = Tcl_FindHashEntry(&infoPtr->classTypes, (char *)objv[1]); if (hPtr == NULL) { Tcl_AppendResult(interp, "genericclass bad classtype \"", typeStr, "\"", NULL); return TCL_ERROR; } result = ItclClassBaseCmd(clientData, interp, PTR2INT(Tcl_GetHashValue(hPtr)), objc - 1, objv + 1, &iclsPtr); if (result != TCL_OK) { return result; } if (PTR2INT(Tcl_GetHashValue(hPtr)) == ITCL_WIDGETADAPTOR) { /* create the itcl_hull variable */ namePtr = Tcl_NewStringObj("itcl_hull", -1); if (ItclCreateComponent(interp, iclsPtr, namePtr, ITCL_COMMON, &icPtr) != TCL_OK) { return TCL_ERROR; } iclsPtr->numVariables++; } Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), NULL); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCmd() * * Invoked by Tcl whenever the user issues an "itcl::class" command to * specify a class definition. Handles the following syntax: * * itcl::class { * inherit ... * * constructor {} ?{}? {} * destructor {} * * method {} {} * proc {} {} * variable ?? ?? * common ?? * * public ... * protected ... * private ... * } * * ------------------------------------------------------------------------ */ int Itcl_ClassCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { return ItclClassBaseCmd(clientData, interp, ITCL_CLASS, objc, objv, NULL); } /* * ------------------------------------------------------------------------ * ItclClassBaseCmd() * * ------------------------------------------------------------------------ */ static Tcl_MethodCallProc ObjCallProc; static Tcl_MethodCallProc ArgCallProc; static Tcl_CloneProc CloneProc; static const Tcl_MethodType itclObjMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl objv method", ObjCallProc, Itcl_ReleaseData, CloneProc }; static const Tcl_MethodType itclArgMethodType = { TCL_OO_METHOD_VERSION_CURRENT, "itcl argv method", ArgCallProc, Itcl_ReleaseData, CloneProc }; static int CloneProc( Tcl_Interp *dummy, ClientData original, ClientData *copyPtr) { (void)dummy; Itcl_PreserveData((ItclMemberFunc *)original); *copyPtr = original; return TCL_OK; } static int CallAfterCallMethod( ClientData data[], Tcl_Interp *interp, int result) { ClientData clientData = data[0]; Tcl_ObjectContext context = (Tcl_ObjectContext)data[1]; return ItclAfterCallMethod(clientData, interp, context, NULL, result); } static int ObjCallProc( ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { ItclMemberFunc *imPtr = (ItclMemberFunc *)clientData; if (TCL_ERROR == ItclCheckCallMethod(clientData, interp, context, NULL, NULL)) { return TCL_ERROR; } Tcl_NRAddCallback(interp, CallAfterCallMethod, clientData, context, NULL, NULL); if ((imPtr->flags & ITCL_COMMON) == 0) { return Itcl_ExecMethod(clientData, interp, objc-1, objv+1); } else { return Itcl_ExecProc(clientData, interp, objc-1, objv+1); } } static int ArgCallProc( ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { (void)clientData; (void)interp; (void)context; (void)objc; (void)objv; return TCL_ERROR; } int ItclClassBaseCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int flags, /* flags: ITCL_CLASS, ITCL_TYPE, * ITCL_WIDGET or ITCL_WIDGETADAPTOR */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclClass **iclsPtrPtr) /* for returning iclsPtr */ { Tcl_Obj *argumentPtr; Tcl_Obj *bodyPtr; FOREACH_HASH_DECLS; Tcl_HashEntry *hPtr2; Tcl_Namespace *parserNs, *ooNs; Tcl_CallFrame frame; ItclClass *iclsPtr; ItclVariable *ivPtr; ItclObjectInfo* infoPtr; char *className; int isNewEntry; int result; int noCleanup; ItclMemberFunc *imPtr; infoPtr = (ItclObjectInfo*)clientData; if (iclsPtrPtr != NULL) { *iclsPtrPtr = NULL; } if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); return TCL_ERROR; } ItclShowArgs(1, "ItclClassBaseCmd", objc, objv); className = Tcl_GetString(objv[1]); noCleanup = 0; /* * Find the namespace to use as a parser for the class definition. * If for some reason it is destroyed, bail out here. */ parserNs = Tcl_FindNamespace(interp, "::itcl::parser", NULL, TCL_LEAVE_ERR_MSG); if (parserNs == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while parsing class definition for \"%s\")", className)); return TCL_ERROR; } /* * Try to create the specified class and its namespace. */ /* need the workaround with infoPtr->currClassFlags to keep the stubs * call interface compatible! */ infoPtr->currClassFlags = flags; if (Itcl_CreateClass(interp, className, infoPtr, &iclsPtr) != TCL_OK) { infoPtr->currClassFlags = 0; return TCL_ERROR; } infoPtr->currClassFlags = 0; iclsPtr->flags = flags; /* * Import the built-in commands from the itcl::builtin namespace. * Do this before parsing the class definition, so methods/procs * can override the built-in commands. */ result = Tcl_Import(interp, iclsPtr->nsPtr, "::itcl::builtin::*", /* allowOverwrite */ 1); ooNs = Tcl_GetObjectNamespace(iclsPtr->oPtr); if ( result == TCL_OK && ooNs != iclsPtr->nsPtr) { result = Tcl_Import(interp, ooNs, "::itcl::builtin::*", 1); } if (result != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (while installing built-in commands for class \"%s\")", className)); goto errorReturn; } /* * Push this class onto the class definition stack so that it * becomes the current context for all commands in the parser. * Activate the parser and evaluate the class definition. */ Itcl_PushStack(iclsPtr, &infoPtr->clsStack); result = Itcl_PushCallFrame(interp, &frame, parserNs, /* isProcCallFrame */ 0); Itcl_SetCallFrameResolver(interp, iclsPtr->resolvePtr); if (result == TCL_OK) { result = Tcl_EvalObjEx(interp, objv[2], 0); Itcl_PopCallFrame(interp); } Itcl_PopStack(&infoPtr->clsStack); noCleanup = 0; if (result != TCL_OK) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1); Tcl_Obj *stackTrace = NULL; Tcl_IncrRefCount(key); Tcl_DictObjGet(NULL, options, key, &stackTrace); Tcl_DecrRefCount(key); if (stackTrace == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n error while parsing class \"%s\" body %s", className, Tcl_GetString(objv[2]))); noCleanup = 1; } else { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (class \"%s\" body line %s)", className, Tcl_GetString(stackTrace))); } Tcl_DecrRefCount(options); result = TCL_ERROR; goto errorReturn; } if (Itcl_FirstListElem(&iclsPtr->bases) == NULL) { /* No [inherit]. Use default inheritance root. */ Tcl_Obj *cmdPtr = Tcl_NewListObj(4, NULL); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("::oo::define", -1)); Tcl_ListObjAppendElement(NULL, cmdPtr, iclsPtr->fullNamePtr); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("superclass", -1)); Tcl_ListObjAppendElement(NULL, cmdPtr, Tcl_NewStringObj("::itcl::Root", -1)); Tcl_IncrRefCount(cmdPtr); result = Tcl_EvalObjEx(interp, cmdPtr, 0); Tcl_DecrRefCount(cmdPtr); if (result == TCL_ERROR) { goto errorReturn; } } /* * At this point, parsing of the class definition has succeeded. * Add built-in methods such as "configure" and "cget"--as long * as they don't conflict with those defined in the class. */ if (Itcl_InstallBiMethods(interp, iclsPtr) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } /* * Build the name resolution tables for all data members. */ Itcl_BuildVirtualTables(iclsPtr); /* make the methods and procs known to TclOO */ FOREACH_HASH_VALUE(imPtr, &iclsPtr->functions) { ClientData pmPtr; argumentPtr = imPtr->codePtr->argumentPtr; bodyPtr = imPtr->codePtr->bodyPtr; if (imPtr->codePtr->flags & ITCL_IMPLEMENT_OBJCMD) { /* Implementation of this member is coded in C expecting Tcl_Obj */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); Itcl_PreserveData(imPtr); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { imPtr->tmPtr = Tcl_NewInstanceMethod(interp, iclsPtr->oPtr, imPtr->namePtr, 1, &itclObjMethodType, imPtr); Itcl_PreserveData(imPtr); } } else if (imPtr->codePtr->flags & ITCL_IMPLEMENT_ARGCMD) { /* Implementation of this member is coded in C expecting (char *) */ imPtr->tmPtr = Tcl_NewMethod(interp, iclsPtr->clsPtr, imPtr->namePtr, 1, &itclArgMethodType, imPtr); Itcl_PreserveData(imPtr); } else { if (imPtr->codePtr->flags & ITCL_BUILTIN) { int isDone; isDone = 0; if (imPtr->builtinArgumentPtr == NULL) { /* FIXME next lines are possibly a MEMORY leak not really sure!! */ argumentPtr = Tcl_NewStringObj("args", -1); imPtr->builtinArgumentPtr = argumentPtr; Tcl_IncrRefCount(imPtr->builtinArgumentPtr); } else { argumentPtr = imPtr->builtinArgumentPtr; } bodyPtr = Tcl_NewStringObj("return [", -1); if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-cget") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::cget", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-configure") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::configure", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-isa") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::isa", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-createhull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::createhull", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-keepcomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepcomponentoption", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-ignorecomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignorercomponentoption", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-renamecomponentoption") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renamecomponentoption", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-keepoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::keepoptioncomponent", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-ignoreoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::ignoreoptioncomponent", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-renameoptioncomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::renameoptioncomponent", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-setupcomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setupcomponent", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-initoptions") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::initoptions", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-getinstancevar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::getinstancevar", -1); isDone = 1; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR| ITCL_WIDGET|ITCL_ECLASS)) { /* now the builtin stuff for snit functionality */ if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mytypemethod") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypemethod", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mymethod") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mymethod", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-myvar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myvar", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-mytypevar") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::mytypevar", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-itcl_hull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::itcl_hull", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-callinstance") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::callinstance", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-myproc") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::myproc", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-installhull") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installhull", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-installcomponent") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::installcomponent", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-classunknown") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::classunknown", -1); isDone = 1; } if (strcmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-destroy") == 0) { Tcl_AppendToObj(bodyPtr, "::itcl::builtin::destroy", -1); isDone = 1; } } if (strncmp(Tcl_GetString(imPtr->codePtr->bodyPtr), "@itcl-builtin-setget", 20) == 0) { char *cp = Tcl_GetString(imPtr->codePtr->bodyPtr)+20; Tcl_AppendToObj(bodyPtr, "::itcl::builtin::setget ", -1); Tcl_AppendToObj(bodyPtr, cp, -1); Tcl_AppendToObj(bodyPtr, " ", 1); isDone = 1; } if (!isDone) { Tcl_AppendToObj(bodyPtr, Tcl_GetString(imPtr->codePtr->bodyPtr), -1); } Tcl_AppendToObj(bodyPtr, " {*}$args]", -1); } imPtr->tmPtr = Itcl_NewProcClassMethod(interp, iclsPtr->clsPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); hPtr2 = Tcl_CreateHashEntry(&iclsPtr->infoPtr->procMethods, (char *)imPtr->tmPtr, &isNewEntry); if (isNewEntry) { Tcl_SetHashValue(hPtr2, imPtr); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (argumentPtr == NULL) { argumentPtr = iclsPtr->infoPtr->typeDestructorArgumentPtr; imPtr->codePtr->argumentPtr = argumentPtr; Tcl_IncrRefCount(argumentPtr); } /* * We're overwriting the tmPtr field, so yank out the * entry in the procMethods map based on the old one. */ if (isNewEntry) { Tcl_DeleteHashEntry(hPtr2); } imPtr->tmPtr = Itcl_NewProcMethod(interp, iclsPtr->oPtr, ItclCheckCallMethod, ItclAfterCallMethod, ItclProcErrorProc, imPtr, imPtr->namePtr, argumentPtr, bodyPtr, &pmPtr); } } if ((imPtr->flags & ITCL_COMMON) == 0) { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), Itcl_ExecMethod, imPtr, Itcl_ReleaseData); Itcl_PreserveData(imPtr); } else { imPtr->accessCmd = Tcl_CreateObjCommand(interp, Tcl_GetString(imPtr->fullNamePtr), Itcl_ExecProc, imPtr, Itcl_ReleaseData); Itcl_PreserveData(imPtr); } } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { /* initialize the typecomponents and typevariables */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } FOREACH_HASH_VALUE(ivPtr, &iclsPtr->variables) { if ((ivPtr->flags & ITCL_COMMON) && (ivPtr->init != NULL)) { if (Tcl_SetVar2(interp, Tcl_GetString(ivPtr->namePtr), NULL, Tcl_GetString(ivPtr->init), TCL_NAMESPACE_ONLY) == NULL) { Itcl_PopCallFrame(interp); result = TCL_ERROR; goto errorReturn; } } } Itcl_PopCallFrame(interp); } if (iclsPtr->typeConstructorPtr != NULL) { /* call the typeconstructor body */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } result = Tcl_EvalObjEx(interp, iclsPtr->typeConstructorPtr, TCL_EVAL_DIRECT); Itcl_PopCallFrame(interp); if (result != TCL_OK) { goto errorReturn; } } result = TCL_OK; if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { if (ItclCheckForInitializedComponents(interp, iclsPtr, NULL) != TCL_OK) { result = TCL_ERROR; goto errorReturn; } } if (result == TCL_OK) { Tcl_ResetResult(interp); } if (iclsPtrPtr != NULL) { *iclsPtrPtr = iclsPtr; } ItclAddClassesDictInfo(interp, iclsPtr); return result; errorReturn: if (!noCleanup) { Tcl_DeleteNamespace(iclsPtr->nsPtr); } return result; } /* * ------------------------------------------------------------------------ * ItclCheckForInitializedComponents() * * check if all components for delegation exist and are initialized * ------------------------------------------------------------------------ */ int ItclCheckForInitializedComponents( Tcl_Interp *interp, ItclClass *iclsPtr, ItclObject *ioPtr) { FOREACH_HASH_DECLS; Tcl_CallFrame frame; Tcl_DString buffer; ItclDelegatedFunction *idmPtr; int result; int doCheck; result = TCL_OK; /* check if the typecomponents are initialized */ if (Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr, /*isProcCallFrame*/0) != TCL_OK) { return TCL_ERROR; } idmPtr = NULL; FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { const char *val; /* check here for delegated typemethods only * rest is done in ItclCreateObject */ doCheck = 1; if (ioPtr == NULL) { if (!(idmPtr->flags & ITCL_TYPE_METHOD)) { doCheck = 0; ioPtr = iclsPtr->infoPtr->currIoPtr; } } if (doCheck) { if (idmPtr->icPtr != NULL) { if (idmPtr->icPtr->ivPtr->flags & ITCL_COMMON) { Tcl_Obj *objPtr; objPtr = Tcl_NewStringObj(ITCL_VARIABLES_NAMESPACE, -1); Tcl_AppendToObj(objPtr, (Tcl_GetObjectNamespace( idmPtr->icPtr->ivPtr->iclsPtr->oPtr))->fullName, -1); Tcl_AppendToObj(objPtr, "::", -1); Tcl_AppendToObj(objPtr, Tcl_GetString( idmPtr->icPtr->ivPtr->namePtr), -1); val = Tcl_GetVar2(interp, Tcl_GetString(objPtr), NULL, 0); Tcl_DecrRefCount(objPtr); } else { Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, Tcl_GetString(ioPtr->varNsNamePtr), -1); Tcl_DStringAppend(&buffer, Tcl_GetString(idmPtr->icPtr->ivPtr->fullNamePtr), -1); val = Tcl_GetVar2(interp, Tcl_DStringValue(&buffer), NULL, 0); Tcl_DStringFree(&buffer); } if ((ioPtr != NULL) && ((val != NULL) && (strlen(val) == 0))) { val = ItclGetInstanceVar( ioPtr->iclsPtr->interp, "itcl_hull", NULL, ioPtr, iclsPtr); } if ((val == NULL) || (strlen(val) == 0)) { if (iclsPtr->flags & ITCL_WIDGETADAPTOR) { if (strcmp (Tcl_GetString(idmPtr->icPtr->namePtr), "itcl_hull") == 0) { /* maybe that will be initialized in constructor * later on */ continue; } } result = TCL_ERROR; break; } } } } Itcl_PopCallFrame(interp); if (result == TCL_ERROR) { const char *startStr; const char *sepStr; const char *objectStr; startStr = ""; sepStr = ""; objectStr = ""; if (ioPtr != NULL) { sepStr = " "; objectStr = Tcl_GetString(ioPtr->origNamePtr); } if (idmPtr->flags & ITCL_TYPE_METHOD) { startStr = "type"; } /* FIXME there somtimes is a message for widgetadaptor: * can't read "itcl_hull": no such variable * have to check why */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_GetString(iclsPtr->fullNamePtr), sepStr, objectStr, " delegates ", startStr, "method \"", Tcl_GetString(idmPtr->namePtr), "\" to undefined ", startStr, "component \"", Tcl_GetString(idmPtr->icPtr->ivPtr->namePtr), "\"", NULL); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassInheritCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "inherit" command is invoked to define one or more base classes. * Handles the following syntax: * * inherit ?...? * * ------------------------------------------------------------------------ */ int Itcl_ClassInheritCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); int result; int i; int newEntry; int haveClasses; const char *token; Itcl_ListElem *elem; Itcl_ListElem *elem2; ItclClass *cdPtr; ItclClass *baseClsPtr; ItclClass *badCdPtr; ItclHierIter hier; Itcl_Stack stack; Tcl_CallFrame frame; Tcl_DString buffer; ItclShowArgs(2, "Itcl_InheritCmd", objc, objv); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::inherit called from", " not within a class", NULL); return TCL_ERROR; } /* * An "inherit" statement can only be included once in a * class definition. */ elem = Itcl_FirstListElem(&iclsPtr->bases); if (elem != NULL) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), Tcl_GetString(cdPtr->namePtr), " ", NULL); elem = Itcl_NextListElem(elem); } Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\" already defined for class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * Validate each base class and add it to the "bases" list. */ result = Itcl_PushCallFrame(interp, &frame, iclsPtr->nsPtr->parentPtr, /* isProcCallFrame */ 0); if (result != TCL_OK) { return TCL_ERROR; } for (objc--,objv++; objc > 0; objc--,objv++) { /* * Make sure that the base class name is known in the * parent namespace (currently active). If not, try * to autoload its definition. */ token = Tcl_GetString(*objv); baseClsPtr = Itcl_FindClass(interp, token, /* autoload */ 1); if (!baseClsPtr) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); int errlen; char *errmsg; Tcl_IncrRefCount(resultPtr); errmsg = Tcl_GetStringFromObj(resultPtr, &errlen); Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot inherit from \"", token, "\"", NULL); if (errlen > 0) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), " (", errmsg, ")", NULL); } Tcl_DecrRefCount(resultPtr); goto inheritError; } /* * Make sure that the base class is not the same as the * class that is being built. */ if (baseClsPtr == iclsPtr) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", Tcl_GetString(iclsPtr->namePtr), "\" cannot inherit from itself", NULL); goto inheritError; } Itcl_AppendList(&iclsPtr->bases, baseClsPtr); ItclPreserveClass(baseClsPtr); } /* * Scan through the inheritance list to make sure that no * class appears twice. */ elem = Itcl_FirstListElem(&iclsPtr->bases); while (elem) { elem2 = Itcl_NextListElem(elem); while (elem2) { if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "class \"", iclsPtr->fullNamePtr, "\" cannot inherit base class \"", cdPtr->fullNamePtr, "\" more than once", NULL); goto inheritError; } elem2 = Itcl_NextListElem(elem2); } elem = Itcl_NextListElem(elem); } /* * Add each base class and all of its base classes into * the heritage for the current class. Along the way, make * sure that no class appears twice in the heritage. */ Itcl_InitHierIter(&hier, iclsPtr); cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */ cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr != NULL) { (void) Tcl_CreateHashEntry(&iclsPtr->heritage, (char*)cdPtr, &newEntry); if (!newEntry) { break; } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); /* * Same base class found twice in the hierarchy? * Then flag error. Show the list of multiple paths * leading to the same base class. */ if (!newEntry) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); badCdPtr = cdPtr; Tcl_AppendStringsToObj(resultPtr, "class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\" inherits base class \"", Tcl_GetString(badCdPtr->fullNamePtr), "\" more than once:", NULL); cdPtr = iclsPtr; Itcl_InitStack(&stack); Itcl_PushStack(cdPtr, &stack); /* * Show paths leading to bad base class */ while (Itcl_GetStackSize(&stack) > 0) { cdPtr = (ItclClass*)Itcl_PopStack(&stack); if (cdPtr == badCdPtr) { Tcl_AppendToObj(resultPtr, "\n ", -1); for (i=0; i < Itcl_GetStackSize(&stack); i++) { if (Itcl_GetStackValue(&stack, i) == NULL) { cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); Tcl_AppendStringsToObj(resultPtr, Tcl_GetString(cdPtr->namePtr), "->", NULL); } } Tcl_AppendToObj(resultPtr, Tcl_GetString(badCdPtr->namePtr), -1); } else if (!cdPtr) { (void)Itcl_PopStack(&stack); } else { elem = Itcl_LastListElem(&cdPtr->bases); if (elem) { Itcl_PushStack(cdPtr, &stack); Itcl_PushStack(NULL, &stack); while (elem) { Itcl_PushStack(Itcl_GetListValue(elem), &stack); elem = Itcl_PrevListElem(elem); } } } } Itcl_DeleteStack(&stack); goto inheritError; } /* * At this point, everything looks good. * Finish the installation of the base classes. Update * each base class to recognize the current class as a * derived class. */ Tcl_DStringInit(&buffer); haveClasses = 0; elem = Itcl_FirstListElem(&iclsPtr->bases); Tcl_DStringAppend(&buffer, "::oo::define ", -1); Tcl_DStringAppend(&buffer, Tcl_GetString(iclsPtr->fullNamePtr), -1); Tcl_DStringAppend(&buffer, " superclass", -1); while (elem) { baseClsPtr = (ItclClass*)Itcl_GetListValue(elem); haveClasses++; Tcl_DStringAppend(&buffer, " ", -1); Tcl_DStringAppend(&buffer, Tcl_GetString(baseClsPtr->fullNamePtr), -1); Itcl_AppendList(&baseClsPtr->derived, iclsPtr); ItclPreserveClass(iclsPtr); elem = Itcl_NextListElem(elem); } Itcl_PopCallFrame(interp); if (haveClasses) { result = Tcl_EvalEx(interp, Tcl_DStringValue(&buffer), -1, 0); } Tcl_DStringFree(&buffer); Itcl_BuildVirtualTables(iclsPtr); return result; /* * If the "inherit" list cannot be built properly, tear it * down and return an error. */ inheritError: Itcl_PopCallFrame(interp); elem = Itcl_FirstListElem(&iclsPtr->bases); while (elem) { ItclReleaseClass( (ItclClass *)Itcl_GetListValue(elem) ); elem = Itcl_DeleteListElem(elem); } return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_ClassProtectionCmd() * * Invoked by Tcl whenever the user issues a protection setting * command like "public" or "private". Creates commands and * variables, and assigns a protection level to them. Protection * levels are defined as follows: * * public => accessible from any namespace * protected => accessible from selected namespaces * private => accessible only in the namespace where it was defined * * Handles the following syntax: * * public ? ...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_ClassProtectionCmd( ClientData clientData, /* protection level (public/protected/private) */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ProtectionCmdInfo *pInfo = (ProtectionCmdInfo*)clientData; int result; int oldLevel; ItclShowArgs(2, "Itcl_ClassProtectionCmd", objc, objv); if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); return TCL_ERROR; } oldLevel = Itcl_Protection(interp, pInfo->pLevel); if (objc == 2) { /* something like: public { variable a; variable b } */ result = Tcl_EvalObjEx(interp, objv[1], 0); } else { /* something like: public variable a 123 456 */ result = Itcl_EvalArgs(interp, objc-1, objv+1); } if (result == TCL_BREAK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"break\" outside of a loop", -1)); result = TCL_ERROR; } else { if (result == TCL_CONTINUE) { Tcl_SetObjResult(interp, Tcl_NewStringObj("invoked \"continue\" outside of a loop", -1)); result = TCL_ERROR; } else { if (result != TCL_OK) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, result); Tcl_Obj *key = Tcl_NewStringObj("-errorline", -1); Tcl_Obj *stackTrace = NULL; Tcl_IncrRefCount(key); Tcl_DictObjGet(NULL, options, key, &stackTrace); Tcl_DecrRefCount(key); if (stackTrace == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n error while parsing class \"%s\"", Tcl_GetString(objv[0]))); } else { char *token = Tcl_GetString(objv[0]); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%.100s body line %s)", token, Tcl_GetString(stackTrace))); } } } } Itcl_Protection(interp, oldLevel); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassConstructorCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "constructor" command is invoked to define the constructor * for an object. Handles the following syntax: * * constructor ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassConstructorCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_Obj *namePtr; char *arglist; char *body; ItclShowArgs(2, "Itcl_ClassConstructorCmd", objc, objv); if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::constructor called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[0]; if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)objv[0])) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } /* * If there is an object initialization statement, pick this * out and take the last argument as the constructor body. */ arglist = Tcl_GetString(objv[1]); if (objc == 3) { body = Tcl_GetString(objv[2]); } else { iclsPtr->initCode = objv[2]; Tcl_IncrRefCount(iclsPtr->initCode); body = Tcl_GetString(objv[3]); } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassDestructorCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "destructor" command is invoked to define the destructor * for an object. Handles the following syntax: * * destructor * * ------------------------------------------------------------------------ */ int Itcl_ClassDestructorCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); Tcl_Obj *namePtr; char *body; ItclShowArgs(2, "Itcl_ClassDestructorCmd", objc, objv); if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::destructor called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[0]; body = Tcl_GetString(objv[1]); if (Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr)) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "\"", Tcl_GetString(namePtr), "\" already defined in class \"", Tcl_GetString(iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, NULL, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "method" command is invoked to define an object method. * Handles the following syntax: * * method ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassMethodCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); char *arglist; char *body; ItclShowArgs(2, "Itcl_ClassMethodCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::method called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[1]; hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "method \"", Tcl_GetString(namePtr), "\" has been delegated", NULL); return TCL_ERROR; } arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (Itcl_CreateMethod(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassProcCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "proc" command is invoked to define a common class proc. * A "proc" is like a "method", but only has access to "common" * class variables. Handles the following syntax: * * proc ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassProcCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; char *arglist; char *body; ItclShowArgs(1, "Itcl_ClassProcCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); namePtr = objv[1]; arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::proc called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { const char *name = Tcl_GetString(namePtr); /* check if the typemethod is already delegated */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { Tcl_AppendResult(interp, "Error in \"typemethod ", name, "...\", \"", name, "\" has been delegated", NULL); return TCL_ERROR; } } } if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "proc" command is invoked to define a common class proc. * A "proc" is like a "method", but only has access to "common" * class variables. Handles the following syntax: * * typemethod ?? ?? * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeMethodCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { FOREACH_HASH_DECLS; Tcl_Obj *namePtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; char *arglist; char *body; ItclMemberFunc *imPtr; ItclShowArgs(1, "Itcl_ClassTypeMethodCmd", objc, objv); if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::typemethod called from", " not within a class", NULL); return TCL_ERROR; } namePtr = objv[1]; arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetString(objv[2]); } if (objc >= 4) { body = Tcl_GetString(objv[3]); } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { const char *name = Tcl_GetString(namePtr); /* check if the typemethod is already delegated */ FOREACH_HASH_VALUE(idmPtr, &iclsPtr->delegatedFunctions) { if (strcmp(Tcl_GetString(idmPtr->namePtr), name) == 0) { Tcl_AppendResult(interp, "Error in \"typemethod ", name, "...\", \"", name, "\" has been delegated", NULL); return TCL_ERROR; } } } iclsPtr->infoPtr->functionFlags = ITCL_TYPE_METHOD; if (Itcl_CreateProc(interp, iclsPtr, namePtr, arglist, body) != TCL_OK) { iclsPtr->infoPtr->functionFlags = 0; return TCL_ERROR; } iclsPtr->infoPtr->functionFlags = 0; hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)namePtr); imPtr = (ItclMemberFunc *)Tcl_GetHashValue(hPtr); imPtr->flags |= ITCL_TYPE_METHOD; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassVariableCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "variable" command is invoked to define an instance variable. * Handles the following syntax: * * variable ?? ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassVariableCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *namePtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclVariable *ivPtr; char *init; char *config; char *arrayInitStr; const char *usageStr; int pLevel; int haveError; int haveArrayInit; int result; result = TCL_OK; haveError = 0; haveArrayInit = 0; usageStr = NULL; arrayInitStr = NULL; ItclShowArgs(1, "Itcl_ClassVariableCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::variable called from", " not within a class", NULL); return TCL_ERROR; } pLevel = Itcl_Protection(interp, 0); if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (objc > 2) { if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { if (objc == 4) { arrayInitStr = Tcl_GetString(objv[3]); haveArrayInit = 1; } else { haveError = 1; usageStr = "varname ?init|-array init?"; } } } } if (!haveError && !haveArrayInit) { if (pLevel == ITCL_PUBLIC) { if (objc < 2 || objc > 4) { usageStr = "name ?init? ?config?"; haveError = 1; } } else { if ((objc < 2) || (objc > 3)) { usageStr = "name ?init?"; haveError = 1; } } } if (haveError) { Tcl_WrongNumArgs(interp, 1, objv, usageStr); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ namePtr = objv[1]; if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", NULL); return TCL_ERROR; } init = NULL; config = NULL; if (!haveArrayInit) { if (objc >= 3) { init = Tcl_GetString(objv[2]); } if (objc >= 4) { config = Tcl_GetString(objv[3]); } } if (Itcl_CreateVariable(interp, iclsPtr, namePtr, init, config, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { ivPtr->flags |= ITCL_VARIABLE; } if (haveArrayInit) { ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1); Tcl_IncrRefCount(ivPtr->arrayInitPtr); } else { ivPtr->arrayInitPtr = NULL; } iclsPtr->numVariables++; ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); return result; } /* * ------------------------------------------------------------------------ * ItclInitClassCommon() * * initialize a class commen variable * * ------------------------------------------------------------------------ */ static int ItclInitClassCommon( Tcl_Interp *interp, ItclClass *iclsPtr, ItclVariable *ivPtr, const char *initStr) { Tcl_DString buffer; Tcl_CallFrame frame; Tcl_Namespace *commonNsPtr; Tcl_HashEntry *hPtr; Tcl_Var varPtr; int result; int isNew; result = TCL_OK; ivPtr->flags |= ITCL_COMMON; iclsPtr->numCommons++; /* * Create the variable in the namespace associated with the * class. Do this the hard way, to avoid the variable resolver * procedures. These procedures won't work until we rebuild * the virtual tables below. */ Tcl_DStringInit(&buffer); if (ivPtr->protection != ITCL_PUBLIC) { /* public commons go to the class namespace directly the others * go to the variables namespace of the class */ Tcl_DStringAppend(&buffer, ITCL_VARIABLES_NAMESPACE, -1); } Tcl_DStringAppend(&buffer, (Tcl_GetObjectNamespace(ivPtr->iclsPtr->oPtr))->fullName, -1); commonNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), NULL, 0); if (commonNsPtr == NULL) { Tcl_AppendResult(interp, "ITCL: cannot find common variables namespace", " for class \"", Tcl_GetString(ivPtr->iclsPtr->fullNamePtr), "\"", NULL); return TCL_ERROR; } varPtr = Tcl_NewNamespaceVar(interp, commonNsPtr, Tcl_GetString(ivPtr->namePtr)); hPtr = Tcl_CreateHashEntry(&iclsPtr->classCommons, (char *)ivPtr, &isNew); if (isNew) { Itcl_PreserveVar(varPtr); Tcl_SetHashValue(hPtr, varPtr); } result = Itcl_PushCallFrame(interp, &frame, commonNsPtr, /* isProcCallFrame */ 0); Itcl_PopCallFrame(interp); /* * If an initialization value was specified, then initialize * the variable now, otherwise be sure the variable is uninitialized. */ if (initStr != NULL) { const char *val; val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, initStr, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", NULL); return TCL_ERROR; } } else { /* previous var-lookup in class body (in ::itcl::parser) could obtain * inherited common vars, so be sure it does not exists after new * common creation (simply remove this reference). */ Tcl_UnsetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), NULL, TCL_NAMESPACE_ONLY); } if (ivPtr->arrayInitPtr != NULL) { int i; int argc; const char **argv; const char *val; result = Tcl_SplitList(interp, Tcl_GetString(ivPtr->arrayInitPtr), &argc, &argv); for (i = 0; i < argc; i++) { val = Tcl_SetVar2(interp, Tcl_GetString(ivPtr->fullNamePtr), argv[i], argv[i + 1], TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot initialize common variable \"", Tcl_GetString(ivPtr->namePtr), "\"", NULL); return TCL_ERROR; } i++; } ckfree((char *)argv); } Tcl_DStringFree(&buffer); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCommonCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "common" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * common ?? * * ------------------------------------------------------------------------ */ static int ItclClassCommonCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ int protection, ItclVariable **ivPtrPtr) { ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclVariable *ivPtr; Tcl_Obj *namePtr; char *arrayInitStr; const char *usageStr; char *initStr; int haveError; int haveArrayInit; int result; result = TCL_OK; haveError = 0; haveArrayInit = 0; usageStr = NULL; arrayInitStr = NULL; *ivPtrPtr = NULL; ItclShowArgs(2, "Itcl_ClassCommonCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::common called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & (ITCL_TYPE|ITCL_WIDGETADAPTOR)) { if (objc > 2) { if (strcmp(Tcl_GetString(objv[2]), "-array") == 0) { if (objc == 4) { arrayInitStr = Tcl_GetString(objv[3]); haveArrayInit = 1; } else { haveError = 1; usageStr = "varname ?init|-array init?"; } } } } if (!haveError && !haveArrayInit) { if ((objc < 2) || (objc > 3)) { usageStr = "varname ?init?"; haveError = 1; } } if (haveError) { Tcl_WrongNumArgs(interp, 1, objv, usageStr); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ namePtr = objv[1]; if (strstr(Tcl_GetString(namePtr), "::")) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "bad variable name \"", Tcl_GetString(namePtr), "\"", NULL); return TCL_ERROR; } initStr = NULL; if (!haveArrayInit) { if (objc >= 3) { initStr = Tcl_GetString(objv[2]); } } if (Itcl_CreateVariable(interp, iclsPtr, namePtr, initStr, NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (protection != 0) { ivPtr->protection = protection; } if (haveArrayInit) { ivPtr->arrayInitPtr = Tcl_NewStringObj(arrayInitStr, -1); Tcl_IncrRefCount(ivPtr->arrayInitPtr); } else { ivPtr->arrayInitPtr = NULL; } *ivPtrPtr = ivPtr; result = ItclInitClassCommon(interp, iclsPtr, ivPtr, initStr); ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeVariableCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "typevariable" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * typevariable ?? * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeVariableCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclVariable *ivPtr; int result; ivPtr = NULL; ItclShowArgs(1, "Itcl_ClassTypeVariableCmd", objc, objv); result = ItclClassCommonCmd(clientData, interp, objc, objv, ITCL_PUBLIC, &ivPtr); if (ivPtr != NULL) { ivPtr->flags |= ITCL_TYPE_VARIABLE; ItclAddClassVariableDictInfo(interp, ivPtr->iclsPtr, ivPtr); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassCommonCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "common" command is invoked to define a variable that is * common to all objects in the class. Handles the following syntax: * * common ?? * * ------------------------------------------------------------------------ */ int Itcl_ClassCommonCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclVariable *ivPtr; ItclShowArgs(2, "Itcl_ClassTypeVariableCmd", objc, objv); return ItclClassCommonCmd(clientData, interp, objc, objv, 0, &ivPtr); } /* * ------------------------------------------------------------------------ * ItclFreeParserCommandData() * * This callback will free() up memory dynamically allocated * and passed as the ClientData argument to Tcl_CreateObjCommand. * This callback is required because one can not simply pass * a pointer to the free() or ckfree() to Tcl_CreateObjCommand. * ------------------------------------------------------------------------ */ static void ItclFreeParserCommandData( ClientData cdata) /* client data to be destroyed */ { ckfree(cdata); } /* * ------------------------------------------------------------------------ * ItclDelObjectInfo() * * Invoked when the management info for [incr Tcl] is no longer being * used in an interpreter. This will only occur when all class * manipulation commands are removed from the interpreter. * * See also FreeItclObjectInfo() in itclBase.c * ------------------------------------------------------------------------ */ static void ItclDelObjectInfo( char* cdata) /* client data for class command */ { Tcl_HashSearch place; Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr = (ItclObjectInfo*)cdata; ItclObject *ioPtr; /* * Destroy all known objects by deleting their access * commands. */ hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); while (hPtr) { ioPtr = (ItclObject*)Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(infoPtr->interp, ioPtr->accessCmd); /* * Fix 227804: Whenever an object to delete was found we * have to reset the search to the beginning as the * current entry in the search was deleted and accessing it * is therefore not allowed anymore. */ hPtr = Tcl_FirstHashEntry(&infoPtr->objects, &place); /*hPtr = Tcl_NextHashEntry(&place);*/ } Tcl_DeleteHashTable(&infoPtr->objects); Tcl_DeleteHashTable(&infoPtr->frameContext); Itcl_DeleteStack(&infoPtr->clsStack); Itcl_Free(infoPtr); } /* * ------------------------------------------------------------------------ * Itcl_ClassFilterCmd() * * * ------------------------------------------------------------------------ */ static int Itcl_ClassFilterCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj **newObjv; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; int result; ItclShowArgs(1, "Itcl_ClassFilterCmd", objc, objv); infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::filter called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", "/::itcl::extendedclass. Only these can have filters", NULL); return TCL_ERROR; } if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, " ? ...?"); return TCL_ERROR; } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*(objc+2)); newObjv[0] = Tcl_NewStringObj("::oo::define", -1); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj(Tcl_GetString(iclsPtr->fullNamePtr), -1); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("filter", -1); Tcl_IncrRefCount(newObjv[2]); memcpy(newObjv+3, objv+1, sizeof(Tcl_Obj *)*(objc-1)); ItclShowArgs(1, "Itcl_ClassFilterCmd2", objc+2, newObjv); result = Tcl_EvalObjv(interp, objc+2, newObjv, 0); Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); ckfree((char *)newObjv); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassMixinCmd() * * * ------------------------------------------------------------------------ */ static int Itcl_ClassMixinCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { (void)clientData; (void)interp; ItclShowArgs(0, "Itcl_ClassMixinCmd", objc, objv); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_WidgetCmd() * * that is just a dummy command to load package ItclWidget * and then to resend the command and execute it in that package * package ItclWidget is renaming the Tcl command!! * * ------------------------------------------------------------------------ */ static int Itcl_WidgetCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr; int result; ItclShowArgs(1, "Itcl_WidgetCmd", objc-1, objv); infoPtr = (ItclObjectInfo *)clientData; if (!infoPtr->itclWidgetInitted) { result = Tcl_EvalEx(interp, initWidgetScript, -1, 0); if (result != TCL_OK) { return result; } infoPtr->itclWidgetInitted = 1; } return Tcl_EvalObjv(interp, objc, objv, 0); } /* * ------------------------------------------------------------------------ * Itcl_WidgetAdaptorCmd() * * that is just a dummy command to load package ItclWidget * and then to resend the command and execute it in that package * package ItclWidget is renaming the Tcl command!! * * ------------------------------------------------------------------------ */ static int Itcl_WidgetAdaptorCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclObjectInfo *infoPtr; int result; ItclShowArgs(1, "Itcl_WidgetAdaptorCmd", objc-1, objv); infoPtr = (ItclObjectInfo *)clientData; if (!infoPtr->itclWidgetInitted) { result = Tcl_EvalEx(interp, initWidgetScript, -1, 0); if (result != TCL_OK) { return result; } infoPtr->itclWidgetInitted = 1; } return Tcl_EvalObjv(interp, objc, objv, 0); } /* * ------------------------------------------------------------------------ * ItclParseOption() * * Invoked by Tcl during the parsing whenever * the "option" command is invoked to define an option * Handles the following syntax: * * option * * ------------------------------------------------------------------------ */ int ItclParseOption( ItclObjectInfo *infoPtr, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclClass *iclsPtr, ItclObject *ioPtr, ItclOption **ioptPtrPtr) /* where the otpion info is found */ { Tcl_Obj *classNamePtr; Tcl_Obj *nameSpecPtr; Tcl_Obj **newObjv; Tcl_HashEntry *hPtr; ItclOption *ioptPtr; char *init; char *defaultValue; char *cgetMethod; char *cgetMethodVar; char *configureMethod; char *configureMethodVar; char *validateMethod; char *validateMethodVar; const char *token; const char *usage; const char *optionName; const char **argv; const char *name; const char *resourceName; const char *className; int argc; int pLevel; int readOnly; int newObjc; int foundOption; int result; int i; const char *cp; (void)infoPtr; ItclShowArgs(1, "ItclParseOption", objc, objv); pLevel = Itcl_Protection(interp, 0); usage = "namespec \ ?init? \ ?-default value? \ ?-readonly? \ ?-cgetmethod methodName? \ ?-cgetmethodvar varName? \ ?-configuremethod methodName? \ ?-configuremethodvar varName? \ ?-validatemethod methodName? \ ?-validatemethodvar varName"; if (pLevel == ITCL_PUBLIC) { if (objc < 2 || objc > 11) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } } else { if ((objc < 2) || (objc > 12)) { Tcl_WrongNumArgs(interp, 1, objv, usage); return TCL_ERROR; } } argv = NULL; newObjv = NULL; defaultValue = NULL; cgetMethod = NULL; configureMethod = NULL; validateMethod = NULL; cgetMethodVar = NULL; configureMethodVar = NULL; validateMethodVar = NULL; readOnly = 0; newObjc = 0; optionName = Tcl_GetString(objv[1]); if (iclsPtr != NULL) { /* check for already delegated!! */ hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedOptions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "cannot define option \"", optionName, "\" locally, it has already been delegated", NULL); result = TCL_ERROR; goto errorOut; } } if (ioPtr != NULL) { /* check for already delegated!! */ hPtr = Tcl_FindHashEntry(&ioPtr->objectDelegatedOptions, (char *)objv[1]); if (hPtr != NULL) { Tcl_AppendResult(interp, "cannot define option \"", optionName, "\" locally, it has already been delegated", NULL); result = TCL_ERROR; goto errorOut; } } newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *)*objc); newObjv[newObjc] = objv[1]; newObjc++; for (i=2; i 1) { resourceName = argv[1]; } else { /* resource name defaults to option name minus hyphen */ resourceName = name+1; } if (argc > 2) { className = argv[2]; } else { /* class name defaults to option name minus hyphen and capitalized */ className = resourceName; } classNamePtr = ItclCapitalize(className); init = defaultValue; if ((newObjc > 1) && (init == NULL)) { init = Tcl_GetString(newObjv[1]); } ioptPtr = (ItclOption*)Itcl_Alloc(sizeof(ItclOption)); ioptPtr->protection = Itcl_Protection(interp, 0); if (ioptPtr->protection == ITCL_DEFAULT_PROTECT) { ioptPtr->protection = ITCL_PROTECTED; } ioptPtr->namePtr = Tcl_NewStringObj(name, -1); Tcl_IncrRefCount(ioptPtr->namePtr); ioptPtr->resourceNamePtr = Tcl_NewStringObj(resourceName, -1); Tcl_IncrRefCount(ioptPtr->resourceNamePtr); ioptPtr->classNamePtr = Tcl_NewStringObj(Tcl_GetString(classNamePtr), -1); Tcl_IncrRefCount(ioptPtr->classNamePtr); Tcl_DecrRefCount(classNamePtr); if (init) { ioptPtr->defaultValuePtr = Tcl_NewStringObj(init, -1); Tcl_IncrRefCount(ioptPtr->defaultValuePtr); } if (cgetMethod != NULL) { ioptPtr->cgetMethodPtr = Tcl_NewStringObj(cgetMethod, -1); Tcl_IncrRefCount(ioptPtr->cgetMethodPtr); } if (configureMethod != NULL) { ioptPtr->configureMethodPtr = Tcl_NewStringObj(configureMethod, -1); Tcl_IncrRefCount(ioptPtr->configureMethodPtr); } if (validateMethod != NULL) { ioptPtr->validateMethodPtr = Tcl_NewStringObj(validateMethod, -1); Tcl_IncrRefCount(ioptPtr->validateMethodPtr); } if (cgetMethodVar != NULL) { ioptPtr->cgetMethodVarPtr = Tcl_NewStringObj(cgetMethodVar, -1); Tcl_IncrRefCount(ioptPtr->cgetMethodVarPtr); } if (configureMethodVar != NULL) { ioptPtr->configureMethodVarPtr = Tcl_NewStringObj(configureMethodVar, -1); Tcl_IncrRefCount(ioptPtr->configureMethodVarPtr); } if (validateMethodVar != NULL) { ioptPtr->validateMethodVarPtr = Tcl_NewStringObj(validateMethodVar, -1); Tcl_IncrRefCount(ioptPtr->validateMethodVarPtr); } if (readOnly != 0) { ioptPtr->flags |= ITCL_OPTION_READONLY; } *ioptPtrPtr = ioptPtr; ItclAddOptionDictInfo(interp, iclsPtr, ioptPtr); result = TCL_OK; errorOut: if (argv != NULL) { ckfree((char *)argv); } if (newObjv != NULL) { ckfree((char *)newObjv); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassOptionCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "option" command is invoked to define an option * Handles the following syntax: * * option * * ------------------------------------------------------------------------ */ int Itcl_ClassOptionCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclOption *ioptPtr; const char *tkPackage; const char *tkVersion; ItclObjectInfo *infoPtr = (ItclObjectInfo*)clientData; ItclClass *iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); ItclShowArgs(1, "Itcl_ClassOptionCmd", objc, objv); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::option called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "a \"class\" cannot have options", NULL); return TCL_ERROR; } if ((objc > 1) && (strcmp(Tcl_GetString(objv[1]), "add") == 0)) { tkVersion = "8.6"; tkPackage = Tcl_PkgPresentEx(interp, "Tk", tkVersion, 0, NULL); if (tkPackage == NULL) { tkPackage = Tcl_PkgRequireEx(interp, "Tk", tkVersion, 0, NULL); } if (tkPackage == NULL) { Tcl_AppendResult(interp, "cannot load package Tk", tkVersion, NULL); return TCL_ERROR; } return Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL); } if (ItclParseOption(infoPtr, interp, objc, objv, iclsPtr, NULL, &ioptPtr) != TCL_OK) { return TCL_ERROR; } if (Itcl_CreateOption(interp, iclsPtr, ioptPtr) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclCreateComponent() * * * ------------------------------------------------------------------------ */ int ItclCreateComponent( Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *componentPtr, int type, ItclComponent **icPtrPtr) { Tcl_HashEntry *hPtr; ItclComponent *icPtr; ItclVariable *ivPtr; int result; int isNew; if (iclsPtr == NULL) { return TCL_OK; } hPtr = Tcl_CreateHashEntry(&iclsPtr->components, (char *)componentPtr, &isNew); if (isNew) { if (Itcl_CreateVariable(interp, iclsPtr, componentPtr, NULL, NULL, &ivPtr) != TCL_OK) { return TCL_ERROR; } if (type & ITCL_COMMON) { result = ItclInitClassCommon(interp, iclsPtr, ivPtr, ""); if (result != TCL_OK) { return result; } } if (iclsPtr->flags & (ITCL_WIDGET|ITCL_WIDGETADAPTOR)) { if (strcmp(Tcl_GetString(componentPtr), "itcl_hull") == 0) { /* special built in itcl_hull variable */ ivPtr->initted = 1; ivPtr->flags |= ITCL_HULL_VAR; } } ivPtr->flags |= ITCL_COMPONENT_VAR; icPtr = (ItclComponent *)ckalloc(sizeof(ItclComponent)); memset(icPtr, 0, sizeof(ItclComponent)); Tcl_InitObjHashTable(&icPtr->keptOptions); icPtr->namePtr = componentPtr; Tcl_IncrRefCount(icPtr->namePtr); icPtr->ivPtr = ivPtr; Tcl_SetHashValue(hPtr, icPtr); ItclAddClassVariableDictInfo(interp, iclsPtr, ivPtr); } else { icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } *icPtrPtr = icPtr; return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclHandleClassComponent() * * Invoked by Tcl during the parsing of a class definition whenever * the "component" command is invoked to define a component * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int ItclHandleClassComponent( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[], /* argument objects */ ItclComponent **icPtrPtr) { Tcl_Obj **newObjv; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclComponent *icPtr; const char *usage; const char *publ; int inherit; int haveInherit; int havePublic; int newObjc; int haveValue; int storageClass; int i; ItclShowArgs(1, "Itcl_ClassComponentCmd", objc, objv); if (icPtrPtr != NULL) { *icPtrPtr = NULL; } infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::component called from", " not within a class", NULL); return TCL_ERROR; } usage = "component ?-public ? ?-inherit ???"; if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::extendedclass/::itcl::widget", "/::itcl::widgetadaptor/::itcl::type.", " Only these can have components", NULL); return TCL_ERROR; } if ((objc < 2) || (objc > 6)) { Tcl_AppendResult(interp, "wrong # args should be: ", usage, NULL); return TCL_ERROR; } inherit = 0; haveInherit = 0; publ = NULL; havePublic = 0; for (i = 2; i < objc; i++) { if (strcmp(Tcl_GetString(objv[i]), "-inherit") == 0) { if (haveInherit) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } haveValue = 0; inherit = 1; if (i < objc - 1) { if (strcmp(Tcl_GetString(objv[i + 1]), "yes") == 0) { haveValue = 1; } if (strcmp(Tcl_GetString(objv[i + 1]), "YES") == 0) { haveValue = 1; } if (strcmp(Tcl_GetString(objv[i + 1]), "no") == 0) { haveValue = 1; inherit = 0; } if (strcmp(Tcl_GetString(objv[i + 1]), "NO") == 0) { haveValue = 1; inherit = 0; } } if (haveValue) { i++; } haveInherit = 1; } else { if (strcmp(Tcl_GetString(objv[i]), "-public") == 0) { if (havePublic) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } havePublic = 1; if (i >= objc - 1) { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } publ = Tcl_GetString(objv[i + 1]); } else { Tcl_AppendResult(interp, "wrong syntax should be: ", usage, NULL); return TCL_ERROR; } } i++; } storageClass = ITCL_COMMON; if (iclsPtr->flags & ITCL_ECLASS) { storageClass = 0; } if (ItclCreateComponent(interp, iclsPtr, objv[1], storageClass, &icPtr) != TCL_OK) { return TCL_ERROR; } if (inherit) { icPtr->flags |= ITCL_COMPONENT_INHERIT; newObjc = 4; newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); newObjv[0] = Tcl_NewStringObj("delegate::option", -1); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj("*", -1); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("to", -1); Tcl_IncrRefCount(newObjv[2]); newObjv[3] = objv[1]; Tcl_IncrRefCount(newObjv[3]); if (Itcl_ClassDelegateOptionCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_SetStringObj(newObjv[0] , "delegate::method", -1); if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); Tcl_DecrRefCount(newObjv[3]); ckfree((char *)newObjv); } if (publ != NULL) { icPtr->flags |= ITCL_COMPONENT_PUBLIC; newObjc = 4; newObjv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*)*newObjc); newObjv[0] = Tcl_NewStringObj("delegate::method", -1); Tcl_IncrRefCount(newObjv[0]); newObjv[1] = Tcl_NewStringObj(publ, -1); Tcl_IncrRefCount(newObjv[1]); newObjv[2] = Tcl_NewStringObj("to", -1); Tcl_IncrRefCount(newObjv[2]); newObjv[3] = objv[1]; Tcl_IncrRefCount(newObjv[3]); ItclShowArgs(1, "COMPPUB", newObjc, newObjv); if (Itcl_ClassDelegateMethodCmd(infoPtr, interp, newObjc, newObjv) != TCL_OK) { return TCL_ERROR; } Tcl_DecrRefCount(newObjv[0]); Tcl_DecrRefCount(newObjv[1]); Tcl_DecrRefCount(newObjv[2]); Tcl_DecrRefCount(newObjv[3]); ckfree((char *)newObjv); } if (icPtrPtr != NULL) { *icPtrPtr = icPtr; } ItclAddClassComponentDictInfo(interp, iclsPtr, icPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ClassComponentCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "component" command is invoked to define a component * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int Itcl_ClassComponentCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclComponent *icPtr; return ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); } /* * ------------------------------------------------------------------------ * Itcl_ClassTypeComponentCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "typecomponent" command is invoked to define a typecomponent * Handles the following syntax: * * component * * ------------------------------------------------------------------------ */ static int Itcl_ClassTypeComponentCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { ItclComponent *icPtr; int result; ItclShowArgs(1, "Itcl_ClassTypeComponentCmd", objc, objv); result = ItclHandleClassComponent(clientData, interp, objc, objv, &icPtr); if (result != TCL_OK) { return result; } icPtr->ivPtr->flags |= ITCL_COMMON; return TCL_OK; } /* * ------------------------------------------------------------------------ * ItclCreateDelegatedFunction() * * Install a delegated function for a class * * ------------------------------------------------------------------------ */ int ItclCreateDelegatedFunction( Tcl_Interp *interp, ItclClass *iclsPtr, Tcl_Obj *methodNamePtr, ItclComponent *icPtr, Tcl_Obj *targetPtr, Tcl_Obj *usingPtr, Tcl_Obj *exceptionsPtr, ItclDelegatedFunction **idmPtrPtr) { ItclDelegatedFunction *idmPtr; const char **argv; int argc; int isNew; int i; idmPtr = (ItclDelegatedFunction *)ckalloc(sizeof(ItclDelegatedFunction)); memset(idmPtr, 0, sizeof(ItclDelegatedFunction)); Tcl_InitObjHashTable(&idmPtr->exceptions); idmPtr->namePtr = Tcl_NewStringObj(Tcl_GetString(methodNamePtr), -1); Tcl_IncrRefCount(idmPtr->namePtr); idmPtr->icPtr = icPtr; idmPtr->asPtr = targetPtr; if (idmPtr->asPtr != NULL) { Tcl_IncrRefCount(idmPtr->asPtr); } idmPtr->usingPtr = usingPtr; if (idmPtr->usingPtr != NULL) { Tcl_IncrRefCount(idmPtr->usingPtr); } if (exceptionsPtr != NULL) { if (Tcl_SplitList(interp, Tcl_GetString(exceptionsPtr), &argc, &argv) != TCL_OK) { return TCL_ERROR; } for(i = 0; i < argc; i++) { Tcl_Obj *objPtr; objPtr = Tcl_NewStringObj(argv[i], -1); Tcl_CreateHashEntry(&idmPtr->exceptions, (char *)objPtr, &isNew); } ckfree((char *) argv); } if (idmPtrPtr != NULL) { *idmPtrPtr = idmPtr; } ItclAddClassDelegatedFunctionDictInfo(interp, iclsPtr, idmPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_HandleDelegateMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate method" command is invoked to define a * Handles the following syntax: * * delegate method * * ------------------------------------------------------------------------ */ int Itcl_HandleDelegateMethodCmd( Tcl_Interp *interp, /* current interpreter */ ItclObject *ioPtr, /* != NULL for ::itcl::adddelegatedmethod otherwise NULL */ ItclClass *iclsPtr, /* != NULL for delegate method otherwise NULL */ ItclDelegatedFunction **idmPtrPtr, /* where to return idoPtr */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *methodNamePtr; Tcl_Obj *componentPtr; Tcl_Obj *targetPtr; Tcl_Obj *usingPtr; Tcl_Obj *exceptionsPtr; Tcl_HashEntry *hPtr; ItclClass *iclsPtr2; ItclComponent *icPtr; ItclHierIter hier; const char *usageStr; const char *methodName; const char *component; const char *token; int result; int i; int foundOpt; ItclShowArgs(1, "Itcl_HandleDelegateMethodCmd", objc, objv); usageStr = "delegate method to ?as ?\n\ delegate method ?to ? using \n\ delegate method * ?to ? ?using ? ?except ?"; if (objc < 4) { Tcl_AppendResult(interp, "wrong # args should be ", usageStr, NULL); return TCL_ERROR; } componentPtr = NULL; icPtr = NULL; methodName = Tcl_GetString(objv[1]); component = NULL; targetPtr = NULL; usingPtr = NULL; exceptionsPtr = NULL; for(i=2;iobjectDelegatedFunctions, (char *) methodNamePtr); } else { hPtr = Tcl_FindHashEntry(&iclsPtr->delegatedFunctions, (char *) methodNamePtr); } hPtr = NULL; if (ioPtr != NULL) { if (componentPtr != NULL) { Itcl_InitHierIter(&hier, ioPtr->iclsPtr); while ((iclsPtr = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); } } else { if (componentPtr != NULL) { iclsPtr2 = iclsPtr; Itcl_InitHierIter(&hier, iclsPtr2); while ((iclsPtr2 = Itcl_AdvanceHierIter(&hier)) != NULL) { hPtr = Tcl_FindHashEntry(&iclsPtr2->components, (char *)componentPtr); if (hPtr != NULL) { break; } } Itcl_DeleteHierIter(&hier); } } if (hPtr == NULL) { if (componentPtr != NULL) { if (ItclCreateComponent(interp, iclsPtr, componentPtr, ITCL_COMMON, &icPtr) != TCL_OK) { return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&iclsPtr->components, (char *)componentPtr); } } if (hPtr != NULL) { icPtr = (ItclComponent *)Tcl_GetHashValue(hPtr); } if (*methodName != '*') { /* FIXME !!! */ /* check for locally defined method */ hPtr = NULL; if (ioPtr != NULL) { } else { /* FIXME !! have to check the hierarchy !! */ hPtr = Tcl_FindHashEntry(&iclsPtr->functions, (char *)methodNamePtr); } if (hPtr != NULL) { Tcl_AppendResult(interp, "method \"", methodName, "\" has been defined locally", NULL); result = TCL_ERROR; goto errorOut; } } result = ItclCreateDelegatedFunction(interp, iclsPtr, methodNamePtr, icPtr, targetPtr, usingPtr, exceptionsPtr, idmPtrPtr); (*idmPtrPtr)->flags |= ITCL_METHOD; errorOut: Tcl_DecrRefCount(methodNamePtr); return result; } /* * ------------------------------------------------------------------------ * Itcl_ClassDelegateMethodCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate method" command is invoked to define a * Handles the following syntax: * * delegate method * * ------------------------------------------------------------------------ */ static int Itcl_ClassDelegateMethodCmd( ClientData clientData, /* info for all known objects */ Tcl_Interp *interp, /* current interpreter */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_HashEntry *hPtr; ItclObjectInfo *infoPtr; ItclClass *iclsPtr; ItclDelegatedFunction *idmPtr; int isNew; int result; ItclShowArgs(1, "Itcl_ClassDelegateMethodCmd", objc, objv); infoPtr = (ItclObjectInfo*)clientData; iclsPtr = (ItclClass*)Itcl_PeekStack(&infoPtr->clsStack); if (iclsPtr == NULL) { Tcl_AppendResult(interp, "Error: ::itcl::parser::delegatemethod called from", " not within a class", NULL); return TCL_ERROR; } if (iclsPtr->flags & ITCL_CLASS) { Tcl_AppendResult(interp, "\"", Tcl_GetString(iclsPtr->namePtr), " is no ::itcl::widget/::itcl::widgetadaptor/::itcl::type", "/::itcl::extendedclass.", " Only these can delegate methods", NULL); return TCL_ERROR; } result = Itcl_HandleDelegateMethodCmd(interp, NULL, iclsPtr, &idmPtr, objc, objv); if (result != TCL_OK) { return result; } idmPtr->flags |= ITCL_METHOD; hPtr = Tcl_CreateHashEntry(&iclsPtr->delegatedFunctions, (char *)idmPtr->namePtr, &isNew); Tcl_SetHashValue(hPtr, idmPtr); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_HandleDelegateOptionCmd() * * Invoked by Tcl during the parsing of a class definition whenever * the "delegate option" command is invoked to define a delegated option * or if ::itcl::adddelegatedoption is called with an itcl object * Handles the following syntax: * * delegate option ... * * ------------------------------------------------------------------------ */ int Itcl_HandleDelegateOptionCmd( Tcl_Interp *interp, /* current interpreter */ ItclObject *ioPtr, /* != NULL for ::itcl::adddelgatedoption otherwise NULL */ ItclClass *iclsPtr, /* != NULL for delegate option otherwise NULL */ ItclDelegatedOption **idoPtrPtr, /* where to return idoPtr */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { Tcl_Obj *allOptionNamePtr; Tcl_Obj *optionNamePtr; Tcl_Obj *componentPtr; Tcl_Obj *targetPtr; Tcl_Obj *exceptionsPtr; Tcl_Obj *resourceNamePtr; Tcl_Obj *classNamePtr; Tcl_HashEntry *hPtr; ItclComponent *icPtr; ItclClass *iclsPtr2; ItclDelegatedOption *idoPtr; ItclHierIter hier; const char *usageStr; const char *option; const char *component; const char *token; const char **argv; int foundOpt; int argc; int isStarOption; int isNew; int i; const char *cp; ItclShowArgs(1, "Itcl_HandleDelegatedOptionCmd", objc, objv); usageStr = " to ?as