itcl3.4.3/0000755003604700454610000000000012660706021010772 5ustar dgp771divitcl3.4.3/aclocal.m40000664003604700454610000000004212536627705012645 0ustar dgp771divbuiltin(include,tclconfig/tcl.m4) itcl3.4.3/Makefile.in0000664003604700454610000003543512536627705013070 0ustar dgp771div# Makefile.in -- # # This file is a Makefile for Sample TEA Extension. If it has the name # "Makefile.in" then it is a template for a Makefile; to generate the # actual Makefile, run "./configure", which is a configuration script # generated by the "autoconf" program (constructs like "@foo@" will get # replaced in the actual Makefile. # # Copyright (c) 1999 Scriptics Corporation. # Copyright (c) 2002-2004 ActiveState Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #======================================================================== # The names of the source files is defined in the configure script. # The object files are used for linking into the final library. # This will be used when a dist target is added to the Makefile. # It is not important to specify the directory, as long as it is the # $(srcdir) or in the generic, win or unix subdirectory. #======================================================================== PKG_SOURCES = @PKG_SOURCES@ PKG_OBJECTS = @PKG_OBJECTS@ PKG_STUB_SOURCES = @PKG_STUB_SOURCES@ PKG_STUB_OBJECTS = @PKG_STUB_OBJECTS@ #======================================================================== # PKG_TCL_SOURCES identifies Tcl runtime files that are associated with # this package that need to be installed, if any. #======================================================================== PKG_TCL_SOURCES = @PKG_TCL_SOURCES@ #======================================================================== # This is a list of header files to be installed # itk.h includes itclInt.h, which needs itclIntDecls.h, # so we must install them. #======================================================================== PKG_HEADERS = @PKG_HEADERS@ #======================================================================== # Nothing of the variables below this line need to be changed. Please # check the TARGETS section below to make sure the make targets are # correct. #======================================================================== #======================================================================== # Change the name of the variable "exampleA_LIB_FILE" to match the one # used in the configure script. This is the parameterized name of the # library that we are building. #======================================================================== PKG_LIB_FILE = @PKG_LIB_FILE@ PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@ lib_BINARIES = $(PKG_LIB_FILE) $(PKG_STUB_LIB_FILE) BINARIES = $(lib_BINARIES) SHELL = @SHELL@ srcdir = @srcdir@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ datadir = @datadir@ mandir = @mandir@ includedir = @includedir@ DESTDIR = PKG_DIR = $(PACKAGE_NAME)$(PACKAGE_VERSION) pkgdatadir = $(datadir)/$(PKG_DIR) pkglibdir = $(libdir)/$(PKG_DIR) pkgincludedir = $(includedir)/$(PKG_DIR) top_builddir = . INSTALL_OPTIONS = INSTALL = $(SHELL) $(srcdir)/tclconfig/install-sh -c ${INSTALL_OPTIONS} INSTALL_DATA_DIR = ${INSTALL} -d -m 755 INSTALL_PROGRAM = ${INSTALL} -m 755 INSTALL_DATA = ${INSTALL} -m 444 INSTALL_SCRIPT = ${INSTALL_PROGRAM} INSTALL_LIBRARY = ${INSTALL_DATA} PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ PACKAGE_PATCH_LEVEL = @itcl_PATCH_LEVEL@ CC = @CC@ CFLAGS_DEFAULT = @CFLAGS_DEFAULT@ CFLAGS_WARNING = @CFLAGS_WARNING@ CLEANFILES = @CLEANFILES@ EXEEXT = @EXEEXT@ LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ MAKE_LIB = @MAKE_LIB@ MAKE_SHARED_LIB = @MAKE_SHARED_LIB@ MAKE_STATIC_LIB = @MAKE_STATIC_LIB@ MAKE_STUB_LIB = @MAKE_STUB_LIB@ OBJEXT = @OBJEXT@ RANLIB = @RANLIB@ RANLIB_STUB = @RANLIB_STUB@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ STLIB_LD = @STLIB_LD@ TCL_DEFS = @TCL_DEFS@ TCL_BIN_DIR = @TCL_BIN_DIR@ TCL_SRC_DIR = @TCL_SRC_DIR@ # Not used, but retained for reference of what libs Tcl required TCL_LIBS = @TCL_LIBS@ #======================================================================== # TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our # package without installing. The other environment variables allow us # to test against an uninstalled Tcl. Add special env vars that you # require for testing here (like TCLX_LIBRARY). #======================================================================== EXTRA_PATH = $(top_builddir):$(TCL_BIN_DIR) PKG_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` \ ITCL_LIBRARY=`@CYGPATH@ $(srcdir)/library` \ @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \ PATH="$(EXTRA_PATH):$(PATH)" \ TCLLIBPATH="$(top_builddir)" TCLSH_PROG = @TCLSH_PROG@ TCLSH = $(PKG_ENV) $(TCLSH_PROG) SHARED_BUILD = @SHARED_BUILD@ INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ PKG_CFLAGS = @PKG_CFLAGS@ DEFS = @DEFS@ $(PKG_CFLAGS) \ -DITCL_LIBRARY=\"$(pkglibdir)\" CONFIG_CLEAN_FILES = @CONFIG_CLEAN_FILES@ Makefile itclConfig.sh pkgIndex.tcl CPPFLAGS = @CPPFLAGS@ LIBS = @PKG_LIBS@ @LIBS@ AR = @AR@ CFLAGS = @CFLAGS@ COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) #======================================================================== # Start of user-definable TARGETS section #======================================================================== #======================================================================== # TEA TARGETS. Please note that the "libraries:" target refers to platform # independent files, and the "binaries:" target inclues executable programs and # platform-dependent libraries. Modify these targets so that they install # the various pieces of your package. The make and install rules # for the BINARIES that you specified above have already been done. #======================================================================== all: binaries libraries doc #======================================================================== # The binaries target builds executable programs, Windows .dll's, unix # shared/static libraries, and any other platform-dependent files. # The list of targets to build for "binaries:" is specified at the top # of the Makefile, in the "BINARIES" variable. #======================================================================== binaries: $(BINARIES) libraries: doc: install: all install-binaries install-libraries install-doc install-binaries: binaries install-lib-binaries install-bin-binaries #======================================================================== # This rule installs platform-independent files, such as header files. #======================================================================== install-libraries: libraries @$(INSTALL_DATA_DIR) $(DESTDIR)$(includedir) @echo "Installing header files in $(DESTDIR)$(includedir)" @list='$(PKG_HEADERS)'; for i in $$list; do \ echo "Installing $(srcdir)/$$i" ; \ $(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir) ; \ done; #======================================================================== # Install documentation. Unix manpages should go in the $(mandir) # directory. #======================================================================== install-doc: doc @$(INSTALL_DATA_DIR) $(DESTDIR)$(mandir)/mann @echo "Installing man pages in $(DESTDIR)$(mandir)" @cd $(srcdir)/doc; for i in *.n; do \ echo "Installing $$i"; \ rm -f $(DESTDIR)$(mandir)/mann/`basename $$i`; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(DESTDIR)$(mandir)/mann/$$i; \ chmod 444 $(DESTDIR)$(mandir)/mann/$$i; \ done test: binaries libraries $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` -load "package require Itcl $(PACKAGE_VERSION)" $(TESTFLAGS) shell: binaries libraries @$(TCLSH) $(SCRIPT) gdb: $(PKG_ENV) gdb $(TCLSH_PROG) $(SCRIPT) VALGRINDARGS=--tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v valgrind: binaries libraries $(PKG_ENV) valgrind $(VALGRINDARGS) $(TCLSH_PROG) `@CYGPATH@ $(srcdir)/tests/all.tcl` -load "package require Itcl $(PACKAGE_VERSION)" $(TESTFLAGS) valgrindshell: binaries libraries $(PKG_ENV) valgrind $(VALGRINDARGS) $(TCLSH_PROG) $(SCRIPT) depend: #======================================================================== # $(PKG_LIB_FILE) should be listed as part of the BINARIES variable # mentioned above. That will ensure that this target is built when you # run "make binaries". # # The $(PKG_OBJECTS) objects are created and linked into the final # library. In most cases these object files will correspond to the # source files above. #======================================================================== $(PKG_LIB_FILE): $(PKG_OBJECTS) -rm -f $(PKG_LIB_FILE) ${MAKE_LIB} $(RANLIB) $(PKG_LIB_FILE) $(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS) -rm -f $(PKG_STUB_LIB_FILE) ${MAKE_STUB_LIB} $(RANLIB_STUB) $(PKG_STUB_LIB_FILE) #======================================================================== # We need to enumerate the list of .c to .o lines here. # # In the following lines, $(srcdir) refers to the toplevel directory # containing your extension. If your sources are in a subdirectory, # you will have to modify the paths to reflect this: # # exampleA.$(OBJEXT): $(srcdir)/generic/exampleA.c # $(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/exampleA.c` -o $@ # # Setting the VPATH variable to a list of paths will cause the makefile # to look into these paths when resolving .c to .obj dependencies. # As necessary, add $(srcdir):$(srcdir)/compat:.... #======================================================================== VPATH = $(srcdir)/unix:$(srcdir)/generic:$(srcdir)/win .c.$(OBJEXT): $(COMPILE) -c `@CYGPATH@ $<` -o $@ #======================================================================== # Distribution creation # You may need to tweak this target to make it work correctly. #======================================================================== TAR = tar RELEASE_DIR = $(PKG_DIR)$(PACKAGE_PATCH_LEVEL) #COMPRESS = tar cvf $(RELEASE_DIR).tar $(RELEASE_DIR); compress $(RELEASE_DIR).tar COMPRESS = $(TAR) zcvf $(RELEASE_DIR).tar.gz $(RELEASE_DIR) DIST_ROOT = /tmp/dist DIST_DIR = $(DIST_ROOT)/$(RELEASE_DIR) dist-clean: rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.* dist: dist-clean doc mkdir -p $(DIST_DIR) cp -p $(srcdir)/license* $(srcdir)/aclocal.m4 $(srcdir)/configure \ $(srcdir)/*.in $(DIST_DIR)/ chmod 664 $(DIST_DIR)/Makefile.in $(DIST_DIR)/aclocal.m4 chmod 775 $(DIST_DIR)/configure $(DIST_DIR)/configure.in mkdir $(DIST_DIR)/tclconfig cp $(srcdir)/tclconfig/install-sh $(srcdir)/tclconfig/tcl.m4 \ $(DIST_DIR)/tclconfig/ chmod 664 $(DIST_DIR)/tclconfig/tcl.m4 chmod +x $(DIST_DIR)/tclconfig/install-sh list='doc generic library tests win win/rc'; \ for p in $$list; do \ if test -d $(srcdir)/$$p ; then \ mkdir $(DIST_DIR)/$$p; \ for q in $(srcdir)/$$p/*; do \ if test -f $$q ; then \ cp -p $$q $(DIST_DIR)/$$p/; \ fi; \ done; \ fi; \ done list='CHANGES ChangeLog INCOMPATIBLE README TODO'; \ for p in $$list; do \ if test -f $(srcdir)/../$$p ; then \ cp -p $(srcdir)/../$$p $(DIST_DIR)/; \ fi; \ done (cd $(DIST_ROOT); $(COMPRESS);) #======================================================================== # End of user-definable section #======================================================================== #======================================================================== # Don't modify the file to clean here. Instead, set the "CLEANFILES" # variable in configure.in #======================================================================== clean: -test -z "$(BINARIES)" || rm -f $(BINARIES) -rm -f *.o core *.core -rm -f *.$(OBJEXT) -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES) distclean: clean -rm -f *.tab.c -rm -f $(CONFIG_CLEAN_FILES) -rm -f config.cache config.log config.status #======================================================================== # Install binary object libraries. On Windows this includes both .dll and # .lib files. Because the .lib files are not explicitly listed anywhere, # we need to deduce their existence from the .dll file of the same name. # Additionally, the .dll files go into the bin directory, but the .lib # files go into the lib directory. On Unix platforms, all library files # go into the lib directory. In addition, this will generate the pkgIndex.tcl # file in the install location (assuming it can find a usable tclsh8.2 shell) # # You should not have to modify this target. #======================================================================== install-lib-binaries: @$(INSTALL_DATA_DIR) $(DESTDIR)$(pkglibdir) @list='$(lib_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p"; \ $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p; \ stub=`echo $$p|sed -e "s/.*\(stub\).*/\1/"`; \ if test "x$$stub" = "xstub"; then \ echo " $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB_STUB) $(DESTDIR)$(pkglibdir)/$$p; \ else \ echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \ $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p; \ fi; \ ext=`echo $$p|sed -e "s/.*\.//"`; \ if test "x$$ext" = "xdll"; then \ lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ if test -f $$lib; then \ echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \ $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib; \ fi; \ fi; \ fi; \ done @list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ if test -f $(srcdir)/$$p; then \ destp=`basename $$p`; \ echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \ $(INSTALL_DATA) $(srcdir)/$$p $(DESTDIR)$(pkglibdir)/$$destp; \ fi; \ done $(INSTALL_DATA) pkgIndex.tcl $(DESTDIR)$(pkglibdir) $(INSTALL_DATA) itclConfig.sh $(DESTDIR)$(libdir) #======================================================================== # Install binary executables (e.g. .exe files) # # You should not have to modify this target. #======================================================================== install-bin-binaries: @$(INSTALL_DATA_DIR) $(DESTDIR)$(bindir) @list='$(bin_BINARIES)'; for p in $$list; do \ if test -f $$p; then \ echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \ $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p; \ fi; \ done .SUFFIXES: .c .$(OBJEXT) #Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status # cd $(top_builddir) \ # && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status uninstall-binaries: list='$(lib_BINARIES)'; for p in $$list; do \ rm -f $(DESTDIR)$(pkglibdir)/$$p; \ done list='$(PKG_TCL_SOURCES)'; for p in $$list; do \ p=`basename $$p`; \ rm -f $(DESTDIR)$(pkglibdir)/$$p; \ done list='$(bin_BINARIES)'; for p in $$list; do \ rm -f $(DESTDIR)$(bindir)/$$p; \ done .PHONY: all binaries clean depend distclean doc install libraries test # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: itcl3.4.3/tests/0000755003604700454610000000000012660706021012134 5ustar dgp771divitcl3.4.3/tests/mkindex.test0000644003604700454610000000425712536627705014521 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 ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # 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}" ::tcltest::removeFile tclIndex ::tcltest::cleanupTests return itcl3.4.3/tests/delete.test0000644003604700454610000001670612632330731014311 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.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # 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} { set obj [test_delete #auto -x "data stays"] list [$obj killme {return $x}] [itcl::find objects -isa test_delete] } {{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}} 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 itcl3.4.3/tests/interp.test0000644003604700454610000000510612536627705014355 0ustar dgp771div# # Tests for using [incr Tcl] in slave interpreters # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # Bell Labs Innovations for Lucent Technologies # mmclennan@lucent.com # http://www.tcltk.com/itcl # ---------------------------------------------------------------------- # Copyright (c) 1993-1998 Lucent Technologies, Inc. # ====================================================================== # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Make sure that slave interpreters can be created and loaded # with [incr Tcl]... # ---------------------------------------------------------------------- test interp-1.1 {create a slave interp with [incr Tcl]} { interp create slave load "" Itcl slave list [slave eval "namespace children :: itcl"] [interp delete slave] } {::itcl {}} test interp-1.2 {create a safe slave interp with [incr Tcl]} { interp create -safe slave load "" Itcl slave list [slave eval "namespace children :: itcl"] [interp delete slave] } {::itcl {}} test interp-1.3 {errors are okay when slave interp is deleted} { interp create slave load "" Itcl slave slave eval { itcl::class Troublemaker { destructor { error "cannot delete this object" } } itcl::class Foo { variable obj "" constructor {} { set obj [Troublemaker #auto] } destructor { delete object $obj } } Foo f } interp delete slave } {} test interp-1.4 {one namespace can cause another to be destroyed} { interp create slave load "" Itcl slave slave eval { namespace eval group { itcl::class base1 {} itcl::class base2 {} } itcl::class TroubleMaker { inherit group::base1 group::base2 } } interp delete slave } {} test interp-1.5 {cleanup interp object list, this should not include an object that deletes itself in ctor} { interp create slave load "" Itcl slave slave eval { itcl::class DeleteSelf { constructor {} { itcl::delete object $this } } DeleteSelf ds } interp delete slave } {} ::tcltest::cleanupTests return itcl3.4.3/tests/scope.test0000644003604700454610000002175212536627705014172 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 # ---------------------------------------------------------------------- # 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} { list [test_scope0 mcontext itcl::scope priv] \ [test_scope::pcontext itcl::scope pric] } {{@itcl ::test_scope0 ::test_scope::priv} ::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 [$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} { 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 } {0 {@itcl ::test_scope0 ::test_scope::varray(0)} 0 {@itcl ::test_scope0 ::test_scope::varray(1)} 0 ::test_scope::carray(0) 0 ::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 ::tcltest::cleanupTests return itcl3.4.3/tests/tclIndex0000644003604700454610000000270412435166633013645 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]] itcl3.4.3/tests/methods.test0000644003604700454610000001262712536627705014525 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 # ---------------------------------------------------------------------- # Methods with various argument lists # ---------------------------------------------------------------------- test methods-1.1 {define a class with lots of methods and arg lists} { itcl::class test_args { method none {} { return "none" } method two {x y} { return "two: $x $y" } method defvals {x {y def1} {z def2}} { return "defvals: $x $y $z" } method varargs {x {y def1} args} { return "varargs: $x $y ($args)" } method nomagic {args x} { return "nomagic: $args $x" } method clash {x bang boom} { return "clash: $x $bang $boom" } method clash_time {x bang boom} { time {set result "clash_time: $x $bang $boom"} 1 return $result } proc crash {x bang boom} { return "crash: $x $bang $boom" } proc crash_time {x bang boom} { time {set result "crash_time: $x $bang $boom"} 1 return $result } variable bang "ok" common boom "no-problem" } } "" test methods-1.2 {create an object to execute tests} { test_args ta } {ta} test methods-1.3 {argument checking: not enough args} { list [catch {ta two 1} msg] $msg } {1 {wrong # args: should be "ta two x y"}} test methods-1.4a {argument checking: too many args} { list [catch {ta two 1 2 3} msg] $msg } {1 {wrong # args: should be "ta two x y"}} test methods-1.4b {argument checking: too many args} { list [catch {ta none 1 2 3} msg] $msg } {1 {wrong # args: should be "ta none"}} test methods-1.5a {argument checking: just right} { list [catch {ta two 1 2} msg] $msg } {0 {two: 1 2}} test methods-1.5b {argument checking: just right} { list [catch {ta none} msg] $msg } {0 none} test methods-1.6a {default arguments: not enough args} { list [catch {ta defvals} msg] $msg } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} test methods-1.6b {default arguments: missing arguments supplied} { list [catch {ta defvals 1} msg] $msg } {0 {defvals: 1 def1 def2}} test methods-1.6c {default arguments: missing arguments supplied} { list [catch {ta defvals 1 2} msg] $msg } {0 {defvals: 1 2 def2}} test methods-1.6d {default arguments: all arguments assigned} { list [catch {ta defvals 1 2 3} msg] $msg } {0 {defvals: 1 2 3}} test methods-1.6e {default arguments: too many args} { list [catch {ta defvals 1 2 3 4} msg] $msg } {1 {wrong # args: should be "ta defvals x ?y? ?z?"}} test methods-1.7a {variable arguments: not enough args} { list [catch {ta varargs} msg] $msg } {1 {wrong # args: should be "ta varargs x ?y? ?arg arg ...?"}} test methods-1.7b {variable arguments: empty} { list [catch {ta varargs 1 2} msg] $msg } {0 {varargs: 1 2 ()}} test methods-1.7c {variable arguments: one} { list [catch {ta varargs 1 2 one} msg] $msg } {0 {varargs: 1 2 (one)}} test methods-1.7d {variable arguments: two} { list [catch {ta varargs 1 2 one two} msg] $msg } {0 {varargs: 1 2 (one two)}} test methods-1.8 {magic "args" argument has no magic unless at end of list} { list [catch {ta nomagic 1 2 3 4} msg] $msg } {1 {wrong # args: should be "ta nomagic args x"}} test methods-1.9 {formal args don't clobber class members} { list [catch {ta clash 1 2 3} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {clash: 1 2 3} ok no-problem} test methods-1.10 {formal args don't clobber class members} { list [catch {test_args::crash 4 5 6} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {crash: 4 5 6} ok no-problem} test methods-1.11 {formal args don't clobber class members, even in "time"} { list [catch {ta clash_time 7 8 9} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {clash_time: 7 8 9} ok no-problem} test methods-1.12 {formal args don't clobber class members, even in "time"} { list [catch {test_args::crash_time a b c} msg] $msg \ [ta info variable bang -value] \ [ta info variable boom -value] } {0 {crash_time: a b c} ok no-problem} test methods-2.1 {covers leak condition test for compiled locals, no args} { for {set i 0} {$i < 100} {incr i} { ::itcl::class LeakClass { proc leakProc {} { set n 1 } } LeakClass::leakProc ::itcl::delete class LeakClass } list 0 } 0 # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_args ::tcltest::cleanupTests return itcl3.4.3/tests/namespace.test0000644003604700454610000000626412536627705015016 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.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Classes within namespaces # ---------------------------------------------------------------------- test namespace-1.1 {same class name can be used in different namespaces} { 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 } } } "" test namespace-1.2 {classes in different namespaces are different} { list [namespace eval test_ns_1::Counter {info variable tag}] \ [namespace eval test_ns_2::Counter {info variable tag}] \ } {{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} { namespace eval test_ns_1 { list [Counter c] [c ++] [c ++] [c ++] [c ++] } } {c 1 2 3 4} test namespace-1.4 {create an object in another namespace} { namespace eval test_ns_2 { list [Counter c] [c ++] [c ++] [c ++] [c ++] } } {c 1 2 4 8} test namespace-1.5 {can find classes wrapped in a namespace} { 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 } {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} { list [catch {namespace eval test_ns_1 {Counter exists}} msg] $msg } {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} { 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}] } {0 lreplace 0 ::test_ns_1::lreplace ::test_ns_1::lreplace} namespace delete test_ns_1 test_ns_2 ::tcltest::cleanupTests return itcl3.4.3/tests/import.test0000644003604700454610000001320212536627705014362 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.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # 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 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 [subst -novariables { [::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 [subst -novariables { [::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} { $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] } } {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 { 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} catch {interp delete $interp} ::tcltest::cleanupTests return itcl3.4.3/tests/info.test0000644003604700454610000003511412632344510013774 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.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # 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? ...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? ...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} { 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] \ } {public variable ::test_info::pubv public {set pubv "public: $pubv"} new-public} 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} { 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] \ } {protected variable ::test_info::prov protected new-protected} 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} { 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] \ } {private variable ::test_info::priv private new-private} 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] \ } {public common ::test_info::pubc public new-public} 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] \ } {protected common ::test_info::proc protected new-protected} 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] \ } {private common ::test_info::pric private new-private} 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, or -value}} # ---------------------------------------------------------------------- # 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.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.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} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_info test_info_base ::tcltest::cleanupTests return itcl3.4.3/tests/protection.test0000644003604700454610000003404112536627705015242 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 # ---------------------------------------------------------------------- # 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 itcl3.4.3/tests/basic.test0000644003604700454610000003035612632344510014125 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.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands test basic-1.0 {empty string as class name should fail but not crash} { list [catch {itcl::class "" {}} err] $err } {1 {invalid class name ""}} # ---------------------------------------------------------------------- # Simple class definition # ---------------------------------------------------------------------- test basic-1.1 {define a simple class} { itcl::class Counter { constructor {args} { incr num eval configure $args } destructor { incr num -1 } method ++ {} { return [incr val $by] } proc num {} { return $num } public variable by 1 protected variable val 0 private common num 0 } } "" test basic-1.2 {class is now defined} { itcl::find classes Counter } {Counter} test basic-1.3 {access command exists with class name} { namespace which -command Counter } {::Counter} test basic-1.4 {create a simple object} { Counter x } {x} test basic-1.5a {object names cannot be duplicated} { list [catch "Counter x" msg] $msg } {1 {command "x" already exists in namespace "::"}} test basic-1.5b {built-in commands cannot be clobbered} { list [catch "Counter info" msg] $msg } {1 {command "info" already exists in namespace "::"}} test basic-1.6 {objects have an access command} { namespace which -command x } {::x} test basic-1.7a {objects are added to the master list} { itcl::find objects x } {x} test basic-1.7b {objects are added to the master list} { itcl::find objects -class Counter x } {x} test basic-1.8 {objects can be deleted} { list [itcl::delete object x] [namespace which -command x] } {{} {}} test basic-1.9 {objects can be recreated with the same name} { Counter x } {x} test basic-1.10 {objects can be destroyed by deleting their access command} { rename ::x "" itcl::find objects x } {} test basic-1.11 {find command supports object names starting with -} { Counter -foo itcl::find objects -class Counter -foo } {-foo} test basic-1.12 {is command with class argument} { itcl::is class Counter } {1} test basic-1.13 {is command with class argument (global namespace)} { itcl::is class ::Counter } {1} test basic-1.14 {is command with class argument (wrapped in code command)} { itcl::is class [itcl::code Counter] } {1} test basic-1.15 {is command with class argument (class does not exist)} { itcl::is class Count } {0} test basic-1.16 {is command with object argument} { itcl::is object -foo } {1} test basic-1.17 {is command with object argument (object does not exist)} { itcl::is object xxx } {0} test basic-1.18 {is command with object argument (with code command)} { itcl::is object [itcl::code -- -foo] } {1} test basic-1.19 {classes can be unicode} { itcl::class \u6210bcd { method foo args { return "bar" } } \u6210bcd #auto } \u6210bcd0 test basic-1.20 {classes can be unicode} { \u6210bcd0 foo } bar test basic-1.21 {Bug 2e0e27de5f} -setup { itcl::class Object { public variable n {} constructor {} {set n test} {} } } -body { Object foo } -cleanup { itcl::delete class Object } -result foo # ---------------------------------------------------------------------- # #auto names # ---------------------------------------------------------------------- test basic-2.1 {create an object with an automatic name} { Counter #auto } {counter0} test basic-2.2 {bury "#auto" within object name} { Counter x#autoy } {xcounter1y} test basic-2.3 {bury "#auto" within object name} { Counter a#aut#autob } {a#autcounter2b} test basic-2.4 {"#auto" is smart enough to skip names that are taken} { Counter counter3 Counter #auto } {counter4} test basic-2.5 {"#auto" with :: at front of name} { itcl::class AutoCheck {} set result [AutoCheck ::#auto] rename AutoCheck {} set result } {::autoCheck0} test basic-2.6 {"#auto" with :: at front of name inside method} { itcl::class AutoCheck { proc new {} { return [AutoCheck ::#auto] } } set result [AutoCheck::new] rename AutoCheck {} set result } {::autoCheck0} test basic-2.7 {"#auto" with :: at front of name inside method inside namespace} { namespace eval AutoCheckNs {} itcl::class AutoCheckNs::AutoCheck { proc new {} { return [AutoCheckNs::AutoCheck ::#auto] } } set result [AutoCheckNs::AutoCheck::new] namespace delete AutoCheckNs set result } {::autoCheck0} # ---------------------------------------------------------------------- # Simple object use # ---------------------------------------------------------------------- test basic-3.1 {object access command works} { Counter c list [c ++] [c ++] [c ++] } {1 2 3} test basic-3.2 {errors produce usage info} { list [catch "c xyzzy" msg] $msg } {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} { c configure } {{-by 1 1}} test basic-3.4 {built-in configure can query one public variable} { c configure -by } {-by 1 1} test basic-3.5 {built-in configure can set public variable} { list [c configure -by 2] [c cget -by] } {{} 2} test basic-3.6 {configure actually changes public variable} { list [c ++] [c ++] } {5 7} test basic-3.7 {class procs can be accessed} { Counter::num } {7} test basic-3.8 {obsolete syntax is no longer allowed} { list [catch "Counter :: num" msg] $msg } {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} { list [itcl::delete class Counter] \ [itcl::find classes Counter] \ [namespace children :: Counter] \ [namespace which -command Counter] } {{} {} {} {}} test basic-4.2 {classes can be redefined} { itcl::class Counter { method ++ {} { return [incr val $by] } public variable by 1 protected variable val 0 } } {} test basic-4.3 {the redefined class is actually different} { list [catch "Counter::num" msg] $msg } {1 {invalid command name "Counter::num"}} test basic-4.4 {objects can be created from the new class} { list [Counter #auto] [Counter #auto] } {counter0 counter1} test basic-4.5 {namespaces for #auto are prepended to the command name} { namespace eval someNS1 {} namespace eval someNS2 {} list [Counter someNS1::#auto] [Counter someNS2::#auto] } [list someNS1::counter2 someNS2::counter3] test basic-4.6 {when a class is destroyed, its objects are deleted} { list [lsort [itcl::find objects counter*]] \ [itcl::delete class Counter] \ [lsort [itcl::find objects counter*]] } {{counter0 counter1} {} {}} # ---------------------------------------------------------------------- # Namespace variables # ---------------------------------------------------------------------- test basic-5.1 {define a simple class with variables in the namespace} { 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" } } "" test basic-5.2 {create an object for the tests} { test_globals #auto } {test_globals0} test basic-5.3 {common variables live in the namespace} { lsort [info vars ::test_globals::*] } {::test_globals::g1 ::test_globals::g2} test basic-5.4 {common variables can be referenced transparently} { list [catch {test_globals0 do set g1} msg] $msg } {0 global1} test basic-5.5 {namespace variables require a declaration} { list [catch {test_globals0 do set g2} msg] $msg } {1 {can't read "g2": no such variable}} test basic-5.6a {variable accesses variables within namespace} { list [catch {test_globals::getval g1} msg] $msg } {0 global1} test basic-5.6b {variable accesses variables within namespace} { list [catch {test_globals::getval g2} msg] $msg } {0 global2} test basic-5.7 {variable command will not find vars in other namespaces} { set ::test_global_0 "g0" list [catch {test_globals::getval test_global_0} msg] $msg \ [catch {test_globals::getval ::test_global_0} msg] $msg \ } {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} { test_globals::setval ::test_global_1 g1 namespace eval :: {lsort [info globals test_global_*]} } {test_global_0 test_global_1} test basic-5.9 {variable names can have ":" in them} { test_globals::setval ::test:global:2 g2 namespace eval :: {info globals test:global:2} } {test:global:2} # ---------------------------------------------------------------------- # Array variables # ---------------------------------------------------------------------- test basic-6.1 {set up a class definition with array variables} { 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 } {test_arrays0} test basic-6.2 {test array access for instance variables} { lsort [test_arrays0 do array get nums] } {1 2 3 one three two} test basic-6.3 {test array access for commons} { lsort [test_arrays0 do array get colors] } [list #0000ff #00ff00 #ff0000 blue green red] test basic-6.4 {test array access for instance variables via "upvar"} { test_arrays0 do test_arrays_get nums } {{one 1} {three 3} {two 2}} test basic-6.5 {test array access for commons via "upvar"} { test_arrays0 do test_arrays_get colors } {{blue #0000ff} {green #00ff00} {red #ff0000}} test basic-6.6a {test array access for commons defined in constructor} { lsort [test_arrays0 do array get undefined] } {A B a b} test basic-6.6b {test array access for commons defined in constructor} { test_arrays0 do test_arrays_get undefined } {{a A} {b B}} test basic-6.6c {test array access for commons defined in constructor} { list [test_arrays0 do set undefined(a)] [test_arrays0 do set undefined(b)] } {A B} test basic-6.7 {common variables can be unset} { test_arrays0 do unset undefined test_arrays0 do array names undefined } {} test basic-6.8 {common variables can be redefined} { test_arrays0 do set undefined "scalar" } {scalar} test basic-7.0 {SF Bug 230} -setup { itcl::class Dog { method bark {} } itcl::body Dog::bark {} { variable bite set bite ouch } } -body { Dog fido fido bark } -cleanup { itcl::delete class Dog } -result ouch ::tcltest::cleanupTests return itcl3.4.3/tests/inherit.test0000644003604700454610000005241712536627705014525 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 # ---------------------------------------------------------------------- # 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} { 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 "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} { 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"}} # ---------------------------------------------------------------------- # 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 itcl3.4.3/tests/ensemble.test0000644003604700454610000001402512536627705014646 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 Tcl 8.4 package require tcltest 2.1 namespace import ::tcltest::test ::tcltest::loadTestedCommands 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} -body { list [catch "itcl::ensemble test_numbers {part foo {{}} {}}" msg] $msg $errorInfo } -match glob -result {1 {*argument with no name} {*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 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 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 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}} ::tcltest::cleanupTests return itcl3.4.3/tests/local.test0000644003604700454610000000427712536627705014156 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 # ---------------------------------------------------------------------- # 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 itcl3.4.3/tests/body.test0000644003604700454610000002152312536627705014012 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 # ---------------------------------------------------------------------- # 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"}} # ---------------------------------------------------------------------- # 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"}} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_body test_cbody ::tcltest::cleanupTests return itcl3.4.3/tests/mkindex.itcl0000644003604700454610000000367611555565627014505 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 { } } } itcl3.4.3/tests/all.tcl0000755003604700454610000000056412536627705013435 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. package require Tcl 8.4 package require tcltest 2.1 tcltest::testsDirectory [file dir [info script]] tcltest::runAllTests return itcl3.4.3/tests/chain.test0000644003604700454610000001176512536627705014146 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 # ---------------------------------------------------------------------- # 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}} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a ::tcltest::cleanupTests return itcl3.4.3/library/0000755003604700454610000000000012660706021012436 5ustar dgp771divitcl3.4.3/library/itcl.tcl0000644003604700454610000002165212536627705014120 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} { 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 } } # ---------------------------------------------------------------------- # 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 } } } } # ---------------------------------------------------------------------- # itcl_class, itcl_info # ---------------------------------------------------------------------- # Compat handling for itcl_class/info, set for auto_index loading only # # Only need to convert public/protected usage. # Uses Tcl 8.4+ coding style # if {([llength [info commands itcl_class]] == 0) && [package vsatisfies $::tcl_version 8.4]} { proc ::itcl::CmdSplit {body} { # DGP's command split set commands {} set chunk "" foreach line [split $body "\n"] { append chunk $line if {[info complete "$chunk\n"]} { # $chunk ends in a complete Tcl command, and none of the # newlines within it end a complete Tcl command. If there # are multiple Tcl commands in $chunk, they must be # separated by semi-colons. set cmd "" foreach part [split $chunk ";"] { append cmd $part if {[info complete "$cmd\n"]} { set cmd [string trimleft $cmd] # Drop empty commands and comments if {($cmd ne "") && ![string match #* $cmd]} { lappend commands $cmd } if {[string match #* $cmd]} { set cmd "#;" } else { set cmd "" } } else { # No complete command yet. # Replace semicolon and continue append cmd ";" } } set chunk "" } else { # No end of command yet. Put the newline back and continue append chunk "\n" } } if {[string trim $chunk] ne ""} { return -code error "Can't parse body into a\ sequence of commands.\n\tIncomplete command:\n$chunk" } return $commands } proc ::itcl::itcl_class {className body} { # inherit baseClass ?baseClass...? ; # no change # constructor args ?init? body ; # no change # destructor body ; # no change # method name args body ; # no change # proc name args body ; # no change # common varName ?init? ; # no change # public varName ?init? ?config? ; # variable ... # protected varName ?init? ; # variable ... (?) set cmds [::itcl::CmdSplit $body] set newcmds [list] foreach cmd $cmds { if {![catch {lindex $cmd 0} firstcmd]} { if {$firstcmd eq "public" || $firstcmd eq "protected"} { set cmd [linsert $cmd 1 "variable"] } } append newcmds "$cmd\n" } return [uplevel 1 [list ::itcl::class $className $newcmds]] } set ::auto_index(itcl_class) [list interp alias {} ::itcl_class {} ::itcl::itcl_class] set ::auto_index(itcl_info) [list interp alias {} ::itcl_info {} ::itcl::find] } # ---------------------------------------------------------------------- # [namespace inscope] # ---------------------------------------------------------------------- # Modify [unknown] to handle Itcl's usage of [namespace inscope] # namespace eval ::itcl { variable UNKNOWN_ADD_84 { ####################################################################### # ADDED BY Itcl # Itcl requires special handling for [namespace inscope] # set cmd [lindex $args 0] if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { set arglist [lrange $args 1 end] set ret [catch {uplevel 1 ::$cmd $arglist} result] if {$ret == 0} { return $result } else { return -code $ret -errorcode $::errorCode $result } } ####################################################################### } variable UNKNOWN_ADD_85 { ####################################################################### # ADDED BY Itcl # Itcl requires special handling for [namespace inscope] # set cmd [lindex $args 0] if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { #return -code error "You need an {*}" set arglist [lrange $args 1 end] set ret [catch {uplevel 1 ::$cmd $arglist} result opts] dict unset opts -errorinfo dict incr opts -level return -options $opts $result } ####################################################################### } if {[package vsatisfies [package provide Tcl] 8.5]} { proc ::unknown args "$UNKNOWN_ADD_85\n[info body ::unknown]" } else { proc ::unknown args "$UNKNOWN_ADD_84\n[info body ::unknown]" } } itcl3.4.3/generic/0000755003604700454610000000000012660706021012406 5ustar dgp771divitcl3.4.3/generic/itcl_linkage.c0000644003604700454610000002762212536627705015225 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: 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" /* * These records store the pointers for all "RegisterC" functions. */ typedef struct ItclCfunc { Tcl_CmdProc *argCmdProc; /* old-style (argc,argv) command handler */ Tcl_ObjCmdProc *objCmdProc; /* new (objc,objv) command handler */ ClientData clientData; /* client data passed into this function */ Tcl_CmdDeleteProc *deleteProc; /* proc called to free clientData */ } ItclCfunc; static Tcl_HashTable* ItclGetRegisteredProcs _ANSI_ARGS_((Tcl_Interp *interp)); static void ItclFreeC _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); /* * ------------------------------------------------------------------------ * Itcl_RegisterC() * * Used to associate a symbolic name with an (argc,argv) C procedure * that handles a Tcl command. Procedures that are registered in this * manner can be referenced in the body of an [incr Tcl] class * definition to specify C procedures to acting as methods/procs. * Usually invoked in an initialization routine for an extension, * called out in Tcl_AppInit() at the start of an application. * * Each symbolic procedure can have an arbitrary client data value * associated with it. This value is passed into the command * handler whenever it is invoked. * * A symbolic procedure name can be used only once for a given style * (arg/obj) handler. If the name is defined with an arg-style * handler, it can be redefined with an obj-style handler; or if * the name is defined with an obj-style handler, it can be redefined * with an arg-style handler. In either case, any previous client * data is discarded and the new client data is remembered. However, * if a name is redefined to a different handler of the same style, * this procedure returns an error. * * Returns TCL_OK on success, or TCL_ERROR (along with an error message * in interp->result) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_RegisterC(interp, name, proc, clientData, deleteProc) Tcl_Interp *interp; /* interpreter handling this registration */ CONST char *name; /* symbolic name for procedure */ Tcl_CmdProc *proc; /* procedure handling Tcl command */ ClientData clientData; /* client data associated with proc */ Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ { int newEntry; Tcl_HashEntry *entry; Tcl_HashTable *procTable; ItclCfunc *cfunc; /* * Make sure that a proc was specified. */ if (!proc) { Tcl_AppendResult(interp, "initialization error: null pointer for ", "C procedure \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Add a new entry for the given procedure. If an entry with * this name already exists, then make sure that it was defined * with the same proc. */ procTable = ItclGetRegisteredProcs(interp); entry = Tcl_CreateHashEntry(procTable, name, &newEntry); if (!newEntry) { cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); if (cfunc->argCmdProc != NULL && cfunc->argCmdProc != proc) { Tcl_AppendResult(interp, "initialization error: C procedure ", "with name \"", name, "\" already defined", (char*)NULL); return TCL_ERROR; } if (cfunc->deleteProc != NULL) { (*cfunc->deleteProc)(cfunc->clientData); } } else { cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); cfunc->objCmdProc = NULL; } cfunc->argCmdProc = proc; cfunc->clientData = clientData; cfunc->deleteProc = deleteProc; Tcl_SetHashValue(entry, (ClientData)cfunc); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_RegisterObjC() * * Used to associate a symbolic name with an (objc,objv) C procedure * that handles a Tcl command. Procedures that are registered in this * manner can be referenced in the body of an [incr Tcl] class * definition to specify C procedures to acting as methods/procs. * Usually invoked in an initialization routine for an extension, * called out in Tcl_AppInit() at the start of an application. * * Each symbolic procedure can have an arbitrary client data value * associated with it. This value is passed into the command * handler whenever it is invoked. * * A symbolic procedure name can be used only once for a given style * (arg/obj) handler. If the name is defined with an arg-style * handler, it can be redefined with an obj-style handler; or if * the name is defined with an obj-style handler, it can be redefined * with an arg-style handler. In either case, any previous client * data is discarded and the new client data is remembered. However, * if a name is redefined to a different handler of the same style, * this procedure returns an error. * * Returns TCL_OK on success, or TCL_ERROR (along with an error message * in interp->result) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_RegisterObjC(interp, name, proc, clientData, deleteProc) Tcl_Interp *interp; /* interpreter handling this registration */ CONST char *name; /* symbolic name for procedure */ Tcl_ObjCmdProc *proc; /* procedure handling Tcl command */ ClientData clientData; /* client data associated with proc */ Tcl_CmdDeleteProc *deleteProc; /* proc called to free up client data */ { int newEntry; Tcl_HashEntry *entry; Tcl_HashTable *procTable; ItclCfunc *cfunc; /* * Make sure that a proc was specified. */ if (!proc) { Tcl_AppendResult(interp, "initialization error: null pointer for ", "C procedure \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Add a new entry for the given procedure. If an entry with * this name already exists, then make sure that it was defined * with the same proc. */ procTable = ItclGetRegisteredProcs(interp); entry = Tcl_CreateHashEntry(procTable, name, &newEntry); if (!newEntry) { cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); if (cfunc->objCmdProc != NULL && cfunc->objCmdProc != proc) { Tcl_AppendResult(interp, "initialization error: C procedure ", "with name \"", name, "\" already defined", (char*)NULL); return TCL_ERROR; } if (cfunc->deleteProc != NULL) { (*cfunc->deleteProc)(cfunc->clientData); } } else { cfunc = (ItclCfunc*)ckalloc(sizeof(ItclCfunc)); cfunc->argCmdProc = NULL; } cfunc->objCmdProc = proc; cfunc->clientData = clientData; cfunc->deleteProc = deleteProc; Tcl_SetHashValue(entry, (ClientData)cfunc); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_FindC() * * Used to query a C procedure via its symbolic name. Looks at the * list of procedures registered previously by either Itcl_RegisterC * or Itcl_RegisterObjC and returns pointers to the appropriate * (argc,argv) or (objc,objv) handlers. Returns non-zero if the * name is recognized and pointers are returned; returns zero * otherwise. * ------------------------------------------------------------------------ */ int Itcl_FindC(interp, name, argProcPtr, objProcPtr, cDataPtr) Tcl_Interp *interp; /* interpreter handling this registration */ CONST char *name; /* symbolic name for procedure */ Tcl_CmdProc **argProcPtr; /* returns (argc,argv) command handler */ Tcl_ObjCmdProc **objProcPtr; /* returns (objc,objv) command handler */ ClientData *cDataPtr; /* returns client data */ { Tcl_HashEntry *entry; Tcl_HashTable *procTable; ItclCfunc *cfunc; *argProcPtr = NULL; /* assume info won't be found */ *objProcPtr = NULL; *cDataPtr = NULL; if (interp) { procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC", (Tcl_InterpDeleteProc**)NULL); if (procTable) { entry = Tcl_FindHashEntry(procTable, name); if (entry) { cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); *argProcPtr = cfunc->argCmdProc; *objProcPtr = cfunc->objCmdProc; *cDataPtr = cfunc->clientData; } } } return (*argProcPtr != NULL || *objProcPtr != NULL); } /* * ------------------------------------------------------------------------ * ItclGetRegisteredProcs() * * Returns a pointer to a hash table containing the list of registered * procs in the specified interpreter. If the hash table does not * already exist, it is created. * ------------------------------------------------------------------------ */ static Tcl_HashTable* ItclGetRegisteredProcs(interp) Tcl_Interp *interp; /* interpreter handling this registration */ { Tcl_HashTable* procTable; /* * If the registration table does not yet exist, then create it. */ procTable = (Tcl_HashTable*)Tcl_GetAssocData(interp, "itcl_RegC", (Tcl_InterpDeleteProc**)NULL); if (!procTable) { procTable = (Tcl_HashTable*)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(procTable, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "itcl_RegC", ItclFreeC, (ClientData)procTable); } return procTable; } /* * ------------------------------------------------------------------------ * ItclFreeC() * * When an interpreter is deleted, this procedure is called to * free up the associated data created by Itcl_RegisterC and * Itcl_RegisterObjC. * ------------------------------------------------------------------------ */ static void ItclFreeC(clientData, interp) ClientData clientData; /* associated data */ Tcl_Interp *interp; /* intepreter being deleted */ { Tcl_HashTable *tablePtr = (Tcl_HashTable*)clientData; Tcl_HashSearch place; Tcl_HashEntry *entry; ItclCfunc *cfunc; entry = Tcl_FirstHashEntry(tablePtr, &place); while (entry) { cfunc = (ItclCfunc*)Tcl_GetHashValue(entry); if (cfunc->deleteProc != NULL) { (*cfunc->deleteProc)(cfunc->clientData); } ckfree ( (char*)cfunc ); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(tablePtr); ckfree((char*)tablePtr); } itcl3.4.3/generic/itcl_util.c0000644003604700454610000012672712536627705014576 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 * ======================================================================== * 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" /* * 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 */ /* * These records are used to keep track of reference-counted data * for Itcl_PreserveData and Itcl_ReleaseData. */ typedef struct ItclPreservedData { ClientData data; /* reference to data */ int usage; /* number of active uses */ Tcl_FreeProc *fproc; /* procedure used to free data */ } ItclPreservedData; static Tcl_HashTable *ItclPreservedList = NULL; TCL_DECLARE_MUTEX(ItclPreservedListLock) /* * 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(testExpr, fileName, lineNumber) 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(stack) 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(stack) 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(cdata,stack) 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(stack) Itcl_Stack *stack; /* stack to be manipulated */ { if (stack->values && (stack->len > 0)) { stack->len--; return stack->values[stack->len]; } return (ClientData)NULL; } /* * ------------------------------------------------------------------------ * Itcl_PeekStack() * * Gets the current value from the top of the given stack. * ------------------------------------------------------------------------ */ ClientData Itcl_PeekStack(stack) Itcl_Stack *stack; /* stack to be examined */ { if (stack->values && (stack->len > 0)) { return stack->values[stack->len-1]; } return (ClientData)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(stack,pos) 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 (ClientData)NULL; } /* * ------------------------------------------------------------------------ * Itcl_InitList() * * Initializes a linked list structure, setting the list to the empty * state. * ------------------------------------------------------------------------ */ void Itcl_InitList(listPtr) 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(listPtr) 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(listPtr) 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(elemPtr) 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(listPtr,val) 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(pos,val) 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(listPtr,val) 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(pos,val) 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(elemPtr,val) Itcl_ListElem *elemPtr; /* list element being modified */ ClientData val; /* new value associated with element */ { assert(elemPtr != NULL); assert(elemPtr->owner != NULL); assert(elemPtr->owner->validate == ITCL_VALID_LIST); elemPtr->value = val; } /* * ======================================================================== * 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 use * a hash table instead of a linked list to maintain the references, * so they scale better. Also, the Tcl procedures have a bad behavior * during the "exit" command. Their exit handler shuts them down * when other data is still being reference-counted and cleaned up. * * ------------------------------------------------------------------------ * Itcl_EventuallyFree() * * Registers a piece of data so that it will be freed when no longer * in use. The data is registered with an initial usage count of "0". * Future calls to Itcl_PreserveData() increase this usage count, and * calls to Itcl_ReleaseData() decrease the count until it reaches * zero and the data is freed. * ------------------------------------------------------------------------ */ void Itcl_EventuallyFree(cdata, fproc) ClientData cdata; /* data to be freed when not in use */ Tcl_FreeProc *fproc; /* procedure called to free data */ { int newEntry; Tcl_HashEntry *entry; ItclPreservedData *chunk; /* * If the clientData value is NULL, do nothing. */ if (cdata == NULL) { return; } /* * If a list has not yet been created to manage bits of * preserved data, then create it. */ Tcl_MutexLock(&ItclPreservedListLock); if (!ItclPreservedList) { ItclPreservedList = (Tcl_HashTable*)ckalloc( (unsigned)sizeof(Tcl_HashTable) ); Tcl_InitHashTable(ItclPreservedList, TCL_ONE_WORD_KEYS); } /* * Find or create the data in the global list. */ entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry); if (newEntry) { chunk = (ItclPreservedData*)ckalloc( (unsigned)sizeof(ItclPreservedData) ); chunk->data = cdata; chunk->usage = 0; chunk->fproc = fproc; Tcl_SetHashValue(entry, (ClientData)chunk); } else { chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); chunk->fproc = fproc; } /* * If the usage count is zero, then delete the data now. */ if (chunk->usage == 0) { chunk->usage = -1; /* cannot preserve/release anymore */ Tcl_MutexUnlock(&ItclPreservedListLock); (*chunk->fproc)((char*)chunk->data); Tcl_MutexLock(&ItclPreservedListLock); Tcl_DeleteHashEntry(entry); ckfree((char*)chunk); } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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(cdata) ClientData cdata; /* data to be preserved */ { Tcl_HashEntry *entry; ItclPreservedData *chunk; int newEntry; /* * If the clientData value is NULL, do nothing. */ if (cdata == NULL) { return; } /* * If a list has not yet been created to manage bits of * preserved data, then create it. */ Tcl_MutexLock(&ItclPreservedListLock); if (!ItclPreservedList) { ItclPreservedList = (Tcl_HashTable*)ckalloc( (unsigned)sizeof(Tcl_HashTable) ); Tcl_InitHashTable(ItclPreservedList,TCL_ONE_WORD_KEYS); } /* * Find the data in the global list and bump its usage count. */ entry = Tcl_CreateHashEntry(ItclPreservedList,(char*)cdata, &newEntry); if (newEntry) { chunk = (ItclPreservedData*)ckalloc( (unsigned)sizeof(ItclPreservedData) ); chunk->data = cdata; chunk->usage = 0; chunk->fproc = NULL; Tcl_SetHashValue(entry, (ClientData)chunk); } else { chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); } /* * Only increment the usage if it is non-negative. * Negative numbers mean that the data is in the process * of being destroyed by Itcl_ReleaseData(), and should * not be further preserved. */ if (chunk->usage >= 0) { chunk->usage++; } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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(cdata) ClientData cdata; /* data to be released */ { Tcl_HashEntry *entry; ItclPreservedData *chunk; /* * If the clientData value is NULL, do nothing. */ if (cdata == NULL) { return; } /* * Otherwise, find the data in the global list and * decrement its usage count. */ entry = NULL; Tcl_MutexLock(&ItclPreservedListLock); if (ItclPreservedList) { entry = Tcl_FindHashEntry(ItclPreservedList,(char*)cdata); } if (!entry) { Tcl_MutexUnlock(&ItclPreservedListLock); Tcl_Panic("Itcl_ReleaseData can't find reference for 0x%p", cdata); } /* * Only decrement the usage if it is non-negative. * When the usage reaches zero, set it to a negative number * to indicate that data is being destroyed, and then * invoke the client delete proc. When the data is deleted, * remove the entry from the preservation list. */ chunk = (ItclPreservedData*)Tcl_GetHashValue(entry); if (chunk->usage > 0 && --chunk->usage == 0) { if (chunk->fproc) { chunk->usage = -1; /* cannot preserve/release anymore */ Tcl_MutexUnlock(&ItclPreservedListLock); (*chunk->fproc)((char*)chunk->data); Tcl_MutexLock(&ItclPreservedListLock); } Tcl_DeleteHashEntry(entry); ckfree((char*)chunk); } Tcl_MutexUnlock(&ItclPreservedListLock); } /* * ------------------------------------------------------------------------ * 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(interp, status) Tcl_Interp* interp; /* interpreter being modified */ int status; /* integer status code for current operation */ { Interp *iPtr = (Interp*)interp; InterpState *info; CONST char *val; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS return (Itcl_InterpState) Tcl_SaveInterpState(interp, status); #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { Itcl_InterpState (*tcl_SaveInterpState)(Tcl_Interp *, int) = (Itcl_InterpState (*)(Tcl_Interp *, int)) tclStubsPtr->reserved535; return (*tcl_SaveInterpState)(interp, status); } #endif info = (InterpState*)ckalloc(sizeof(InterpState)); info->validate = TCL_STATE_VALID; info->status = status; info->errorInfo = NULL; info->errorCode = NULL; /* * Get the result object from the interpreter. This synchronizes * the old-style result, so we don't have to worry about it. * Keeping the object result is enough. */ info->objResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(info->objResult); /* * If an error is in progress, preserve its state. */ #ifdef ERR_IN_PROGRESS /* this disappeared in 8.5a2 */ if ((iPtr->flags & ERR_IN_PROGRESS) != 0) { #else if (iPtr->errorInfo != NULL) { #endif val = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (val) { info->errorInfo = ckalloc((unsigned)(strlen(val)+1)); strcpy(info->errorInfo, val); } val = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); if (val) { info->errorCode = ckalloc((unsigned)(strlen(val)+1)); strcpy(info->errorCode, val); } } /* * Now, reset the interpreter to a clean state. */ Tcl_ResetResult(interp); return (Itcl_InterpState)info; } /* * ------------------------------------------------------------------------ * 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(interp, state) Tcl_Interp* interp; /* interpreter being modified */ Itcl_InterpState state; /* token representing interpreter state */ { InterpState *info = (InterpState*)state; int status; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS return Tcl_RestoreInterpState(interp, (Tcl_InterpState)state); #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { int (*tcl_RestoreInterpState)() = (int (*)()) tclStubsPtr->reserved536; return (*tcl_RestoreInterpState)(interp, state); } #endif if (info->validate != TCL_STATE_VALID) { Tcl_Panic("bad token in Itcl_RestoreInterpState"); } Tcl_ResetResult(interp); /* * If an error is in progress, restore its state. * Set the error code the hard way--set the variable directly * and fix the interpreter flags. Otherwise, if the error code * string is really a list, it will get wrapped in extra {}'s. */ if (info->errorInfo) { Tcl_AddErrorInfo(interp, info->errorInfo); ckfree(info->errorInfo); } if (info->errorCode) { Tcl_SetObjErrorCode(interp, Tcl_NewStringObj(info->errorCode, -1)); ckfree(info->errorCode); } /* * Assign the object result back to the interpreter, then * release our hold on it. */ Tcl_SetObjResult(interp, info->objResult); Tcl_DecrRefCount(info->objResult); status = info->status; info->validate = 0; ckfree((char*)info); return status; } /* * ------------------------------------------------------------------------ * 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(state) Itcl_InterpState state; /* token representing interpreter state */ { InterpState *info = (InterpState*)state; /* * ERR_IN_PROGRESS was replaced by new APIs in 8.5a2. Call them if they * are available, or somehow magic them in from the stubs table. * Tcl_ChannelThreadActionProc is a stubs slot higher than the APIs we * need, so its existence indicates slot-y goodness. */ #ifndef ERR_IN_PROGRESS Tcl_DiscardInterpState((Tcl_InterpState)state); return; #elif defined(USE_TCL_STUBS) && defined(Tcl_ChannelThreadActionProc) if (itclCompatFlags & ITCL_COMPAT_USE_ISTATE_API) { void (* tcl_DiscardInterpState)() = (void (*)()) tclStubsPtr->reserved537; (*tcl_DiscardInterpState)(state); return; } #endif if (info->validate != TCL_STATE_VALID) { Tcl_Panic("bad token in Itcl_DiscardInterpState"); } if (info->errorInfo) { ckfree(info->errorInfo); } if (info->errorCode) { ckfree(info->errorCode); } Tcl_DecrRefCount(info->objResult); info->validate = 0; ckfree((char*)info); } /* * ------------------------------------------------------------------------ * 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(interp, newLevel) Tcl_Interp *interp; /* interpreter being queried */ int newLevel; /* new protection level or 0 */ { int oldVal; ItclObjectInfo *info; /* * If a new level was specified, then set the protection level. * In any case, return the protection level as it stands right now. */ info = (ItclObjectInfo*) Tcl_GetAssocData(interp, ITCL_INTERP_DATA, (Tcl_InterpDeleteProc**)NULL); assert(info != NULL); oldVal = info->protection; if (newLevel != 0) { assert(newLevel == ITCL_PUBLIC || newLevel == ITCL_PROTECTED || newLevel == ITCL_PRIVATE || newLevel == ITCL_DEFAULT_PROTECT); info->protection = newLevel; } return oldVal; } /* * ------------------------------------------------------------------------ * Itcl_ProtectionStr() * * Converts an integer protection code (ITCL_PUBLIC, ITCL_PROTECTED, * or ITCL_PRIVATE) into a human-readable character string. Returns * a pointer to this string. * ------------------------------------------------------------------------ */ char* Itcl_ProtectionStr(pLevel) int pLevel; /* protection level */ { switch (pLevel) { case ITCL_PUBLIC: return "public"; case ITCL_PROTECTED: return "protected"; case ITCL_PRIVATE: return "private"; } return ""; } /* * ------------------------------------------------------------------------ * 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(memberPtr, fromNsPtr) ItclMember* memberPtr; /* class member being tested */ Tcl_Namespace* fromNsPtr; /* namespace requesting access */ { ItclClass* fromCdPtr; Tcl_HashEntry *entry; /* * If the protection level is "public" or "private", then the * answer is known immediately. */ if (memberPtr->protection == ITCL_PUBLIC) { return 1; } else if (memberPtr->protection == ITCL_PRIVATE) { return (memberPtr->classDefn->namesp == fromNsPtr); } /* * 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 (memberPtr->protection == ITCL_PROTECTED); if (Itcl_IsClassNamespace(fromNsPtr)) { fromCdPtr = (ItclClass*)fromNsPtr->clientData; entry = Tcl_FindHashEntry(&fromCdPtr->heritage, (char*)memberPtr->classDefn); if (entry) { return 1; } } return 0; } /* * ------------------------------------------------------------------------ * 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(mfunc, fromNsPtr) ItclMemberFunc* mfunc; /* member function being tested */ Tcl_Namespace* fromNsPtr; /* namespace requesting access */ { ItclClass *cdPtr, *fromCdPtr; ItclMemberFunc *ovlfunc; Tcl_HashEntry *entry; /* * Apply the usual rules first. */ if (Itcl_CanAccess(mfunc->member, 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 ((mfunc->member->flags & ITCL_COMMON) == 0 && Itcl_IsClassNamespace(fromNsPtr)) { cdPtr = mfunc->member->classDefn; fromCdPtr = (ItclClass*)fromNsPtr->clientData; if (Tcl_FindHashEntry(&cdPtr->heritage, (char*)fromCdPtr)) { entry = Tcl_FindHashEntry(&fromCdPtr->resolveCmds, mfunc->member->name); if (entry) { ovlfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); if ((ovlfunc->member->flags & ITCL_COMMON) == 0 && ovlfunc->member->protection < ITCL_PRIVATE) { return 1; } } } } return 0; } /* * ------------------------------------------------------------------------ * Itcl_GetTrueNamespace() * * Returns the current namespace context. This procedure is similar * to Tcl_GetCurrentNamespace, but it supports the notion of * "transparent" call frames installed by Itcl_HandleInstance. * * Returns a pointer to the current namespace calling context. * ------------------------------------------------------------------------ */ Tcl_Namespace* Itcl_GetTrueNamespace(interp, info) Tcl_Interp *interp; /* interpreter being queried */ ItclObjectInfo *info; /* object info associated with interp */ { int i, transparent; Itcl_CallFrame *framePtr, *transFramePtr; Tcl_Namespace *contextNs; /* * See if the current call frame is on the list of transparent * call frames. */ transparent = 0; framePtr = _Tcl_GetCallFrame(interp, 0); for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) { transFramePtr = (Itcl_CallFrame*) Itcl_GetStackValue(&info->transparentFrames, i); if (framePtr == transFramePtr) { transparent = 1; break; } } /* * If this is a transparent call frame, return the namespace * context one level up. */ if (transparent) { framePtr = _Tcl_GetCallFrame(interp, 1); if (framePtr) { contextNs = framePtr->nsPtr; } else { contextNs = Tcl_GetGlobalNamespace(interp); } } else { contextNs = Tcl_GetCurrentNamespace(interp); } return contextNs; } /* * ------------------------------------------------------------------------ * 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(name, buffer, head, tail) CONST char *name; /* path name to class member */ Tcl_DString *buffer; /* dynamic string buffer (uninitialized) */ char **head; /* returns "namesp::namesp::namesp" part */ char **tail; /* returns "element" part */ { register 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; } /* * No :: separators--the whole name is treated as a tail. */ else { *tail = newname; *head = NULL; } } /* * ------------------------------------------------------------------------ * 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(interp, name, rNsPtr, rCmdPtr) 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 = NULL; char *cmdName = NULL; int len = strlen(name); CONST char *pos; int listc, result; CONST char **listv; cmdName = ckalloc((unsigned)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, name, &listc, &listv); if (result == TCL_OK) { if (listc != 4) { Tcl_AppendResult(interp, "malformed command \"", name, "\": should be \"", "namespace inscope namesp command\"", (char*)NULL); result = TCL_ERROR; } else { nsPtr = Tcl_FindNamespace(interp, listv[2], (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (!nsPtr) { result = TCL_ERROR; } else { ckfree(cmdName); cmdName = ckalloc((unsigned)(strlen(listv[3])+1)); strcpy(cmdName, listv[3]); } } } ckfree((char*)listv); if (result != TCL_OK) { char msg[512]; if (cmdName) { ckfree(cmdName); } sprintf(msg, "\n (while decoding scoped command \"%.400s\")", name); Tcl_AddObjErrorInfo(interp, msg, -1); return TCL_ERROR; } } } *rNsPtr = nsPtr; *rCmdPtr = cmdName; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_EvalArgs() * * This procedure invokes a list of (objc,objv) arguments as a * single command. It is similar to Tcl_EvalObj, but it doesn't * do any parsing or compilation. It simply treats the first * argument as a command and invokes that command in the current * context. * * Returns TCL_OK if successful. Otherwise, this procedure returns * TCL_ERROR along with an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_EvalArgs(interp, objc, objv) Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int result; Tcl_Command cmd; Command *cmdPtr; int cmdlinec; Tcl_Obj **cmdlinev; Tcl_Obj *cmdlinePtr = NULL; /* * Resolve the command by converting it to a CmdName object. * This caches a pointer to the Command structure for the * command, so if we need it again, it's ready to use. */ cmd = Tcl_GetCommandFromObj(interp, objv[0]); cmdPtr = (Command*)cmd; cmdlinec = objc; cmdlinev = (Tcl_Obj **) objv; /* * If the command is still not found, handle it with the * "unknown" proc. */ if (cmdPtr == NULL) { cmd = Tcl_FindCommand(interp, "unknown", (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); if (cmd == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invalid command name \"", Tcl_GetStringFromObj(objv[0], NULL), "\"", NULL); return TCL_ERROR; } cmdPtr = (Command*)cmd; cmdlinePtr = Itcl_CreateArgs(interp, "unknown", objc, objv); Tcl_ListObjGetElements(NULL, cmdlinePtr, &cmdlinec, &cmdlinev); } /* * Finally, invoke the command's Tcl_ObjCmdProc. Be careful * to pass in the proper client data. */ Tcl_ResetResult(interp); result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, cmdlinec, cmdlinev); if (cmdlinePtr) { Tcl_DecrRefCount(cmdlinePtr); } return result; } /* * ------------------------------------------------------------------------ * Itcl_CreateArgs() * * This procedure takes a string and a list of (objc,objv) arguments, * and glues them together in a single list. This is useful when * a command word needs to be prepended or substituted into a command * line before it is executed. The arguments are returned in a single * list object, and they can be retrieved by calling * Tcl_ListObjGetElements. When the arguments are no longer needed, * they should be discarded by decrementing the reference count for * the list object. * * Returns a pointer to the list object containing the arguments. * ------------------------------------------------------------------------ */ Tcl_Obj* Itcl_CreateArgs(interp, string, objc, objv) Tcl_Interp *interp; /* current interpreter */ CONST char *string; /* first command word */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int i; Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, Tcl_NewStringObj(string, -1)); for (i=0; i < objc; i++) { Tcl_ListObjAppendElement((Tcl_Interp*)NULL, listPtr, objv[i]); } Tcl_IncrRefCount(listPtr); return listPtr; } itcl3.4.3/generic/itclIntDecls.h0000644003604700454610000014727712536627705015177 0ustar dgp771div/* * itclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _ITCLINTDECLS #define _ITCLINTDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the itcl/generic/tclInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ /* * Exported function declarations: */ #ifndef Itcl_IsClassNamespace_TCL_DECLARED #define Itcl_IsClassNamespace_TCL_DECLARED /* 0 */ TCL_EXTERN(int) Itcl_IsClassNamespace _ANSI_ARGS_(( Tcl_Namespace * namesp)); #endif #ifndef Itcl_IsClass_TCL_DECLARED #define Itcl_IsClass_TCL_DECLARED /* 1 */ TCL_EXTERN(int) Itcl_IsClass _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_FindClass_TCL_DECLARED #define Itcl_FindClass_TCL_DECLARED /* 2 */ TCL_EXTERN(ItclClass*) Itcl_FindClass _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, int autoload)); #endif #ifndef Itcl_FindObject_TCL_DECLARED #define Itcl_FindObject_TCL_DECLARED /* 3 */ TCL_EXTERN(int) Itcl_FindObject _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject ** roPtr)); #endif #ifndef Itcl_IsObject_TCL_DECLARED #define Itcl_IsObject_TCL_DECLARED /* 4 */ TCL_EXTERN(int) Itcl_IsObject _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_ObjectIsa_TCL_DECLARED #define Itcl_ObjectIsa_TCL_DECLARED /* 5 */ TCL_EXTERN(int) Itcl_ObjectIsa _ANSI_ARGS_((ItclObject * contextObj, ItclClass * cdefn)); #endif #ifndef Itcl_Protection_TCL_DECLARED #define Itcl_Protection_TCL_DECLARED /* 6 */ TCL_EXTERN(int) Itcl_Protection _ANSI_ARGS_((Tcl_Interp * interp, int newLevel)); #endif #ifndef Itcl_ProtectionStr_TCL_DECLARED #define Itcl_ProtectionStr_TCL_DECLARED /* 7 */ TCL_EXTERN(char*) Itcl_ProtectionStr _ANSI_ARGS_((int pLevel)); #endif #ifndef Itcl_CanAccess_TCL_DECLARED #define Itcl_CanAccess_TCL_DECLARED /* 8 */ TCL_EXTERN(int) Itcl_CanAccess _ANSI_ARGS_((ItclMember* memberPtr, Tcl_Namespace* fromNsPtr)); #endif #ifndef Itcl_CanAccessFunc_TCL_DECLARED #define Itcl_CanAccessFunc_TCL_DECLARED /* 9 */ TCL_EXTERN(int) Itcl_CanAccessFunc _ANSI_ARGS_(( ItclMemberFunc* mfunc, Tcl_Namespace* fromNsPtr)); #endif #ifndef Itcl_GetTrueNamespace_TCL_DECLARED #define Itcl_GetTrueNamespace_TCL_DECLARED /* 10 */ TCL_EXTERN(Tcl_Namespace*) Itcl_GetTrueNamespace _ANSI_ARGS_(( Tcl_Interp * interp, ItclObjectInfo * info)); #endif #ifndef Itcl_ParseNamespPath_TCL_DECLARED #define Itcl_ParseNamespPath_TCL_DECLARED /* 11 */ TCL_EXTERN(void) Itcl_ParseNamespPath _ANSI_ARGS_((CONST char * name, Tcl_DString * buffer, char ** head, char ** tail)); #endif #ifndef Itcl_DecodeScopedCommand_TCL_DECLARED #define Itcl_DecodeScopedCommand_TCL_DECLARED /* 12 */ TCL_EXTERN(int) Itcl_DecodeScopedCommand _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_Namespace ** rNsPtr, char ** rCmdPtr)); #endif #ifndef Itcl_EvalArgs_TCL_DECLARED #define Itcl_EvalArgs_TCL_DECLARED /* 13 */ TCL_EXTERN(int) Itcl_EvalArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateArgs_TCL_DECLARED #define Itcl_CreateArgs_TCL_DECLARED /* 14 */ TCL_EXTERN(Tcl_Obj*) Itcl_CreateArgs _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_PushContext_TCL_DECLARED #define Itcl_PushContext_TCL_DECLARED /* 15 */ TCL_EXTERN(int) Itcl_PushContext _ANSI_ARGS_((Tcl_Interp * interp, ItclMember * member, ItclClass * contextClass, ItclObject * contextObj, ItclContext * contextPtr)); #endif #ifndef Itcl_PopContext_TCL_DECLARED #define Itcl_PopContext_TCL_DECLARED /* 16 */ TCL_EXTERN(void) Itcl_PopContext _ANSI_ARGS_((Tcl_Interp * interp, ItclContext * contextPtr)); #endif #ifndef Itcl_GetContext_TCL_DECLARED #define Itcl_GetContext_TCL_DECLARED /* 17 */ TCL_EXTERN(int) Itcl_GetContext _ANSI_ARGS_((Tcl_Interp * interp, ItclClass ** cdefnPtr, ItclObject ** odefnPtr)); #endif #ifndef Itcl_InitHierIter_TCL_DECLARED #define Itcl_InitHierIter_TCL_DECLARED /* 18 */ TCL_EXTERN(void) Itcl_InitHierIter _ANSI_ARGS_((ItclHierIter * iter, ItclClass * cdefn)); #endif #ifndef Itcl_DeleteHierIter_TCL_DECLARED #define Itcl_DeleteHierIter_TCL_DECLARED /* 19 */ TCL_EXTERN(void) Itcl_DeleteHierIter _ANSI_ARGS_((ItclHierIter * iter)); #endif #ifndef Itcl_AdvanceHierIter_TCL_DECLARED #define Itcl_AdvanceHierIter_TCL_DECLARED /* 20 */ TCL_EXTERN(ItclClass*) Itcl_AdvanceHierIter _ANSI_ARGS_(( ItclHierIter * iter)); #endif #ifndef Itcl_FindClassesCmd_TCL_DECLARED #define Itcl_FindClassesCmd_TCL_DECLARED /* 21 */ TCL_EXTERN(int) Itcl_FindClassesCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_FindObjectsCmd_TCL_DECLARED #define Itcl_FindObjectsCmd_TCL_DECLARED /* 22 */ TCL_EXTERN(int) Itcl_FindObjectsCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ProtectionCmd_TCL_DECLARED #define Itcl_ProtectionCmd_TCL_DECLARED /* 23 */ TCL_EXTERN(int) Itcl_ProtectionCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DelClassCmd_TCL_DECLARED #define Itcl_DelClassCmd_TCL_DECLARED /* 24 */ TCL_EXTERN(int) Itcl_DelClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DelObjectCmd_TCL_DECLARED #define Itcl_DelObjectCmd_TCL_DECLARED /* 25 */ TCL_EXTERN(int) Itcl_DelObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ScopeCmd_TCL_DECLARED #define Itcl_ScopeCmd_TCL_DECLARED /* 26 */ TCL_EXTERN(int) Itcl_ScopeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CodeCmd_TCL_DECLARED #define Itcl_CodeCmd_TCL_DECLARED /* 27 */ TCL_EXTERN(int) Itcl_CodeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_StubCreateCmd_TCL_DECLARED #define Itcl_StubCreateCmd_TCL_DECLARED /* 28 */ TCL_EXTERN(int) Itcl_StubCreateCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_StubExistsCmd_TCL_DECLARED #define Itcl_StubExistsCmd_TCL_DECLARED /* 29 */ TCL_EXTERN(int) Itcl_StubExistsCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_IsStub_TCL_DECLARED #define Itcl_IsStub_TCL_DECLARED /* 30 */ TCL_EXTERN(int) Itcl_IsStub _ANSI_ARGS_((Tcl_Command cmd)); #endif #ifndef Itcl_CreateClass_TCL_DECLARED #define Itcl_CreateClass_TCL_DECLARED /* 31 */ TCL_EXTERN(int) Itcl_CreateClass _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, ItclObjectInfo * info, ItclClass ** rPtr)); #endif #ifndef Itcl_DeleteClass_TCL_DECLARED #define Itcl_DeleteClass_TCL_DECLARED /* 32 */ TCL_EXTERN(int) Itcl_DeleteClass _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefnPtr)); #endif #ifndef Itcl_FindClassNamespace_TCL_DECLARED #define Itcl_FindClassNamespace_TCL_DECLARED /* 33 */ TCL_EXTERN(Tcl_Namespace*) Itcl_FindClassNamespace _ANSI_ARGS_(( Tcl_Interp* interp, CONST char* path)); #endif #ifndef Itcl_HandleClass_TCL_DECLARED #define Itcl_HandleClass_TCL_DECLARED /* 34 */ TCL_EXTERN(int) Itcl_HandleClass _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassCmdResolver_TCL_DECLARED #define Itcl_ClassCmdResolver_TCL_DECLARED /* 35 */ TCL_EXTERN(int) Itcl_ClassCmdResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Command * rPtr)); #endif #ifndef Itcl_ClassVarResolver_TCL_DECLARED #define Itcl_ClassVarResolver_TCL_DECLARED /* 36 */ TCL_EXTERN(int) Itcl_ClassVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Var * rPtr)); #endif #ifndef Itcl_ClassCompiledVarResolver_TCL_DECLARED #define Itcl_ClassCompiledVarResolver_TCL_DECLARED /* 37 */ TCL_EXTERN(int) Itcl_ClassCompiledVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, int length, Tcl_Namespace * context, Tcl_ResolvedVarInfo ** rPtr)); #endif #ifndef Itcl_BuildVirtualTables_TCL_DECLARED #define Itcl_BuildVirtualTables_TCL_DECLARED /* 38 */ TCL_EXTERN(void) Itcl_BuildVirtualTables _ANSI_ARGS_(( ItclClass* cdefnPtr)); #endif #ifndef Itcl_CreateVarDefn_TCL_DECLARED #define Itcl_CreateVarDefn_TCL_DECLARED /* 39 */ TCL_EXTERN(int) Itcl_CreateVarDefn _ANSI_ARGS_((Tcl_Interp * interp, ItclClass* cdefn, char* name, char* init, char* config, ItclVarDefn** vdefnPtr)); #endif #ifndef Itcl_DeleteVarDefn_TCL_DECLARED #define Itcl_DeleteVarDefn_TCL_DECLARED /* 40 */ TCL_EXTERN(void) Itcl_DeleteVarDefn _ANSI_ARGS_((ItclVarDefn * vdefn)); #endif #ifndef Itcl_GetCommonVar_TCL_DECLARED #define Itcl_GetCommonVar_TCL_DECLARED /* 41 */ TCL_EXTERN(CONST char*) Itcl_GetCommonVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass)); #endif #ifndef Itcl_CreateMember_TCL_DECLARED #define Itcl_CreateMember_TCL_DECLARED /* 42 */ TCL_EXTERN(ItclMember*) Itcl_CreateMember _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name)); #endif #ifndef Itcl_DeleteMember_TCL_DECLARED #define Itcl_DeleteMember_TCL_DECLARED /* 43 */ TCL_EXTERN(void) Itcl_DeleteMember _ANSI_ARGS_((ItclMember * memPtr)); #endif #ifndef Itcl_CreateObject_TCL_DECLARED #define Itcl_CreateObject_TCL_DECLARED /* 44 */ TCL_EXTERN(int) Itcl_CreateObject _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, ItclClass * cdefn, int objc, Tcl_Obj *CONST objv[], ItclObject ** roPtr)); #endif #ifndef Itcl_DeleteObject_TCL_DECLARED #define Itcl_DeleteObject_TCL_DECLARED /* 45 */ TCL_EXTERN(int) Itcl_DeleteObject _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj)); #endif #ifndef Itcl_DestructObject_TCL_DECLARED #define Itcl_DestructObject_TCL_DECLARED /* 46 */ TCL_EXTERN(int) Itcl_DestructObject _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, int flags)); #endif #ifndef Itcl_HandleInstance_TCL_DECLARED #define Itcl_HandleInstance_TCL_DECLARED /* 47 */ TCL_EXTERN(int) Itcl_HandleInstance _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_GetInstanceVar_TCL_DECLARED #define Itcl_GetInstanceVar_TCL_DECLARED /* 48 */ TCL_EXTERN(CONST char*) Itcl_GetInstanceVar _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, ItclObject * contextObj, ItclClass * contextClass)); #endif #ifndef Itcl_ScopedVarResolver_TCL_DECLARED #define Itcl_ScopedVarResolver_TCL_DECLARED /* 49 */ TCL_EXTERN(int) Itcl_ScopedVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNs, int flags, Tcl_Var * rPtr)); #endif #ifndef Itcl_BodyCmd_TCL_DECLARED #define Itcl_BodyCmd_TCL_DECLARED /* 50 */ TCL_EXTERN(int) Itcl_BodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ConfigBodyCmd_TCL_DECLARED #define Itcl_ConfigBodyCmd_TCL_DECLARED /* 51 */ TCL_EXTERN(int) Itcl_ConfigBodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateMethod_TCL_DECLARED #define Itcl_CreateMethod_TCL_DECLARED /* 52 */ TCL_EXTERN(int) Itcl_CreateMethod _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_CreateProc_TCL_DECLARED #define Itcl_CreateProc_TCL_DECLARED /* 53 */ TCL_EXTERN(int) Itcl_CreateProc _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_CreateMemberFunc_TCL_DECLARED #define Itcl_CreateMemberFunc_TCL_DECLARED /* 54 */ TCL_EXTERN(int) Itcl_CreateMemberFunc _ANSI_ARGS_(( Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body, ItclMemberFunc** mfuncPtr)); #endif #ifndef Itcl_ChangeMemberFunc_TCL_DECLARED #define Itcl_ChangeMemberFunc_TCL_DECLARED /* 55 */ TCL_EXTERN(int) Itcl_ChangeMemberFunc _ANSI_ARGS_(( Tcl_Interp* interp, ItclMemberFunc* mfunc, CONST char* arglist, CONST char* body)); #endif #ifndef Itcl_DeleteMemberFunc_TCL_DECLARED #define Itcl_DeleteMemberFunc_TCL_DECLARED /* 56 */ TCL_EXTERN(void) Itcl_DeleteMemberFunc _ANSI_ARGS_((CONST char* cdata)); #endif #ifndef Itcl_CreateMemberCode_TCL_DECLARED #define Itcl_CreateMemberCode_TCL_DECLARED /* 57 */ TCL_EXTERN(int) Itcl_CreateMemberCode _ANSI_ARGS_(( Tcl_Interp* interp, ItclClass * cdefn, CONST char* arglist, CONST char* body, ItclMemberCode** mcodePtr)); #endif #ifndef Itcl_DeleteMemberCode_TCL_DECLARED #define Itcl_DeleteMemberCode_TCL_DECLARED /* 58 */ TCL_EXTERN(void) Itcl_DeleteMemberCode _ANSI_ARGS_((CONST char* cdata)); #endif #ifndef Itcl_GetMemberCode_TCL_DECLARED #define Itcl_GetMemberCode_TCL_DECLARED /* 59 */ TCL_EXTERN(int) Itcl_GetMemberCode _ANSI_ARGS_((Tcl_Interp* interp, ItclMember* member)); #endif /* Slot 60 is reserved */ #ifndef Itcl_EvalMemberCode_TCL_DECLARED #define Itcl_EvalMemberCode_TCL_DECLARED /* 61 */ TCL_EXTERN(int) Itcl_EvalMemberCode _ANSI_ARGS_((Tcl_Interp * interp, ItclMemberFunc * mfunc, ItclMember * member, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_CreateArgList_TCL_DECLARED #define Itcl_CreateArgList_TCL_DECLARED /* 62 */ TCL_EXTERN(int) Itcl_CreateArgList _ANSI_ARGS_((Tcl_Interp* interp, CONST char* decl, int* argcPtr, CompiledLocal** argPtr)); #endif #ifndef Itcl_CreateArg_TCL_DECLARED #define Itcl_CreateArg_TCL_DECLARED /* 63 */ TCL_EXTERN(CompiledLocal*) Itcl_CreateArg _ANSI_ARGS_((CONST char* name, CONST char* init)); #endif #ifndef Itcl_DeleteArgList_TCL_DECLARED #define Itcl_DeleteArgList_TCL_DECLARED /* 64 */ TCL_EXTERN(void) Itcl_DeleteArgList _ANSI_ARGS_(( CompiledLocal * arglist)); #endif #ifndef Itcl_ArgList_TCL_DECLARED #define Itcl_ArgList_TCL_DECLARED /* 65 */ TCL_EXTERN(Tcl_Obj*) Itcl_ArgList _ANSI_ARGS_((int argc, CompiledLocal* arglist)); #endif #ifndef Itcl_EquivArgLists_TCL_DECLARED #define Itcl_EquivArgLists_TCL_DECLARED /* 66 */ TCL_EXTERN(int) Itcl_EquivArgLists _ANSI_ARGS_((CompiledLocal* arg1, int arg1c, CompiledLocal* arg2, int arg2c)); #endif #ifndef Itcl_GetMemberFuncUsage_TCL_DECLARED #define Itcl_GetMemberFuncUsage_TCL_DECLARED /* 67 */ TCL_EXTERN(void) Itcl_GetMemberFuncUsage _ANSI_ARGS_(( ItclMemberFunc * mfunc, ItclObject * contextObj, Tcl_Obj * objPtr)); #endif #ifndef Itcl_ExecMethod_TCL_DECLARED #define Itcl_ExecMethod_TCL_DECLARED /* 68 */ TCL_EXTERN(int) Itcl_ExecMethod _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ExecProc_TCL_DECLARED #define Itcl_ExecProc_TCL_DECLARED /* 69 */ TCL_EXTERN(int) Itcl_ExecProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_AssignArgs_TCL_DECLARED #define Itcl_AssignArgs_TCL_DECLARED /* 70 */ TCL_EXTERN(int) Itcl_AssignArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], ItclMemberFunc * mfunc)); #endif #ifndef Itcl_ConstructBase_TCL_DECLARED #define Itcl_ConstructBase_TCL_DECLARED /* 71 */ TCL_EXTERN(int) Itcl_ConstructBase _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, ItclClass * contextClass)); #endif #ifndef Itcl_InvokeMethodIfExists_TCL_DECLARED #define Itcl_InvokeMethodIfExists_TCL_DECLARED /* 72 */ TCL_EXTERN(int) Itcl_InvokeMethodIfExists _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, ItclClass * contextClass, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); #endif /* Slot 73 is reserved */ #ifndef Itcl_ReportFuncErrors_TCL_DECLARED #define Itcl_ReportFuncErrors_TCL_DECLARED /* 74 */ TCL_EXTERN(int) Itcl_ReportFuncErrors _ANSI_ARGS_(( Tcl_Interp* interp, ItclMemberFunc * mfunc, ItclObject * contextObj, int result)); #endif #ifndef Itcl_ParseInit_TCL_DECLARED #define Itcl_ParseInit_TCL_DECLARED /* 75 */ TCL_EXTERN(int) Itcl_ParseInit _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); #endif #ifndef Itcl_ClassCmd_TCL_DECLARED #define Itcl_ClassCmd_TCL_DECLARED /* 76 */ TCL_EXTERN(int) Itcl_ClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassInheritCmd_TCL_DECLARED #define Itcl_ClassInheritCmd_TCL_DECLARED /* 77 */ TCL_EXTERN(int) Itcl_ClassInheritCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassProtectionCmd_TCL_DECLARED #define Itcl_ClassProtectionCmd_TCL_DECLARED /* 78 */ TCL_EXTERN(int) Itcl_ClassProtectionCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassConstructorCmd_TCL_DECLARED #define Itcl_ClassConstructorCmd_TCL_DECLARED /* 79 */ TCL_EXTERN(int) Itcl_ClassConstructorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassDestructorCmd_TCL_DECLARED #define Itcl_ClassDestructorCmd_TCL_DECLARED /* 80 */ TCL_EXTERN(int) Itcl_ClassDestructorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassMethodCmd_TCL_DECLARED #define Itcl_ClassMethodCmd_TCL_DECLARED /* 81 */ TCL_EXTERN(int) Itcl_ClassMethodCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassProcCmd_TCL_DECLARED #define Itcl_ClassProcCmd_TCL_DECLARED /* 82 */ TCL_EXTERN(int) Itcl_ClassProcCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassVariableCmd_TCL_DECLARED #define Itcl_ClassVariableCmd_TCL_DECLARED /* 83 */ TCL_EXTERN(int) Itcl_ClassVariableCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ClassCommonCmd_TCL_DECLARED #define Itcl_ClassCommonCmd_TCL_DECLARED /* 84 */ TCL_EXTERN(int) Itcl_ClassCommonCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_ParseVarResolver_TCL_DECLARED #define Itcl_ParseVarResolver_TCL_DECLARED /* 85 */ TCL_EXTERN(int) Itcl_ParseVarResolver _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* name, Tcl_Namespace * contextNs, int flags, Tcl_Var* rPtr)); #endif #ifndef Itcl_BiInit_TCL_DECLARED #define Itcl_BiInit_TCL_DECLARED /* 86 */ TCL_EXTERN(int) Itcl_BiInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_InstallBiMethods_TCL_DECLARED #define Itcl_InstallBiMethods_TCL_DECLARED /* 87 */ TCL_EXTERN(int) Itcl_InstallBiMethods _ANSI_ARGS_(( Tcl_Interp * interp, ItclClass * cdefn)); #endif #ifndef Itcl_BiIsaCmd_TCL_DECLARED #define Itcl_BiIsaCmd_TCL_DECLARED /* 88 */ TCL_EXTERN(int) Itcl_BiIsaCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiConfigureCmd_TCL_DECLARED #define Itcl_BiConfigureCmd_TCL_DECLARED /* 89 */ TCL_EXTERN(int) Itcl_BiConfigureCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiCgetCmd_TCL_DECLARED #define Itcl_BiCgetCmd_TCL_DECLARED /* 90 */ TCL_EXTERN(int) Itcl_BiCgetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiChainCmd_TCL_DECLARED #define Itcl_BiChainCmd_TCL_DECLARED /* 91 */ TCL_EXTERN(int) Itcl_BiChainCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoClassCmd_TCL_DECLARED #define Itcl_BiInfoClassCmd_TCL_DECLARED /* 92 */ TCL_EXTERN(int) Itcl_BiInfoClassCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoInheritCmd_TCL_DECLARED #define Itcl_BiInfoInheritCmd_TCL_DECLARED /* 93 */ TCL_EXTERN(int) Itcl_BiInfoInheritCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoHeritageCmd_TCL_DECLARED #define Itcl_BiInfoHeritageCmd_TCL_DECLARED /* 94 */ TCL_EXTERN(int) Itcl_BiInfoHeritageCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoFunctionCmd_TCL_DECLARED #define Itcl_BiInfoFunctionCmd_TCL_DECLARED /* 95 */ TCL_EXTERN(int) Itcl_BiInfoFunctionCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoVariableCmd_TCL_DECLARED #define Itcl_BiInfoVariableCmd_TCL_DECLARED /* 96 */ TCL_EXTERN(int) Itcl_BiInfoVariableCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoBodyCmd_TCL_DECLARED #define Itcl_BiInfoBodyCmd_TCL_DECLARED /* 97 */ TCL_EXTERN(int) Itcl_BiInfoBodyCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_BiInfoArgsCmd_TCL_DECLARED #define Itcl_BiInfoArgsCmd_TCL_DECLARED /* 98 */ TCL_EXTERN(int) Itcl_BiInfoArgsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_DefaultInfoCmd_TCL_DECLARED #define Itcl_DefaultInfoCmd_TCL_DECLARED /* 99 */ TCL_EXTERN(int) Itcl_DefaultInfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsembleInit_TCL_DECLARED #define Itcl_EnsembleInit_TCL_DECLARED /* 100 */ TCL_EXTERN(int) Itcl_EnsembleInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_CreateEnsemble_TCL_DECLARED #define Itcl_CreateEnsemble_TCL_DECLARED /* 101 */ TCL_EXTERN(int) Itcl_CreateEnsemble _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName)); #endif #ifndef Itcl_AddEnsemblePart_TCL_DECLARED #define Itcl_AddEnsemblePart_TCL_DECLARED /* 102 */ TCL_EXTERN(int) Itcl_AddEnsemblePart _ANSI_ARGS_(( Tcl_Interp * interp, CONST char* ensName, CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc * objProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_GetEnsemblePart_TCL_DECLARED #define Itcl_GetEnsemblePart_TCL_DECLARED /* 103 */ TCL_EXTERN(int) Itcl_GetEnsemblePart _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * ensName, CONST char * partName, Tcl_CmdInfo * infoPtr)); #endif #ifndef Itcl_IsEnsemble_TCL_DECLARED #define Itcl_IsEnsemble_TCL_DECLARED /* 104 */ TCL_EXTERN(int) Itcl_IsEnsemble _ANSI_ARGS_((Tcl_CmdInfo* infoPtr)); #endif #ifndef Itcl_GetEnsembleUsage_TCL_DECLARED #define Itcl_GetEnsembleUsage_TCL_DECLARED /* 105 */ TCL_EXTERN(int) Itcl_GetEnsembleUsage _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * ensName, Tcl_Obj * objPtr)); #endif #ifndef Itcl_GetEnsembleUsageForObj_TCL_DECLARED #define Itcl_GetEnsembleUsageForObj_TCL_DECLARED /* 106 */ TCL_EXTERN(int) Itcl_GetEnsembleUsageForObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * ensObjPtr, Tcl_Obj * objPtr)); #endif #ifndef Itcl_EnsembleCmd_TCL_DECLARED #define Itcl_EnsembleCmd_TCL_DECLARED /* 107 */ TCL_EXTERN(int) Itcl_EnsembleCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsPartCmd_TCL_DECLARED #define Itcl_EnsPartCmd_TCL_DECLARED /* 108 */ TCL_EXTERN(int) Itcl_EnsPartCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_EnsembleErrorCmd_TCL_DECLARED #define Itcl_EnsembleErrorCmd_TCL_DECLARED /* 109 */ TCL_EXTERN(int) Itcl_EnsembleErrorCmd _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif /* Slot 110 is reserved */ /* Slot 111 is reserved */ #ifndef _Tcl_GetCallFrame_TCL_DECLARED #define _Tcl_GetCallFrame_TCL_DECLARED /* 112 */ TCL_EXTERN(Itcl_CallFrame*) _Tcl_GetCallFrame _ANSI_ARGS_(( Tcl_Interp * interp, int level)); #endif #ifndef _Tcl_ActivateCallFrame_TCL_DECLARED #define _Tcl_ActivateCallFrame_TCL_DECLARED /* 113 */ TCL_EXTERN(Itcl_CallFrame*) _Tcl_ActivateCallFrame _ANSI_ARGS_(( Tcl_Interp * interp, Itcl_CallFrame * framePtr)); #endif #ifndef _TclNewVar_TCL_DECLARED #define _TclNewVar_TCL_DECLARED /* 114 */ TCL_EXTERN(Var*) _TclNewVar _ANSI_ARGS_((void)); #endif #ifndef Itcl_Assert_TCL_DECLARED #define Itcl_Assert_TCL_DECLARED /* 115 */ TCL_EXTERN(void) Itcl_Assert _ANSI_ARGS_((CONST char * testExpr, CONST char * fileName, int lineNum)); #endif #ifndef Itcl_IsObjectCmd_TCL_DECLARED #define Itcl_IsObjectCmd_TCL_DECLARED /* 116 */ TCL_EXTERN(int) Itcl_IsObjectCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif #ifndef Itcl_IsClassCmd_TCL_DECLARED #define Itcl_IsClassCmd_TCL_DECLARED /* 117 */ TCL_EXTERN(int) Itcl_IsClassCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); #endif typedef struct ItclIntStubs { int magic; struct ItclIntStubHooks *hooks; int (*itcl_IsClassNamespace) _ANSI_ARGS_((Tcl_Namespace * namesp)); /* 0 */ int (*itcl_IsClass) _ANSI_ARGS_((Tcl_Command cmd)); /* 1 */ ItclClass* (*itcl_FindClass) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, int autoload)); /* 2 */ int (*itcl_FindObject) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject ** roPtr)); /* 3 */ int (*itcl_IsObject) _ANSI_ARGS_((Tcl_Command cmd)); /* 4 */ int (*itcl_ObjectIsa) _ANSI_ARGS_((ItclObject * contextObj, ItclClass * cdefn)); /* 5 */ int (*itcl_Protection) _ANSI_ARGS_((Tcl_Interp * interp, int newLevel)); /* 6 */ char* (*itcl_ProtectionStr) _ANSI_ARGS_((int pLevel)); /* 7 */ int (*itcl_CanAccess) _ANSI_ARGS_((ItclMember* memberPtr, Tcl_Namespace* fromNsPtr)); /* 8 */ int (*itcl_CanAccessFunc) _ANSI_ARGS_((ItclMemberFunc* mfunc, Tcl_Namespace* fromNsPtr)); /* 9 */ Tcl_Namespace* (*itcl_GetTrueNamespace) _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); /* 10 */ void (*itcl_ParseNamespPath) _ANSI_ARGS_((CONST char * name, Tcl_DString * buffer, char ** head, char ** tail)); /* 11 */ int (*itcl_DecodeScopedCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace ** rNsPtr, char ** rCmdPtr)); /* 12 */ int (*itcl_EvalArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 13 */ Tcl_Obj* (*itcl_CreateArgs) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int objc, Tcl_Obj *CONST objv[])); /* 14 */ int (*itcl_PushContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclMember * member, ItclClass * contextClass, ItclObject * contextObj, ItclContext * contextPtr)); /* 15 */ void (*itcl_PopContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclContext * contextPtr)); /* 16 */ int (*itcl_GetContext) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass ** cdefnPtr, ItclObject ** odefnPtr)); /* 17 */ void (*itcl_InitHierIter) _ANSI_ARGS_((ItclHierIter * iter, ItclClass * cdefn)); /* 18 */ void (*itcl_DeleteHierIter) _ANSI_ARGS_((ItclHierIter * iter)); /* 19 */ ItclClass* (*itcl_AdvanceHierIter) _ANSI_ARGS_((ItclHierIter * iter)); /* 20 */ int (*itcl_FindClassesCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 21 */ int (*itcl_FindObjectsCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 22 */ int (*itcl_ProtectionCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 23 */ int (*itcl_DelClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 24 */ int (*itcl_DelObjectCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 25 */ int (*itcl_ScopeCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 26 */ int (*itcl_CodeCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 27 */ int (*itcl_StubCreateCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 28 */ int (*itcl_StubExistsCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 29 */ int (*itcl_IsStub) _ANSI_ARGS_((Tcl_Command cmd)); /* 30 */ int (*itcl_CreateClass) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path, ItclObjectInfo * info, ItclClass ** rPtr)); /* 31 */ int (*itcl_DeleteClass) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefnPtr)); /* 32 */ Tcl_Namespace* (*itcl_FindClassNamespace) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* path)); /* 33 */ int (*itcl_HandleClass) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 34 */ int (*itcl_ClassCmdResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Command * rPtr)); /* 35 */ int (*itcl_ClassVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * context, int flags, Tcl_Var * rPtr)); /* 36 */ int (*itcl_ClassCompiledVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, int length, Tcl_Namespace * context, Tcl_ResolvedVarInfo ** rPtr)); /* 37 */ void (*itcl_BuildVirtualTables) _ANSI_ARGS_((ItclClass* cdefnPtr)); /* 38 */ int (*itcl_CreateVarDefn) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass* cdefn, char* name, char* init, char* config, ItclVarDefn** vdefnPtr)); /* 39 */ void (*itcl_DeleteVarDefn) _ANSI_ARGS_((ItclVarDefn * vdefn)); /* 40 */ CONST char* (*itcl_GetCommonVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass)); /* 41 */ ItclMember* (*itcl_CreateMember) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name)); /* 42 */ void (*itcl_DeleteMember) _ANSI_ARGS_((ItclMember * memPtr)); /* 43 */ int (*itcl_CreateObject) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, ItclClass * cdefn, int objc, Tcl_Obj *CONST objv[], ItclObject ** roPtr)); /* 44 */ int (*itcl_DeleteObject) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj)); /* 45 */ int (*itcl_DestructObject) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, int flags)); /* 46 */ int (*itcl_HandleInstance) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 47 */ CONST char* (*itcl_GetInstanceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclObject * contextObj, ItclClass * contextClass)); /* 48 */ int (*itcl_ScopedVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNs, int flags, Tcl_Var * rPtr)); /* 49 */ int (*itcl_BodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 50 */ int (*itcl_ConfigBodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 51 */ int (*itcl_CreateMethod) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); /* 52 */ int (*itcl_CreateProc) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body)); /* 53 */ int (*itcl_CreateMemberFunc) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* name, CONST char* arglist, CONST char* body, ItclMemberFunc** mfuncPtr)); /* 54 */ int (*itcl_ChangeMemberFunc) _ANSI_ARGS_((Tcl_Interp* interp, ItclMemberFunc* mfunc, CONST char* arglist, CONST char* body)); /* 55 */ void (*itcl_DeleteMemberFunc) _ANSI_ARGS_((CONST char* cdata)); /* 56 */ int (*itcl_CreateMemberCode) _ANSI_ARGS_((Tcl_Interp* interp, ItclClass * cdefn, CONST char* arglist, CONST char* body, ItclMemberCode** mcodePtr)); /* 57 */ void (*itcl_DeleteMemberCode) _ANSI_ARGS_((CONST char* cdata)); /* 58 */ int (*itcl_GetMemberCode) _ANSI_ARGS_((Tcl_Interp* interp, ItclMember* member)); /* 59 */ void *reserved60; int (*itcl_EvalMemberCode) _ANSI_ARGS_((Tcl_Interp * interp, ItclMemberFunc * mfunc, ItclMember * member, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); /* 61 */ int (*itcl_CreateArgList) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* decl, int* argcPtr, CompiledLocal** argPtr)); /* 62 */ CompiledLocal* (*itcl_CreateArg) _ANSI_ARGS_((CONST char* name, CONST char* init)); /* 63 */ void (*itcl_DeleteArgList) _ANSI_ARGS_((CompiledLocal * arglist)); /* 64 */ Tcl_Obj* (*itcl_ArgList) _ANSI_ARGS_((int argc, CompiledLocal* arglist)); /* 65 */ int (*itcl_EquivArgLists) _ANSI_ARGS_((CompiledLocal* arg1, int arg1c, CompiledLocal* arg2, int arg2c)); /* 66 */ void (*itcl_GetMemberFuncUsage) _ANSI_ARGS_((ItclMemberFunc * mfunc, ItclObject * contextObj, Tcl_Obj * objPtr)); /* 67 */ int (*itcl_ExecMethod) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 68 */ int (*itcl_ExecProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 69 */ int (*itcl_AssignArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], ItclMemberFunc * mfunc)); /* 70 */ int (*itcl_ConstructBase) _ANSI_ARGS_((Tcl_Interp * interp, ItclObject * contextObj, ItclClass * contextClass)); /* 71 */ int (*itcl_InvokeMethodIfExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ItclClass * contextClass, ItclObject * contextObj, int objc, Tcl_Obj *CONST objv[])); /* 72 */ void *reserved73; int (*itcl_ReportFuncErrors) _ANSI_ARGS_((Tcl_Interp* interp, ItclMemberFunc * mfunc, ItclObject * contextObj, int result)); /* 74 */ int (*itcl_ParseInit) _ANSI_ARGS_((Tcl_Interp * interp, ItclObjectInfo * info)); /* 75 */ int (*itcl_ClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 76 */ int (*itcl_ClassInheritCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 77 */ int (*itcl_ClassProtectionCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 78 */ int (*itcl_ClassConstructorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 79 */ int (*itcl_ClassDestructorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 80 */ int (*itcl_ClassMethodCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 81 */ int (*itcl_ClassProcCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 82 */ int (*itcl_ClassVariableCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 83 */ int (*itcl_ClassCommonCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 84 */ int (*itcl_ParseVarResolver) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* name, Tcl_Namespace * contextNs, int flags, Tcl_Var* rPtr)); /* 85 */ int (*itcl_BiInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 86 */ int (*itcl_InstallBiMethods) _ANSI_ARGS_((Tcl_Interp * interp, ItclClass * cdefn)); /* 87 */ int (*itcl_BiIsaCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 88 */ int (*itcl_BiConfigureCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 89 */ int (*itcl_BiCgetCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 90 */ int (*itcl_BiChainCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 91 */ int (*itcl_BiInfoClassCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 92 */ int (*itcl_BiInfoInheritCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 93 */ int (*itcl_BiInfoHeritageCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 94 */ int (*itcl_BiInfoFunctionCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 95 */ int (*itcl_BiInfoVariableCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 96 */ int (*itcl_BiInfoBodyCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 97 */ int (*itcl_BiInfoArgsCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 98 */ int (*itcl_DefaultInfoCmd) _ANSI_ARGS_((ClientData dummy, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 99 */ int (*itcl_EnsembleInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 100 */ int (*itcl_CreateEnsemble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName)); /* 101 */ int (*itcl_AddEnsemblePart) _ANSI_ARGS_((Tcl_Interp * interp, CONST char* ensName, CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc * objProc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 102 */ int (*itcl_GetEnsemblePart) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * ensName, CONST char * partName, Tcl_CmdInfo * infoPtr)); /* 103 */ int (*itcl_IsEnsemble) _ANSI_ARGS_((Tcl_CmdInfo* infoPtr)); /* 104 */ int (*itcl_GetEnsembleUsage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * ensName, Tcl_Obj * objPtr)); /* 105 */ int (*itcl_GetEnsembleUsageForObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * ensObjPtr, Tcl_Obj * objPtr)); /* 106 */ int (*itcl_EnsembleCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 107 */ int (*itcl_EnsPartCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 108 */ int (*itcl_EnsembleErrorCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 109 */ void *reserved110; void *reserved111; Itcl_CallFrame* (*_Tcl_GetCallFrame) _ANSI_ARGS_((Tcl_Interp * interp, int level)); /* 112 */ Itcl_CallFrame* (*_Tcl_ActivateCallFrame) _ANSI_ARGS_((Tcl_Interp * interp, Itcl_CallFrame * framePtr)); /* 113 */ Var* (*_TclNewVar) _ANSI_ARGS_((void)); /* 114 */ void (*itcl_Assert) _ANSI_ARGS_((CONST char * testExpr, CONST char * fileName, int lineNum)); /* 115 */ int (*itcl_IsObjectCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 116 */ int (*itcl_IsClassCmd) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 117 */ } ItclIntStubs; TCL_EXTERNC ItclIntStubs *itclIntStubsPtr; #if defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) /* * Inline function declarations: */ #ifndef Itcl_IsClassNamespace #define Itcl_IsClassNamespace \ (itclIntStubsPtr->itcl_IsClassNamespace) /* 0 */ #endif #ifndef Itcl_IsClass #define Itcl_IsClass \ (itclIntStubsPtr->itcl_IsClass) /* 1 */ #endif #ifndef Itcl_FindClass #define Itcl_FindClass \ (itclIntStubsPtr->itcl_FindClass) /* 2 */ #endif #ifndef Itcl_FindObject #define Itcl_FindObject \ (itclIntStubsPtr->itcl_FindObject) /* 3 */ #endif #ifndef Itcl_IsObject #define Itcl_IsObject \ (itclIntStubsPtr->itcl_IsObject) /* 4 */ #endif #ifndef Itcl_ObjectIsa #define Itcl_ObjectIsa \ (itclIntStubsPtr->itcl_ObjectIsa) /* 5 */ #endif #ifndef Itcl_Protection #define Itcl_Protection \ (itclIntStubsPtr->itcl_Protection) /* 6 */ #endif #ifndef Itcl_ProtectionStr #define Itcl_ProtectionStr \ (itclIntStubsPtr->itcl_ProtectionStr) /* 7 */ #endif #ifndef Itcl_CanAccess #define Itcl_CanAccess \ (itclIntStubsPtr->itcl_CanAccess) /* 8 */ #endif #ifndef Itcl_CanAccessFunc #define Itcl_CanAccessFunc \ (itclIntStubsPtr->itcl_CanAccessFunc) /* 9 */ #endif #ifndef Itcl_GetTrueNamespace #define Itcl_GetTrueNamespace \ (itclIntStubsPtr->itcl_GetTrueNamespace) /* 10 */ #endif #ifndef Itcl_ParseNamespPath #define Itcl_ParseNamespPath \ (itclIntStubsPtr->itcl_ParseNamespPath) /* 11 */ #endif #ifndef Itcl_DecodeScopedCommand #define Itcl_DecodeScopedCommand \ (itclIntStubsPtr->itcl_DecodeScopedCommand) /* 12 */ #endif #ifndef Itcl_EvalArgs #define Itcl_EvalArgs \ (itclIntStubsPtr->itcl_EvalArgs) /* 13 */ #endif #ifndef Itcl_CreateArgs #define Itcl_CreateArgs \ (itclIntStubsPtr->itcl_CreateArgs) /* 14 */ #endif #ifndef Itcl_PushContext #define Itcl_PushContext \ (itclIntStubsPtr->itcl_PushContext) /* 15 */ #endif #ifndef Itcl_PopContext #define Itcl_PopContext \ (itclIntStubsPtr->itcl_PopContext) /* 16 */ #endif #ifndef Itcl_GetContext #define Itcl_GetContext \ (itclIntStubsPtr->itcl_GetContext) /* 17 */ #endif #ifndef Itcl_InitHierIter #define Itcl_InitHierIter \ (itclIntStubsPtr->itcl_InitHierIter) /* 18 */ #endif #ifndef Itcl_DeleteHierIter #define Itcl_DeleteHierIter \ (itclIntStubsPtr->itcl_DeleteHierIter) /* 19 */ #endif #ifndef Itcl_AdvanceHierIter #define Itcl_AdvanceHierIter \ (itclIntStubsPtr->itcl_AdvanceHierIter) /* 20 */ #endif #ifndef Itcl_FindClassesCmd #define Itcl_FindClassesCmd \ (itclIntStubsPtr->itcl_FindClassesCmd) /* 21 */ #endif #ifndef Itcl_FindObjectsCmd #define Itcl_FindObjectsCmd \ (itclIntStubsPtr->itcl_FindObjectsCmd) /* 22 */ #endif #ifndef Itcl_ProtectionCmd #define Itcl_ProtectionCmd \ (itclIntStubsPtr->itcl_ProtectionCmd) /* 23 */ #endif #ifndef Itcl_DelClassCmd #define Itcl_DelClassCmd \ (itclIntStubsPtr->itcl_DelClassCmd) /* 24 */ #endif #ifndef Itcl_DelObjectCmd #define Itcl_DelObjectCmd \ (itclIntStubsPtr->itcl_DelObjectCmd) /* 25 */ #endif #ifndef Itcl_ScopeCmd #define Itcl_ScopeCmd \ (itclIntStubsPtr->itcl_ScopeCmd) /* 26 */ #endif #ifndef Itcl_CodeCmd #define Itcl_CodeCmd \ (itclIntStubsPtr->itcl_CodeCmd) /* 27 */ #endif #ifndef Itcl_StubCreateCmd #define Itcl_StubCreateCmd \ (itclIntStubsPtr->itcl_StubCreateCmd) /* 28 */ #endif #ifndef Itcl_StubExistsCmd #define Itcl_StubExistsCmd \ (itclIntStubsPtr->itcl_StubExistsCmd) /* 29 */ #endif #ifndef Itcl_IsStub #define Itcl_IsStub \ (itclIntStubsPtr->itcl_IsStub) /* 30 */ #endif #ifndef Itcl_CreateClass #define Itcl_CreateClass \ (itclIntStubsPtr->itcl_CreateClass) /* 31 */ #endif #ifndef Itcl_DeleteClass #define Itcl_DeleteClass \ (itclIntStubsPtr->itcl_DeleteClass) /* 32 */ #endif #ifndef Itcl_FindClassNamespace #define Itcl_FindClassNamespace \ (itclIntStubsPtr->itcl_FindClassNamespace) /* 33 */ #endif #ifndef Itcl_HandleClass #define Itcl_HandleClass \ (itclIntStubsPtr->itcl_HandleClass) /* 34 */ #endif #ifndef Itcl_ClassCmdResolver #define Itcl_ClassCmdResolver \ (itclIntStubsPtr->itcl_ClassCmdResolver) /* 35 */ #endif #ifndef Itcl_ClassVarResolver #define Itcl_ClassVarResolver \ (itclIntStubsPtr->itcl_ClassVarResolver) /* 36 */ #endif #ifndef Itcl_ClassCompiledVarResolver #define Itcl_ClassCompiledVarResolver \ (itclIntStubsPtr->itcl_ClassCompiledVarResolver) /* 37 */ #endif #ifndef Itcl_BuildVirtualTables #define Itcl_BuildVirtualTables \ (itclIntStubsPtr->itcl_BuildVirtualTables) /* 38 */ #endif #ifndef Itcl_CreateVarDefn #define Itcl_CreateVarDefn \ (itclIntStubsPtr->itcl_CreateVarDefn) /* 39 */ #endif #ifndef Itcl_DeleteVarDefn #define Itcl_DeleteVarDefn \ (itclIntStubsPtr->itcl_DeleteVarDefn) /* 40 */ #endif #ifndef Itcl_GetCommonVar #define Itcl_GetCommonVar \ (itclIntStubsPtr->itcl_GetCommonVar) /* 41 */ #endif #ifndef Itcl_CreateMember #define Itcl_CreateMember \ (itclIntStubsPtr->itcl_CreateMember) /* 42 */ #endif #ifndef Itcl_DeleteMember #define Itcl_DeleteMember \ (itclIntStubsPtr->itcl_DeleteMember) /* 43 */ #endif #ifndef Itcl_CreateObject #define Itcl_CreateObject \ (itclIntStubsPtr->itcl_CreateObject) /* 44 */ #endif #ifndef Itcl_DeleteObject #define Itcl_DeleteObject \ (itclIntStubsPtr->itcl_DeleteObject) /* 45 */ #endif #ifndef Itcl_DestructObject #define Itcl_DestructObject \ (itclIntStubsPtr->itcl_DestructObject) /* 46 */ #endif #ifndef Itcl_HandleInstance #define Itcl_HandleInstance \ (itclIntStubsPtr->itcl_HandleInstance) /* 47 */ #endif #ifndef Itcl_GetInstanceVar #define Itcl_GetInstanceVar \ (itclIntStubsPtr->itcl_GetInstanceVar) /* 48 */ #endif #ifndef Itcl_ScopedVarResolver #define Itcl_ScopedVarResolver \ (itclIntStubsPtr->itcl_ScopedVarResolver) /* 49 */ #endif #ifndef Itcl_BodyCmd #define Itcl_BodyCmd \ (itclIntStubsPtr->itcl_BodyCmd) /* 50 */ #endif #ifndef Itcl_ConfigBodyCmd #define Itcl_ConfigBodyCmd \ (itclIntStubsPtr->itcl_ConfigBodyCmd) /* 51 */ #endif #ifndef Itcl_CreateMethod #define Itcl_CreateMethod \ (itclIntStubsPtr->itcl_CreateMethod) /* 52 */ #endif #ifndef Itcl_CreateProc #define Itcl_CreateProc \ (itclIntStubsPtr->itcl_CreateProc) /* 53 */ #endif #ifndef Itcl_CreateMemberFunc #define Itcl_CreateMemberFunc \ (itclIntStubsPtr->itcl_CreateMemberFunc) /* 54 */ #endif #ifndef Itcl_ChangeMemberFunc #define Itcl_ChangeMemberFunc \ (itclIntStubsPtr->itcl_ChangeMemberFunc) /* 55 */ #endif #ifndef Itcl_DeleteMemberFunc #define Itcl_DeleteMemberFunc \ (itclIntStubsPtr->itcl_DeleteMemberFunc) /* 56 */ #endif #ifndef Itcl_CreateMemberCode #define Itcl_CreateMemberCode \ (itclIntStubsPtr->itcl_CreateMemberCode) /* 57 */ #endif #ifndef Itcl_DeleteMemberCode #define Itcl_DeleteMemberCode \ (itclIntStubsPtr->itcl_DeleteMemberCode) /* 58 */ #endif #ifndef Itcl_GetMemberCode #define Itcl_GetMemberCode \ (itclIntStubsPtr->itcl_GetMemberCode) /* 59 */ #endif /* Slot 60 is reserved */ #ifndef Itcl_EvalMemberCode #define Itcl_EvalMemberCode \ (itclIntStubsPtr->itcl_EvalMemberCode) /* 61 */ #endif #ifndef Itcl_CreateArgList #define Itcl_CreateArgList \ (itclIntStubsPtr->itcl_CreateArgList) /* 62 */ #endif #ifndef Itcl_CreateArg #define Itcl_CreateArg \ (itclIntStubsPtr->itcl_CreateArg) /* 63 */ #endif #ifndef Itcl_DeleteArgList #define Itcl_DeleteArgList \ (itclIntStubsPtr->itcl_DeleteArgList) /* 64 */ #endif #ifndef Itcl_ArgList #define Itcl_ArgList \ (itclIntStubsPtr->itcl_ArgList) /* 65 */ #endif #ifndef Itcl_EquivArgLists #define Itcl_EquivArgLists \ (itclIntStubsPtr->itcl_EquivArgLists) /* 66 */ #endif #ifndef Itcl_GetMemberFuncUsage #define Itcl_GetMemberFuncUsage \ (itclIntStubsPtr->itcl_GetMemberFuncUsage) /* 67 */ #endif #ifndef Itcl_ExecMethod #define Itcl_ExecMethod \ (itclIntStubsPtr->itcl_ExecMethod) /* 68 */ #endif #ifndef Itcl_ExecProc #define Itcl_ExecProc \ (itclIntStubsPtr->itcl_ExecProc) /* 69 */ #endif #ifndef Itcl_AssignArgs #define Itcl_AssignArgs \ (itclIntStubsPtr->itcl_AssignArgs) /* 70 */ #endif #ifndef Itcl_ConstructBase #define Itcl_ConstructBase \ (itclIntStubsPtr->itcl_ConstructBase) /* 71 */ #endif #ifndef Itcl_InvokeMethodIfExists #define Itcl_InvokeMethodIfExists \ (itclIntStubsPtr->itcl_InvokeMethodIfExists) /* 72 */ #endif /* Slot 73 is reserved */ #ifndef Itcl_ReportFuncErrors #define Itcl_ReportFuncErrors \ (itclIntStubsPtr->itcl_ReportFuncErrors) /* 74 */ #endif #ifndef Itcl_ParseInit #define Itcl_ParseInit \ (itclIntStubsPtr->itcl_ParseInit) /* 75 */ #endif #ifndef Itcl_ClassCmd #define Itcl_ClassCmd \ (itclIntStubsPtr->itcl_ClassCmd) /* 76 */ #endif #ifndef Itcl_ClassInheritCmd #define Itcl_ClassInheritCmd \ (itclIntStubsPtr->itcl_ClassInheritCmd) /* 77 */ #endif #ifndef Itcl_ClassProtectionCmd #define Itcl_ClassProtectionCmd \ (itclIntStubsPtr->itcl_ClassProtectionCmd) /* 78 */ #endif #ifndef Itcl_ClassConstructorCmd #define Itcl_ClassConstructorCmd \ (itclIntStubsPtr->itcl_ClassConstructorCmd) /* 79 */ #endif #ifndef Itcl_ClassDestructorCmd #define Itcl_ClassDestructorCmd \ (itclIntStubsPtr->itcl_ClassDestructorCmd) /* 80 */ #endif #ifndef Itcl_ClassMethodCmd #define Itcl_ClassMethodCmd \ (itclIntStubsPtr->itcl_ClassMethodCmd) /* 81 */ #endif #ifndef Itcl_ClassProcCmd #define Itcl_ClassProcCmd \ (itclIntStubsPtr->itcl_ClassProcCmd) /* 82 */ #endif #ifndef Itcl_ClassVariableCmd #define Itcl_ClassVariableCmd \ (itclIntStubsPtr->itcl_ClassVariableCmd) /* 83 */ #endif #ifndef Itcl_ClassCommonCmd #define Itcl_ClassCommonCmd \ (itclIntStubsPtr->itcl_ClassCommonCmd) /* 84 */ #endif #ifndef Itcl_ParseVarResolver #define Itcl_ParseVarResolver \ (itclIntStubsPtr->itcl_ParseVarResolver) /* 85 */ #endif #ifndef Itcl_BiInit #define Itcl_BiInit \ (itclIntStubsPtr->itcl_BiInit) /* 86 */ #endif #ifndef Itcl_InstallBiMethods #define Itcl_InstallBiMethods \ (itclIntStubsPtr->itcl_InstallBiMethods) /* 87 */ #endif #ifndef Itcl_BiIsaCmd #define Itcl_BiIsaCmd \ (itclIntStubsPtr->itcl_BiIsaCmd) /* 88 */ #endif #ifndef Itcl_BiConfigureCmd #define Itcl_BiConfigureCmd \ (itclIntStubsPtr->itcl_BiConfigureCmd) /* 89 */ #endif #ifndef Itcl_BiCgetCmd #define Itcl_BiCgetCmd \ (itclIntStubsPtr->itcl_BiCgetCmd) /* 90 */ #endif #ifndef Itcl_BiChainCmd #define Itcl_BiChainCmd \ (itclIntStubsPtr->itcl_BiChainCmd) /* 91 */ #endif #ifndef Itcl_BiInfoClassCmd #define Itcl_BiInfoClassCmd \ (itclIntStubsPtr->itcl_BiInfoClassCmd) /* 92 */ #endif #ifndef Itcl_BiInfoInheritCmd #define Itcl_BiInfoInheritCmd \ (itclIntStubsPtr->itcl_BiInfoInheritCmd) /* 93 */ #endif #ifndef Itcl_BiInfoHeritageCmd #define Itcl_BiInfoHeritageCmd \ (itclIntStubsPtr->itcl_BiInfoHeritageCmd) /* 94 */ #endif #ifndef Itcl_BiInfoFunctionCmd #define Itcl_BiInfoFunctionCmd \ (itclIntStubsPtr->itcl_BiInfoFunctionCmd) /* 95 */ #endif #ifndef Itcl_BiInfoVariableCmd #define Itcl_BiInfoVariableCmd \ (itclIntStubsPtr->itcl_BiInfoVariableCmd) /* 96 */ #endif #ifndef Itcl_BiInfoBodyCmd #define Itcl_BiInfoBodyCmd \ (itclIntStubsPtr->itcl_BiInfoBodyCmd) /* 97 */ #endif #ifndef Itcl_BiInfoArgsCmd #define Itcl_BiInfoArgsCmd \ (itclIntStubsPtr->itcl_BiInfoArgsCmd) /* 98 */ #endif #ifndef Itcl_DefaultInfoCmd #define Itcl_DefaultInfoCmd \ (itclIntStubsPtr->itcl_DefaultInfoCmd) /* 99 */ #endif #ifndef Itcl_EnsembleInit #define Itcl_EnsembleInit \ (itclIntStubsPtr->itcl_EnsembleInit) /* 100 */ #endif #ifndef Itcl_CreateEnsemble #define Itcl_CreateEnsemble \ (itclIntStubsPtr->itcl_CreateEnsemble) /* 101 */ #endif #ifndef Itcl_AddEnsemblePart #define Itcl_AddEnsemblePart \ (itclIntStubsPtr->itcl_AddEnsemblePart) /* 102 */ #endif #ifndef Itcl_GetEnsemblePart #define Itcl_GetEnsemblePart \ (itclIntStubsPtr->itcl_GetEnsemblePart) /* 103 */ #endif #ifndef Itcl_IsEnsemble #define Itcl_IsEnsemble \ (itclIntStubsPtr->itcl_IsEnsemble) /* 104 */ #endif #ifndef Itcl_GetEnsembleUsage #define Itcl_GetEnsembleUsage \ (itclIntStubsPtr->itcl_GetEnsembleUsage) /* 105 */ #endif #ifndef Itcl_GetEnsembleUsageForObj #define Itcl_GetEnsembleUsageForObj \ (itclIntStubsPtr->itcl_GetEnsembleUsageForObj) /* 106 */ #endif #ifndef Itcl_EnsembleCmd #define Itcl_EnsembleCmd \ (itclIntStubsPtr->itcl_EnsembleCmd) /* 107 */ #endif #ifndef Itcl_EnsPartCmd #define Itcl_EnsPartCmd \ (itclIntStubsPtr->itcl_EnsPartCmd) /* 108 */ #endif #ifndef Itcl_EnsembleErrorCmd #define Itcl_EnsembleErrorCmd \ (itclIntStubsPtr->itcl_EnsembleErrorCmd) /* 109 */ #endif /* Slot 110 is reserved */ /* Slot 111 is reserved */ #ifndef _Tcl_GetCallFrame #define _Tcl_GetCallFrame \ (itclIntStubsPtr->_Tcl_GetCallFrame) /* 112 */ #endif #ifndef _Tcl_ActivateCallFrame #define _Tcl_ActivateCallFrame \ (itclIntStubsPtr->_Tcl_ActivateCallFrame) /* 113 */ #endif #ifndef _TclNewVar #define _TclNewVar \ (itclIntStubsPtr->_TclNewVar) /* 114 */ #endif #ifndef Itcl_Assert #define Itcl_Assert \ (itclIntStubsPtr->itcl_Assert) /* 115 */ #endif #ifndef Itcl_IsObjectCmd #define Itcl_IsObjectCmd \ (itclIntStubsPtr->itcl_IsObjectCmd) /* 116 */ #endif #ifndef Itcl_IsClassCmd #define Itcl_IsClassCmd \ (itclIntStubsPtr->itcl_IsClassCmd) /* 117 */ #endif #endif /* defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _ITCLINTDECLS */ itcl3.4.3/generic/itcl_parse.c0000644003604700454610000010251612536627705014721 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 * ======================================================================== * 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" /* * Info needed for public/protected/private commands: */ typedef struct ProtectionCmdInfo { int pLevel; /* protection level */ ItclObjectInfo *info; /* info regarding all known objects */ } ProtectionCmdInfo; /* * FORWARD DECLARATIONS */ static void ItclFreeParserCommandData _ANSI_ARGS_((char* cdata)); /* * ------------------------------------------------------------------------ * 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(interp, info) Tcl_Interp *interp; /* interpreter to be updated */ ItclObjectInfo *info; /* info regarding all known objects */ { Tcl_Namespace *parserNs; ProtectionCmdInfo *pInfo; /* * Create the "itcl::parser" namespace used to parse class * definitions. */ parserNs = Tcl_CreateNamespace(interp, "::itcl::parser", (ClientData)info, Itcl_ReleaseData); if (!parserNs) { Tcl_AppendResult(interp, " (cannot initialize itcl parser)", (char*)NULL); return TCL_ERROR; } Itcl_PreserveData((ClientData)info); /* * Add commands for parsing class definitions. */ Tcl_CreateObjCommand(interp, "::itcl::parser::inherit", Itcl_ClassInheritCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::constructor", Itcl_ClassConstructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::destructor", Itcl_ClassDestructorCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::method", Itcl_ClassMethodCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::proc", Itcl_ClassProcCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::common", Itcl_ClassCommonCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itcl::parser::variable", Itcl_ClassVariableCmd, (ClientData)info, (Tcl_CmdDeleteProc*)NULL); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PUBLIC; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::public", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PROTECTED; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::protected", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); pInfo = (ProtectionCmdInfo*)ckalloc(sizeof(ProtectionCmdInfo)); pInfo->pLevel = ITCL_PRIVATE; pInfo->info = info; Tcl_CreateObjCommand(interp, "::itcl::parser::private", Itcl_ClassProtectionCmd, (ClientData)pInfo, (Tcl_CmdDeleteProc*) ItclFreeParserCommandData); /* * Set the runtime variable resolver for the parser namespace, * to control access to "common" data members while parsing * the class definition. */ Tcl_SetNamespaceResolvers(parserNs, (Tcl_ResolveCmdProc*)NULL, Itcl_ParseVarResolver, (Tcl_ResolveCompiledVarProc*)NULL); /* * Install the "class" command for defining new classes. */ Tcl_CreateObjCommand(interp, "::itcl::class", Itcl_ClassCmd, (ClientData)info, Itcl_ReleaseData); Itcl_PreserveData((ClientData)info); 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 ... * } * * ------------------------------------------------------------------------ */ int Itcl_ClassCmd(clientData, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo* info = (ItclObjectInfo*)clientData; int result, len; char *className; Tcl_Namespace *parserNs; ItclClass *cdefnPtr; Itcl_CallFrame frame; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "name { definition }"); return TCL_ERROR; } className = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { Tcl_AppendResult(interp, "invalid class name \"\"", (char *) NULL); return TCL_ERROR; } /* * 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", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (parserNs == NULL) { char msg[256]; sprintf(msg, "\n (while parsing class definition for \"%.100s\")", className); Tcl_AddErrorInfo(interp, msg); return TCL_ERROR; } /* * Try to create the specified class and its namespace. */ if (Itcl_CreateClass(interp, className, info, &cdefnPtr) != TCL_OK) { return TCL_ERROR; } /* * 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, cdefnPtr->namesp, "::itcl::builtin::*", /* allowOverwrite */ 1); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while installing built-in commands for class \"%.100s\")", className); Tcl_AddErrorInfo(interp, msg); Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * 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((ClientData)cdefnPtr, &info->cdefnStack); result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, parserNs, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = Tcl_EvalObj(interp, objv[2]); Tcl_PopCallFrame(interp); } Itcl_PopStack(&info->cdefnStack); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (class \"%.200s\" body line %d)", className, Tcl_GetErrorLine(interp)); Tcl_AddErrorInfo(interp, msg); Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * 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, cdefnPtr) != TCL_OK) { Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_ERROR; } /* * Build the name resolution tables for all data members. */ Itcl_BuildVirtualTables(cdefnPtr); Tcl_ResetResult(interp); return TCL_OK; } /* * ------------------------------------------------------------------------ * 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); int result, i, newEntry = 1; char *token; Itcl_ListElem *elem, *elem2; ItclClass *cdPtr, *baseCdefnPtr, *badCdPtr; ItclHierIter hier; Itcl_Stack stack; Itcl_CallFrame frame; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "class ?class...?"); return TCL_ERROR; } /* * In "inherit" statement can only be included once in a * class definition. */ elem = Itcl_FirstListElem(&cdefnPtr->bases); if (elem != NULL) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "inheritance \"", -1); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendResult(interp, cdPtr->name, " ", (char*)NULL); elem = Itcl_NextListElem(elem); } Tcl_AppendResult(interp, "\" already defined for class \"", cdefnPtr->fullname, "\"", (char*)NULL); return TCL_ERROR; } /* * Validate each base class and add it to the "bases" list. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, cdefnPtr->namesp->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); baseCdefnPtr = Itcl_FindClass(interp, token, /* autoload */ 1); if (!baseCdefnPtr) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); int errlen; char *errmsg; Tcl_IncrRefCount(resultPtr); errmsg = Tcl_GetStringFromObj(resultPtr, &errlen); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot inherit from \"", token, "\"", (char*)NULL); if (errlen > 0) { Tcl_AppendResult(interp, " (", errmsg, ")", (char*)NULL); } Tcl_DecrRefCount(resultPtr); goto inheritError; } /* * Make sure that the base class is not the same as the * class that is being built. */ if (baseCdefnPtr == cdefnPtr) { Tcl_AppendResult(interp, "class \"", cdefnPtr->name, "\" cannot inherit from itself", (char*)NULL); goto inheritError; } Itcl_AppendList(&cdefnPtr->bases, (ClientData)baseCdefnPtr); Itcl_PreserveData((ClientData)baseCdefnPtr); } /* * Scan through the inheritance list to make sure that no * class appears twice. */ elem = Itcl_FirstListElem(&cdefnPtr->bases); while (elem) { elem2 = Itcl_NextListElem(elem); while (elem2) { if (Itcl_GetListValue(elem) == Itcl_GetListValue(elem2)) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_AppendResult(interp, "class \"", cdefnPtr->fullname, "\" cannot inherit base class \"", cdPtr->fullname, "\" more than once", (char*)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, cdefnPtr); cdPtr = Itcl_AdvanceHierIter(&hier); /* skip the class itself */ cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr != NULL) { (void) Tcl_CreateHashEntry(&cdefnPtr->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) { badCdPtr = cdPtr; Tcl_AppendResult(interp, "class \"", cdefnPtr->fullname, "\" inherits base class \"", badCdPtr->fullname, "\" more than once:", (char*)NULL); cdPtr = cdefnPtr; Itcl_InitStack(&stack); Itcl_PushStack((ClientData)cdPtr, &stack); /* * Show paths leading to bad base class */ while (Itcl_GetStackSize(&stack) > 0) { cdPtr = (ItclClass*)Itcl_PopStack(&stack); if (cdPtr == badCdPtr) { Tcl_AppendResult(interp, "\n ", (char *) NULL); for (i=0; i < Itcl_GetStackSize(&stack); i++) { if (Itcl_GetStackValue(&stack, i) == NULL) { cdPtr = (ItclClass*)Itcl_GetStackValue(&stack, i-1); Tcl_AppendResult(interp, cdPtr->name, "->", (char*)NULL); } } Tcl_AppendResult(interp, badCdPtr->name, (char *) NULL); } else if (!cdPtr) { (void)Itcl_PopStack(&stack); } else { elem = Itcl_LastListElem(&cdPtr->bases); if (elem) { Itcl_PushStack((ClientData)cdPtr, &stack); Itcl_PushStack((ClientData)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. */ elem = Itcl_FirstListElem(&cdefnPtr->bases); while (elem) { baseCdefnPtr = (ItclClass*)Itcl_GetListValue(elem); Itcl_AppendList(&baseCdefnPtr->derived, (ClientData)cdefnPtr); Itcl_PreserveData((ClientData)cdefnPtr); elem = Itcl_NextListElem(elem); } Tcl_PopCallFrame(interp); return TCL_OK; /* * If the "inherit" list cannot be built properly, tear it * down and return an error. */ inheritError: Tcl_PopCallFrame(interp); elem = Itcl_FirstListElem(&cdefnPtr->bases); while (elem) { Itcl_ReleaseData( 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, interp, objc, objv) 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; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?arg arg...?"); return TCL_ERROR; } oldLevel = Itcl_Protection(interp, pInfo->pLevel); if (objc == 2) { result = Tcl_EvalObj(interp, objv[1]); } else { result = Itcl_EvalArgs(interp, objc-1, objv+1); } if (result == TCL_BREAK) { Tcl_SetResult(interp, "invoked \"break\" outside of a loop", TCL_STATIC); result = TCL_ERROR; } else if (result == TCL_CONTINUE) { Tcl_SetResult(interp, "invoked \"continue\" outside of a loop", TCL_STATIC); result = TCL_ERROR; } else if (result != TCL_OK) { char mesg[256], *token; token = Tcl_GetStringFromObj(objv[0], (int*)NULL); sprintf(mesg, "\n (%.100s body line %d)", token, Tcl_GetErrorLine(interp)); Tcl_AddErrorInfo(interp, mesg); } 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); char *name, *arglist, *body; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "args ?init? body"); return TCL_ERROR; } name = Tcl_GetStringFromObj(objv[0], (int*)NULL); if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) { Tcl_AppendResult(interp, "\"", name, "\" already defined in class \"", cdefnPtr->fullname, "\"", (char*)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 { cdefnPtr->initCode = Tcl_DuplicateObj(objv[2]); Tcl_IncrRefCount(cdefnPtr->initCode); body = Tcl_GetString(objv[3]); } if (Itcl_CreateMethod(interp, cdefnPtr, name, 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); char *name, *body; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); return TCL_ERROR; } name = Tcl_GetStringFromObj(objv[0], (int*)NULL); body = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (Tcl_FindHashEntry(&cdefnPtr->functions, name)) { Tcl_AppendResult(interp, "\"", name, "\" already defined in class \"", cdefnPtr->fullname, "\"", (char*)NULL); return TCL_ERROR; } if (Itcl_CreateMethod(interp, cdefnPtr, name, (char*)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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); char *name, *arglist, *body; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } name = Tcl_GetStringFromObj(objv[1], (int*)NULL); arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); } if (objc >= 4) { body = Tcl_GetStringFromObj(objv[3], (int*)NULL); } if (Itcl_CreateMethod(interp, cdefnPtr, name, 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); char *name, *arglist, *body; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?args? ?body?"); return TCL_ERROR; } name = Tcl_GetStringFromObj(objv[1], (int*)NULL); arglist = NULL; body = NULL; if (objc >= 3) { arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); } if (objc >= 4) { body = Tcl_GetStringFromObj(objv[3], (int*)NULL); } if (Itcl_CreateProc(interp, cdefnPtr, name, arglist, body) != TCL_OK) { return TCL_ERROR; } 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); int pLevel; ItclVarDefn *vdefn; char *name, *init, *config; pLevel = Itcl_Protection(interp, 0); if (pLevel == ITCL_PUBLIC) { if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "name ?init? ?config?"); return TCL_ERROR; } } else if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "name ?init?"); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ name = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (strstr(name, "::")) { Tcl_AppendResult(interp, "bad variable name \"", name, "\"", (char*)NULL); return TCL_ERROR; } init = NULL; config = NULL; if (objc >= 3) { init = Tcl_GetStringFromObj(objv[2], (int*)NULL); } if (objc >= 4) { config = Tcl_GetStringFromObj(objv[3], (int*)NULL); } if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, config, &vdefn) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * 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, interp, objc, objv) ClientData clientData; /* info for all known objects */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclObjectInfo *info = (ItclObjectInfo*)clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); int newEntry; char *name, *init; ItclVarDefn *vdefn; Namespace *nsPtr; Var *varPtr; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "varname ?init?"); return TCL_ERROR; } /* * Make sure that the variable name does not contain anything * goofy like a "::" scope qualifier. */ name = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (strstr(name, "::")) { Tcl_AppendResult(interp, "bad variable name \"", name, "\"", (char*)NULL); return TCL_ERROR; } init = NULL; if (objc >= 3) { init = Tcl_GetStringFromObj(objv[2], (int*)NULL); } if (Itcl_CreateVarDefn(interp, cdefnPtr, name, init, (char*)NULL, &vdefn) != TCL_OK) { return TCL_ERROR; } vdefn->member->flags |= ITCL_COMMON; /* * 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. */ nsPtr = (Namespace*)cdefnPtr->namesp; varPtr = ItclVarHashCreateVar(&nsPtr->varTable, vdefn->member->name, &newEntry); #if ITCL_TCL_PRE_8_5 if (newEntry && itclOldRuntime) { varPtr->nsPtr = nsPtr; } #endif TclSetVarNamespaceVar(varPtr); ItclVarRefCount(varPtr)++; /* another use by class */ /* * TRICKY NOTE: Make sure to rebuild the virtual tables for this * class so that this variable is ready to access. The variable * resolver for the parser namespace needs this info to find the * variable if the developer tries to set it within the class * definition. * * If an initialization value was specified, then initialize * the variable now. */ Itcl_BuildVirtualTables(cdefnPtr); if (init) { CONST char *val = Tcl_SetVar(interp, vdefn->member->name, init, TCL_NAMESPACE_ONLY); if (!val) { Tcl_AppendResult(interp, "cannot initialize common variable \"", vdefn->member->name, "\"", (char*)NULL); return TCL_ERROR; } } return TCL_OK; } /* * ------------------------------------------------------------------------ * 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(interp, name, contextNs, flags, rPtr) 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 *info = (ItclObjectInfo*)contextNs->clientData; ItclClass *cdefnPtr = (ItclClass*)Itcl_PeekStack(&info->cdefnStack); Tcl_HashEntry *entry; ItclVarLookup *vlookup; /* * See if the requested variable is a recognized "common" member. * If it is, make sure that access is allowed. */ entry = Tcl_FindHashEntry(&cdefnPtr->resolveVars, name); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { if (!vlookup->accessible) { Tcl_AppendResult(interp, "can't access \"", name, "\": ", Itcl_ProtectionStr(vlookup->vdefn->member->protection), " variable", (char*)NULL); return TCL_ERROR; } *rPtr = vlookup->var.common; return TCL_OK; } } /* * If the variable is not recognized, return TCL_CONTINUE and * let lookup continue via the normal name resolution rules. * This is important for variables like "errorInfo" * that might get set while the parser namespace is active. */ return TCL_CONTINUE; } /* * ------------------------------------------------------------------------ * 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(cdata) char* cdata; /* client data to be destroyed */ { ckfree(cdata); } itcl3.4.3/generic/itclDecls.h0000644003604700454610000002537512536627705014516 0ustar dgp771div/* * itclDecls.h -- * * Declarations of functions in the platform independent public Itcl API. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _ITCLDECLS #define _ITCLDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the itcl/generic/tcl.decls script. */ /* !BEGIN!: Do not edit below this line. */ /* * Exported function declarations: */ #ifndef Itcl_Init_TCL_DECLARED #define Itcl_Init_TCL_DECLARED /* 0 */ TCL_EXTERN(int) Itcl_Init _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_SafeInit_TCL_DECLARED #define Itcl_SafeInit_TCL_DECLARED /* 1 */ TCL_EXTERN(int) Itcl_SafeInit _ANSI_ARGS_((Tcl_Interp * interp)); #endif #ifndef Itcl_RegisterC_TCL_DECLARED #define Itcl_RegisterC_TCL_DECLARED /* 2 */ TCL_EXTERN(int) Itcl_RegisterC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_RegisterObjC_TCL_DECLARED #define Itcl_RegisterObjC_TCL_DECLARED /* 3 */ TCL_EXTERN(int) Itcl_RegisterObjC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); #endif #ifndef Itcl_FindC_TCL_DECLARED #define Itcl_FindC_TCL_DECLARED /* 4 */ TCL_EXTERN(int) Itcl_FindC _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc ** argProcPtr, Tcl_ObjCmdProc ** objProcPtr, ClientData * cDataPtr)); #endif #ifndef Itcl_InitStack_TCL_DECLARED #define Itcl_InitStack_TCL_DECLARED /* 5 */ TCL_EXTERN(void) Itcl_InitStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_DeleteStack_TCL_DECLARED #define Itcl_DeleteStack_TCL_DECLARED /* 6 */ TCL_EXTERN(void) Itcl_DeleteStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_PushStack_TCL_DECLARED #define Itcl_PushStack_TCL_DECLARED /* 7 */ TCL_EXTERN(void) Itcl_PushStack _ANSI_ARGS_((ClientData cdata, Itcl_Stack * stack)); #endif #ifndef Itcl_PopStack_TCL_DECLARED #define Itcl_PopStack_TCL_DECLARED /* 8 */ TCL_EXTERN(ClientData) Itcl_PopStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_PeekStack_TCL_DECLARED #define Itcl_PeekStack_TCL_DECLARED /* 9 */ TCL_EXTERN(ClientData) Itcl_PeekStack _ANSI_ARGS_((Itcl_Stack * stack)); #endif #ifndef Itcl_GetStackValue_TCL_DECLARED #define Itcl_GetStackValue_TCL_DECLARED /* 10 */ TCL_EXTERN(ClientData) Itcl_GetStackValue _ANSI_ARGS_((Itcl_Stack * stack, int pos)); #endif #ifndef Itcl_InitList_TCL_DECLARED #define Itcl_InitList_TCL_DECLARED /* 11 */ TCL_EXTERN(void) Itcl_InitList _ANSI_ARGS_((Itcl_List * listPtr)); #endif #ifndef Itcl_DeleteList_TCL_DECLARED #define Itcl_DeleteList_TCL_DECLARED /* 12 */ TCL_EXTERN(void) Itcl_DeleteList _ANSI_ARGS_((Itcl_List * listPtr)); #endif #ifndef Itcl_CreateListElem_TCL_DECLARED #define Itcl_CreateListElem_TCL_DECLARED /* 13 */ TCL_EXTERN(Itcl_ListElem*) Itcl_CreateListElem _ANSI_ARGS_(( Itcl_List * listPtr)); #endif #ifndef Itcl_DeleteListElem_TCL_DECLARED #define Itcl_DeleteListElem_TCL_DECLARED /* 14 */ TCL_EXTERN(Itcl_ListElem*) Itcl_DeleteListElem _ANSI_ARGS_(( Itcl_ListElem * elemPtr)); #endif #ifndef Itcl_InsertList_TCL_DECLARED #define Itcl_InsertList_TCL_DECLARED /* 15 */ TCL_EXTERN(Itcl_ListElem*) Itcl_InsertList _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); #endif #ifndef Itcl_InsertListElem_TCL_DECLARED #define Itcl_InsertListElem_TCL_DECLARED /* 16 */ TCL_EXTERN(Itcl_ListElem*) Itcl_InsertListElem _ANSI_ARGS_(( Itcl_ListElem * pos, ClientData val)); #endif #ifndef Itcl_AppendList_TCL_DECLARED #define Itcl_AppendList_TCL_DECLARED /* 17 */ TCL_EXTERN(Itcl_ListElem*) Itcl_AppendList _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); #endif #ifndef Itcl_AppendListElem_TCL_DECLARED #define Itcl_AppendListElem_TCL_DECLARED /* 18 */ TCL_EXTERN(Itcl_ListElem*) Itcl_AppendListElem _ANSI_ARGS_(( Itcl_ListElem * pos, ClientData val)); #endif #ifndef Itcl_SetListValue_TCL_DECLARED #define Itcl_SetListValue_TCL_DECLARED /* 19 */ TCL_EXTERN(void) Itcl_SetListValue _ANSI_ARGS_(( Itcl_ListElem * elemPtr, ClientData val)); #endif #ifndef Itcl_EventuallyFree_TCL_DECLARED #define Itcl_EventuallyFree_TCL_DECLARED /* 20 */ TCL_EXTERN(void) Itcl_EventuallyFree _ANSI_ARGS_((ClientData cdata, Tcl_FreeProc * fproc)); #endif #ifndef Itcl_PreserveData_TCL_DECLARED #define Itcl_PreserveData_TCL_DECLARED /* 21 */ TCL_EXTERN(void) Itcl_PreserveData _ANSI_ARGS_((ClientData cdata)); #endif #ifndef Itcl_ReleaseData_TCL_DECLARED #define Itcl_ReleaseData_TCL_DECLARED /* 22 */ TCL_EXTERN(void) Itcl_ReleaseData _ANSI_ARGS_((ClientData cdata)); #endif #ifndef Itcl_SaveInterpState_TCL_DECLARED #define Itcl_SaveInterpState_TCL_DECLARED /* 23 */ TCL_EXTERN(Itcl_InterpState) Itcl_SaveInterpState _ANSI_ARGS_(( Tcl_Interp* interp, int status)); #endif #ifndef Itcl_RestoreInterpState_TCL_DECLARED #define Itcl_RestoreInterpState_TCL_DECLARED /* 24 */ TCL_EXTERN(int) Itcl_RestoreInterpState _ANSI_ARGS_(( Tcl_Interp* interp, Itcl_InterpState state)); #endif #ifndef Itcl_DiscardInterpState_TCL_DECLARED #define Itcl_DiscardInterpState_TCL_DECLARED /* 25 */ TCL_EXTERN(void) Itcl_DiscardInterpState _ANSI_ARGS_(( Itcl_InterpState state)); #endif typedef struct ItclStubHooks { struct ItclIntStubs *itclIntStubs; } ItclStubHooks; typedef struct ItclStubs { int magic; struct ItclStubHooks *hooks; int (*itcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 0 */ int (*itcl_SafeInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 1 */ int (*itcl_RegisterC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 2 */ int (*itcl_RegisterObjC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ObjCmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 3 */ int (*itcl_FindC) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_CmdProc ** argProcPtr, Tcl_ObjCmdProc ** objProcPtr, ClientData * cDataPtr)); /* 4 */ void (*itcl_InitStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 5 */ void (*itcl_DeleteStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 6 */ void (*itcl_PushStack) _ANSI_ARGS_((ClientData cdata, Itcl_Stack * stack)); /* 7 */ ClientData (*itcl_PopStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 8 */ ClientData (*itcl_PeekStack) _ANSI_ARGS_((Itcl_Stack * stack)); /* 9 */ ClientData (*itcl_GetStackValue) _ANSI_ARGS_((Itcl_Stack * stack, int pos)); /* 10 */ void (*itcl_InitList) _ANSI_ARGS_((Itcl_List * listPtr)); /* 11 */ void (*itcl_DeleteList) _ANSI_ARGS_((Itcl_List * listPtr)); /* 12 */ Itcl_ListElem* (*itcl_CreateListElem) _ANSI_ARGS_((Itcl_List * listPtr)); /* 13 */ Itcl_ListElem* (*itcl_DeleteListElem) _ANSI_ARGS_((Itcl_ListElem * elemPtr)); /* 14 */ Itcl_ListElem* (*itcl_InsertList) _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); /* 15 */ Itcl_ListElem* (*itcl_InsertListElem) _ANSI_ARGS_((Itcl_ListElem * pos, ClientData val)); /* 16 */ Itcl_ListElem* (*itcl_AppendList) _ANSI_ARGS_((Itcl_List * listPtr, ClientData val)); /* 17 */ Itcl_ListElem* (*itcl_AppendListElem) _ANSI_ARGS_((Itcl_ListElem * pos, ClientData val)); /* 18 */ void (*itcl_SetListValue) _ANSI_ARGS_((Itcl_ListElem * elemPtr, ClientData val)); /* 19 */ void (*itcl_EventuallyFree) _ANSI_ARGS_((ClientData cdata, Tcl_FreeProc * fproc)); /* 20 */ void (*itcl_PreserveData) _ANSI_ARGS_((ClientData cdata)); /* 21 */ void (*itcl_ReleaseData) _ANSI_ARGS_((ClientData cdata)); /* 22 */ Itcl_InterpState (*itcl_SaveInterpState) _ANSI_ARGS_((Tcl_Interp* interp, int status)); /* 23 */ int (*itcl_RestoreInterpState) _ANSI_ARGS_((Tcl_Interp* interp, Itcl_InterpState state)); /* 24 */ void (*itcl_DiscardInterpState) _ANSI_ARGS_((Itcl_InterpState state)); /* 25 */ } ItclStubs; TCL_EXTERNC ItclStubs *itclStubsPtr; #if defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) /* * Inline function declarations: */ #ifndef Itcl_Init #define Itcl_Init \ (itclStubsPtr->itcl_Init) /* 0 */ #endif #ifndef Itcl_SafeInit #define Itcl_SafeInit \ (itclStubsPtr->itcl_SafeInit) /* 1 */ #endif #ifndef Itcl_RegisterC #define Itcl_RegisterC \ (itclStubsPtr->itcl_RegisterC) /* 2 */ #endif #ifndef Itcl_RegisterObjC #define Itcl_RegisterObjC \ (itclStubsPtr->itcl_RegisterObjC) /* 3 */ #endif #ifndef Itcl_FindC #define Itcl_FindC \ (itclStubsPtr->itcl_FindC) /* 4 */ #endif #ifndef Itcl_InitStack #define Itcl_InitStack \ (itclStubsPtr->itcl_InitStack) /* 5 */ #endif #ifndef Itcl_DeleteStack #define Itcl_DeleteStack \ (itclStubsPtr->itcl_DeleteStack) /* 6 */ #endif #ifndef Itcl_PushStack #define Itcl_PushStack \ (itclStubsPtr->itcl_PushStack) /* 7 */ #endif #ifndef Itcl_PopStack #define Itcl_PopStack \ (itclStubsPtr->itcl_PopStack) /* 8 */ #endif #ifndef Itcl_PeekStack #define Itcl_PeekStack \ (itclStubsPtr->itcl_PeekStack) /* 9 */ #endif #ifndef Itcl_GetStackValue #define Itcl_GetStackValue \ (itclStubsPtr->itcl_GetStackValue) /* 10 */ #endif #ifndef Itcl_InitList #define Itcl_InitList \ (itclStubsPtr->itcl_InitList) /* 11 */ #endif #ifndef Itcl_DeleteList #define Itcl_DeleteList \ (itclStubsPtr->itcl_DeleteList) /* 12 */ #endif #ifndef Itcl_CreateListElem #define Itcl_CreateListElem \ (itclStubsPtr->itcl_CreateListElem) /* 13 */ #endif #ifndef Itcl_DeleteListElem #define Itcl_DeleteListElem \ (itclStubsPtr->itcl_DeleteListElem) /* 14 */ #endif #ifndef Itcl_InsertList #define Itcl_InsertList \ (itclStubsPtr->itcl_InsertList) /* 15 */ #endif #ifndef Itcl_InsertListElem #define Itcl_InsertListElem \ (itclStubsPtr->itcl_InsertListElem) /* 16 */ #endif #ifndef Itcl_AppendList #define Itcl_AppendList \ (itclStubsPtr->itcl_AppendList) /* 17 */ #endif #ifndef Itcl_AppendListElem #define Itcl_AppendListElem \ (itclStubsPtr->itcl_AppendListElem) /* 18 */ #endif #ifndef Itcl_SetListValue #define Itcl_SetListValue \ (itclStubsPtr->itcl_SetListValue) /* 19 */ #endif #ifndef Itcl_EventuallyFree #define Itcl_EventuallyFree \ (itclStubsPtr->itcl_EventuallyFree) /* 20 */ #endif #ifndef Itcl_PreserveData #define Itcl_PreserveData \ (itclStubsPtr->itcl_PreserveData) /* 21 */ #endif #ifndef Itcl_ReleaseData #define Itcl_ReleaseData \ (itclStubsPtr->itcl_ReleaseData) /* 22 */ #endif #ifndef Itcl_SaveInterpState #define Itcl_SaveInterpState \ (itclStubsPtr->itcl_SaveInterpState) /* 23 */ #endif #ifndef Itcl_RestoreInterpState #define Itcl_RestoreInterpState \ (itclStubsPtr->itcl_RestoreInterpState) /* 24 */ #endif #ifndef Itcl_DiscardInterpState #define Itcl_DiscardInterpState \ (itclStubsPtr->itcl_DiscardInterpState) /* 25 */ #endif #endif /* defined(USE_ITCL_STUBS) && !defined(USE_ITCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _ITCLDECLS */ itcl3.4.3/generic/itclInt.decls0000644003604700454610000003606212536627705015054 0ustar dgp771div# itclInt.decls -- # # This file contains the declarations for all unsupported # functions that are exported by the Itcl library. # # By "unsupported", it should be noted that due to Tcl's hiding # of the data types used, we inherit this hidden-ness ourselves, # too, unfortunately. # # Copyright (c) 1998-1999 by Scriptics Corporation. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. library itcl # Define the unsupported generic interfaces. interface itclInt # # Functions used within the package, but not considered "public" # declare 0 generic { int Itcl_IsClassNamespace(Tcl_Namespace *namesp) } declare 1 generic { int Itcl_IsClass (Tcl_Command cmd) } declare 2 generic { ItclClass* Itcl_FindClass (Tcl_Interp* interp, CONST char* path, int autoload) } declare 3 generic { int Itcl_FindObject (Tcl_Interp *interp, CONST char *name, ItclObject **roPtr) } declare 4 generic { int Itcl_IsObject (Tcl_Command cmd) } declare 5 generic { int Itcl_ObjectIsa (ItclObject *contextObj, ItclClass *cdefn) } declare 6 generic { int Itcl_Protection (Tcl_Interp *interp, int newLevel) } declare 7 generic { char* Itcl_ProtectionStr (int pLevel) } declare 8 generic { int Itcl_CanAccess (ItclMember* memberPtr, Tcl_Namespace* fromNsPtr) } declare 9 generic { int Itcl_CanAccessFunc (ItclMemberFunc* mfunc, Tcl_Namespace* fromNsPtr) } declare 10 generic { Tcl_Namespace* Itcl_GetTrueNamespace (Tcl_Interp *interp, \ ItclObjectInfo *info) } declare 11 generic { void Itcl_ParseNamespPath (CONST char *name, Tcl_DString *buffer, \ char **head, char **tail) } declare 12 generic { int Itcl_DecodeScopedCommand (Tcl_Interp *interp, CONST char *name, \ Tcl_Namespace **rNsPtr, char **rCmdPtr) } declare 13 generic { int Itcl_EvalArgs (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) } declare 14 generic { Tcl_Obj* Itcl_CreateArgs (Tcl_Interp *interp, CONST char *string, \ int objc, Tcl_Obj *CONST objv[]) } declare 15 generic { int Itcl_PushContext (Tcl_Interp *interp, ItclMember *member, \ ItclClass *contextClass, ItclObject *contextObj, \ ItclContext *contextPtr) } declare 16 generic { void Itcl_PopContext (Tcl_Interp *interp, ItclContext *contextPtr) } declare 17 generic { int Itcl_GetContext (Tcl_Interp *interp, ItclClass **cdefnPtr, \ ItclObject **odefnPtr) } declare 18 generic { void Itcl_InitHierIter (ItclHierIter *iter, ItclClass *cdefn) } declare 19 generic { void Itcl_DeleteHierIter (ItclHierIter *iter) } declare 20 generic { ItclClass* Itcl_AdvanceHierIter (ItclHierIter *iter) } declare 21 generic { int Itcl_FindClassesCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 22 generic { int Itcl_FindObjectsCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 23 generic { int Itcl_ProtectionCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 24 generic { int Itcl_DelClassCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 25 generic { int Itcl_DelObjectCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 26 generic { int Itcl_ScopeCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 27 generic { int Itcl_CodeCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 28 generic { int Itcl_StubCreateCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 29 generic { int Itcl_StubExistsCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 30 generic { int Itcl_IsStub (Tcl_Command cmd) } # # Functions for manipulating classes # declare 31 generic { int Itcl_CreateClass (Tcl_Interp* interp, CONST char* path, \ ItclObjectInfo *info, ItclClass **rPtr) } declare 32 generic { int Itcl_DeleteClass (Tcl_Interp *interp, ItclClass *cdefnPtr) } declare 33 generic { Tcl_Namespace* Itcl_FindClassNamespace (Tcl_Interp* interp, CONST char* path) } declare 34 generic { int Itcl_HandleClass (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 35 generic { int Itcl_ClassCmdResolver (Tcl_Interp *interp, CONST char* name, \ Tcl_Namespace *context, int flags, Tcl_Command *rPtr) } declare 36 generic { int Itcl_ClassVarResolver (Tcl_Interp *interp, CONST char* name, \ Tcl_Namespace *context, int flags, Tcl_Var *rPtr) } declare 37 generic { int Itcl_ClassCompiledVarResolver (Tcl_Interp *interp, CONST char* name, \ int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr) } declare 38 generic { void Itcl_BuildVirtualTables (ItclClass* cdefnPtr) } declare 39 generic { int Itcl_CreateVarDefn (Tcl_Interp *interp, ItclClass* cdefn, \ char* name, char* init, char* config, ItclVarDefn** vdefnPtr) } declare 40 generic { void Itcl_DeleteVarDefn (ItclVarDefn *vdefn) } declare 41 generic { CONST char* Itcl_GetCommonVar (Tcl_Interp *interp, CONST char *name, \ ItclClass *contextClass) } declare 42 generic { ItclMember* Itcl_CreateMember (Tcl_Interp* interp, ItclClass *cdefn, \ CONST char* name) } declare 43 generic { void Itcl_DeleteMember (ItclMember *memPtr) } # # Functions for manipulating objects # declare 44 generic { int Itcl_CreateObject (Tcl_Interp *interp, CONST char* name, ItclClass *cdefn, \ int objc, Tcl_Obj *CONST objv[], ItclObject **roPtr) } declare 45 generic { int Itcl_DeleteObject (Tcl_Interp *interp, ItclObject *contextObj) } declare 46 generic { int Itcl_DestructObject (Tcl_Interp *interp, ItclObject *contextObj, \ int flags) } declare 47 generic { int Itcl_HandleInstance (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 48 generic { CONST char* Itcl_GetInstanceVar (Tcl_Interp *interp, CONST char *name, \ ItclObject *contextObj, ItclClass *contextClass) } declare 49 generic { int Itcl_ScopedVarResolver (Tcl_Interp *interp, CONST char *name, \ Tcl_Namespace *contextNs, int flags, Tcl_Var *rPtr) } # # Functions for manipulating methods and procs # declare 50 generic { int Itcl_BodyCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 51 generic { int Itcl_ConfigBodyCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 52 generic { int Itcl_CreateMethod (Tcl_Interp* interp, ItclClass *cdefn, CONST char* name, CONST char* arglist, CONST char* body) } declare 53 generic { int Itcl_CreateProc (Tcl_Interp* interp, ItclClass *cdefn, CONST char* name, CONST char* arglist, CONST char* body) } declare 54 generic { int Itcl_CreateMemberFunc (Tcl_Interp* interp, ItclClass *cdefn, \ CONST char* name, CONST char* arglist, CONST char* body, \ ItclMemberFunc** mfuncPtr) } declare 55 generic { int Itcl_ChangeMemberFunc (Tcl_Interp* interp, ItclMemberFunc* mfunc, \ CONST char* arglist, CONST char* body) } declare 56 generic { void Itcl_DeleteMemberFunc (CONST char* cdata) } declare 57 generic { int Itcl_CreateMemberCode (Tcl_Interp* interp, ItclClass *cdefn, \ CONST char* arglist, CONST char* body, ItclMemberCode** mcodePtr) } declare 58 generic { void Itcl_DeleteMemberCode (CONST char* cdata) } declare 59 generic { int Itcl_GetMemberCode (Tcl_Interp* interp, ItclMember* member) } #declare 60 generic { # int Itcl_CompileMemberCodeBody (Tcl_Interp *interp, ItclMember *member, \ # char *desc, Tcl_Obj *bodyPtr) #} declare 61 generic { int Itcl_EvalMemberCode (Tcl_Interp *interp, ItclMemberFunc *mfunc, \ ItclMember *member, ItclObject *contextObj, int objc, \ Tcl_Obj *CONST objv[]) } declare 62 generic { int Itcl_CreateArgList (Tcl_Interp* interp, CONST char* decl, int* argcPtr, \ CompiledLocal** argPtr) } declare 63 generic { CompiledLocal* Itcl_CreateArg (CONST char* name, CONST char* init) } declare 64 generic { void Itcl_DeleteArgList (CompiledLocal *arglist) } declare 65 generic { Tcl_Obj* Itcl_ArgList (int argc, CompiledLocal* arglist) } declare 66 generic { int Itcl_EquivArgLists (CompiledLocal* arg1, int arg1c, \ CompiledLocal* arg2, int arg2c) } declare 67 generic { void Itcl_GetMemberFuncUsage (ItclMemberFunc *mfunc, \ ItclObject *contextObj, Tcl_Obj *objPtr) } declare 68 generic { int Itcl_ExecMethod (ClientData clientData, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 69 generic { int Itcl_ExecProc (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 70 generic { int Itcl_AssignArgs (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], \ ItclMemberFunc *mfunc) } declare 71 generic { int Itcl_ConstructBase (Tcl_Interp *interp, ItclObject *contextObj, \ ItclClass *contextClass) } declare 72 generic { int Itcl_InvokeMethodIfExists (Tcl_Interp *interp, CONST char *name, \ ItclClass *contextClass, ItclObject *contextObj, int objc, \ Tcl_Obj *CONST objv[]) } #declare 73 generic { # int Itcl_EvalBody (Tcl_Interp *interp, Tcl_Obj *bodyPtr) #} declare 74 generic { int Itcl_ReportFuncErrors (Tcl_Interp* interp, ItclMemberFunc *mfunc, \ ItclObject *contextObj, int result) } # # Commands for parsing class definitions # declare 75 generic { int Itcl_ParseInit (Tcl_Interp *interp, ItclObjectInfo *info) } declare 76 generic { int Itcl_ClassCmd (ClientData clientData, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 77 generic { int Itcl_ClassInheritCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 78 generic { int Itcl_ClassProtectionCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 79 generic { int Itcl_ClassConstructorCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 80 generic { int Itcl_ClassDestructorCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 81 generic { int Itcl_ClassMethodCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 82 generic { int Itcl_ClassProcCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 83 generic { int Itcl_ClassVariableCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 84 generic { int Itcl_ClassCommonCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 85 generic { int Itcl_ParseVarResolver (Tcl_Interp *interp, CONST char* name, \ Tcl_Namespace *contextNs, int flags, Tcl_Var* rPtr) } # # Commands in the "builtin" namespace # declare 86 generic { int Itcl_BiInit (Tcl_Interp *interp) } declare 87 generic { int Itcl_InstallBiMethods (Tcl_Interp *interp, ItclClass *cdefn) } declare 88 generic { int Itcl_BiIsaCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 89 generic { int Itcl_BiConfigureCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 90 generic { int Itcl_BiCgetCmd (ClientData clientData, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 91 generic { int Itcl_BiChainCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 92 generic { int Itcl_BiInfoClassCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 93 generic { int Itcl_BiInfoInheritCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 94 generic { int Itcl_BiInfoHeritageCmd (ClientData dummy, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 95 generic { int Itcl_BiInfoFunctionCmd (ClientData dummy, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 96 generic { int Itcl_BiInfoVariableCmd (ClientData dummy, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 97 generic { int Itcl_BiInfoBodyCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 98 generic { int Itcl_BiInfoArgsCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 99 generic { int Itcl_DefaultInfoCmd (ClientData dummy, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } # # Ensembles # declare 100 generic { int Itcl_EnsembleInit (Tcl_Interp *interp) } declare 101 generic { int Itcl_CreateEnsemble (Tcl_Interp *interp, CONST char* ensName) } declare 102 generic { int Itcl_AddEnsemblePart (Tcl_Interp *interp, CONST char* ensName, \ CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc *objProc, \ ClientData clientData, Tcl_CmdDeleteProc *deleteProc) } declare 103 generic { int Itcl_GetEnsemblePart (Tcl_Interp *interp, CONST char *ensName, \ CONST char *partName, Tcl_CmdInfo *infoPtr) } declare 104 generic { int Itcl_IsEnsemble (Tcl_CmdInfo* infoPtr) } declare 105 generic { int Itcl_GetEnsembleUsage (Tcl_Interp *interp, CONST char *ensName, \ Tcl_Obj *objPtr) } declare 106 generic { int Itcl_GetEnsembleUsageForObj (Tcl_Interp *interp, Tcl_Obj *ensObjPtr, \ Tcl_Obj *objPtr) } declare 107 generic { int Itcl_EnsembleCmd (ClientData clientData, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 108 generic { int Itcl_EnsPartCmd (ClientData clientData, Tcl_Interp *interp, int objc, \ Tcl_Obj *CONST objv[]) } declare 109 generic { int Itcl_EnsembleErrorCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } # # Commands provided for backward compatibility # # not used anymore (3.3) #declare 110 generic { # int Itcl_OldInit (Tcl_Interp* interp, ItclObjectInfo* info) #} #declare 111 generic { # int Itcl_InstallOldBiMethods (Tcl_Interp *interp, ItclClass *cdefn) #} # # Things that should be in the Tcl core. # declare 112 generic { Itcl_CallFrame* _Tcl_GetCallFrame (Tcl_Interp *interp, int level) } declare 113 generic { Itcl_CallFrame* _Tcl_ActivateCallFrame (Tcl_Interp *interp, \ Itcl_CallFrame *framePtr) } declare 114 generic { Var* _TclNewVar (void) } declare 115 generic { void Itcl_Assert (CONST char *testExpr, CONST char *fileName, int lineNum) } declare 116 generic { int Itcl_IsObjectCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } declare 117 generic { int Itcl_IsClassCmd (ClientData clientData, Tcl_Interp *interp, \ int objc, Tcl_Obj *CONST objv[]) } itcl3.4.3/generic/itcl.h0000644003604700454610000001461412660674743013537 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. * * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: * * To add [incr Tcl] facilities to a Tcl application, modify the * Tcl_AppInit() routine as follows: * * 1) Include this header file near the top of the file containing * Tcl_AppInit(): * * #include "itcl.h" * * 2) Within the body of Tcl_AppInit(), add the following lines: * * if (Itcl_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * 3) Link your application with libitcl.a * * NOTE: An example file "tclAppInit.c" containing the changes shown * above is included in this distribution. * * ======================================================================== * 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. */ #ifndef ITCL_H #define ITCL_H #include "tcl.h" #ifndef TCL_ALPHA_RELEASE # define TCL_ALPHA_RELEASE 0 #endif #ifndef TCL_BETA_RELEASE # define TCL_BETA_RELEASE 1 #endif #ifndef TCL_FINAL_RELEASE # define TCL_FINAL_RELEASE 2 #endif #define ITCL_MAJOR_VERSION 3 #define ITCL_MINOR_VERSION 4 #define ITCL_RELEASE_LEVEL TCL_FINAL_RELEASE #define ITCL_RELEASE_SERIAL 3 #define ITCL_VERSION "3.4" #define ITCL_PATCH_LEVEL "3.4.3" /* * A special definition used to allow this header file to be included * in resource files so that they can get obtain version information from * this file. Resource compilers don't like all the C stuff, like typedefs * and procedure declarations, that occur below. */ #ifndef RC_INVOKED #undef TCL_STORAGE_CLASS #ifdef BUILD_itcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_ITCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* * Fix the Borland bug that's in the EXTERN macro from tcl.h. */ #ifndef TCL_EXTERN # undef DLLIMPORT # undef DLLEXPORT # ifdef __cplusplus # define TCL_EXTERNC extern "C" # else # define TCL_EXTERNC extern # endif # if defined(STATIC_BUILD) # define DLLIMPORT # define DLLEXPORT # define TCL_EXTERN(RTYPE) TCL_EXTERNC RTYPE # elif (defined(__WIN32__) && ( \ defined(_MSC_VER) || (__BORLANDC__ >= 0x0550) || \ defined(__LCC__) || defined(__WATCOMC__) || \ (defined(__GNUC__) && defined(__declspec)) \ )) || (defined(MAC_TCL) && FUNCTION_DECLSPEC) # define DLLIMPORT __declspec(dllimport) # define DLLEXPORT __declspec(dllexport) # define TCL_EXTERN(RTYPE) TCL_EXTERNC TCL_STORAGE_CLASS RTYPE # elif defined(__BORLANDC__) # define DLLIMPORT __import # define DLLEXPORT __export /* Pre-5.5 Borland requires the attributes be placed after the */ /* return type instead. */ # define TCL_EXTERN(RTYPE) TCL_EXTERNC RTYPE TCL_STORAGE_CLASS # else # define DLLIMPORT # define DLLEXPORT # define TCL_EXTERN(RTYPE) TCL_EXTERNC TCL_STORAGE_CLASS RTYPE # endif #endif /* * Protection levels: * * ITCL_PUBLIC - accessible from any namespace * ITCL_PROTECTED - accessible from namespace that imports in "protected" mode * ITCL_PRIVATE - accessible only within the namespace that contains it */ #define ITCL_PUBLIC 1 #define ITCL_PROTECTED 2 #define ITCL_PRIVATE 3 #define ITCL_DEFAULT_PROTECT 4 /* * Generic stack. */ typedef struct Itcl_Stack { ClientData *values; /* values on stack */ int len; /* number of values on stack */ int max; /* maximum size of stack */ ClientData space[5]; /* initial space for stack data */ } Itcl_Stack; #define Itcl_GetStackSize(stackPtr) ((stackPtr)->len) /* * Generic linked list. */ struct Itcl_List; typedef struct Itcl_ListElem { struct Itcl_List* owner; /* list containing this element */ ClientData value; /* value associated with this element */ struct Itcl_ListElem *prev; /* previous element in linked list */ struct Itcl_ListElem *next; /* next element in linked list */ } Itcl_ListElem; typedef struct Itcl_List { int validate; /* validation stamp */ int num; /* number of elements */ struct Itcl_ListElem *head; /* previous element in linked list */ struct Itcl_ListElem *tail; /* next element in linked list */ } Itcl_List; #define Itcl_FirstListElem(listPtr) ((listPtr)->head) #define Itcl_LastListElem(listPtr) ((listPtr)->tail) #define Itcl_NextListElem(elemPtr) ((elemPtr)->next) #define Itcl_PrevListElem(elemPtr) ((elemPtr)->prev) #define Itcl_GetListLength(listPtr) ((listPtr)->num) #define Itcl_GetListValue(elemPtr) ((elemPtr)->value) /* * Token representing the state of an interpreter. */ typedef struct Itcl_InterpState_ *Itcl_InterpState; /* * Include the public function declarations that are accessible via * the stubs table. */ #include "itclDecls.h" /* * Itcl_InitStubs is used by extensions like Itk that can be linked * against the itcl stubs library. If we are not using stubs * then this reduces to package require. */ #ifdef USE_ITCL_STUBS TCL_EXTERNC CONST char * Itcl_InitStubs _ANSI_ARGS_((Tcl_Interp *interp, CONST char *version, int exact)); #else #define Itcl_InitStubs(interp, version, exact) \ Tcl_PkgRequire(interp, "Itcl", version, exact) #endif /* * Public functions that are not accessible via the stubs table. */ #endif /* RC_INVOKED */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* ITCL_H */ itcl3.4.3/generic/itcl_ensemble.c0000644003604700454610000020646612536627705015412 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 handles ensembles, which support compound commands in Tcl. * The usual "info" command is an ensemble with parts like "info body" * and "info globals". Extension developers can extend commands like * "info" by adding their own parts to the ensemble. * * ======================================================================== * 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" /* * Data used to represent an ensemble: */ struct Ensemble; typedef struct EnsemblePart { char *name; /* name of this part */ int minChars; /* chars needed to uniquely identify part */ Command *cmdPtr; /* command handling this part */ char *usage; /* usage string describing syntax */ struct Ensemble* ensemble; /* ensemble containing this part */ } EnsemblePart; /* * Data used to represent an ensemble: */ typedef struct Ensemble { Tcl_Interp *interp; /* interpreter containing this ensemble */ EnsemblePart **parts; /* list of parts in this ensemble */ int numParts; /* number of parts in part list */ int maxParts; /* current size of parts list */ Tcl_Command cmd; /* command representing this ensemble */ EnsemblePart* parent; /* parent part for sub-ensembles * NULL => toplevel ensemble */ } Ensemble; /* * Data shared by ensemble access commands and ensemble parser: */ typedef struct EnsembleParser { Tcl_Interp* master; /* master interp containing ensembles */ Tcl_Interp* parser; /* slave interp for parsing */ Ensemble* ensData; /* add parts to this ensemble */ } EnsembleParser; /* * Declarations for local procedures to this file: */ static void FreeEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static void DupEnsInvocInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static void UpdateStringOfEnsInvoc _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetEnsInvocFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* * This structure defines a Tcl object type that takes the * place of a part name during ensemble invocations. When an * error occurs and the caller tries to print objv[0], it will * get a string that contains a complete path to the ensemble * part. */ Tcl_ObjType itclEnsInvocType = { "ensembleInvoc", /* name */ FreeEnsInvocInternalRep, /* freeIntRepProc */ DupEnsInvocInternalRep, /* dupIntRepProc */ UpdateStringOfEnsInvoc, /* updateStringProc */ SetEnsInvocFromAny /* setFromAnyProc */ }; /* * Forward declarations for the procedures used in this file. */ static void GetEnsembleUsage _ANSI_ARGS_((Ensemble *ensData, Tcl_Obj *objPtr)); static void GetEnsemblePartUsage _ANSI_ARGS_((EnsemblePart *ensPart, Tcl_Obj *objPtr)); static int CreateEnsemble _ANSI_ARGS_((Tcl_Interp *interp, Ensemble *parentEnsData, CONST char *ensName)); static int AddEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble* ensData, CONST char* partName, CONST char* usageInfo, Tcl_ObjCmdProc *objProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc, EnsemblePart **rVal)); static void DeleteEnsemble _ANSI_ARGS_((ClientData clientData)); static int FindEnsemble _ANSI_ARGS_((Tcl_Interp *interp, CONST char **nameArgv, int nameArgc, Ensemble** ensDataPtr)); static int CreateEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble *ensData, CONST char* partName, EnsemblePart **ensPartPtr)); static void DeleteEnsemblePart _ANSI_ARGS_((EnsemblePart *ensPart)); static int FindEnsemblePart _ANSI_ARGS_((Tcl_Interp *interp, Ensemble *ensData, CONST char* partName, EnsemblePart **rensPart)); static int FindEnsemblePartIndex _ANSI_ARGS_((Ensemble *ensData, CONST char *partName, int *posPtr)); static void ComputeMinChars _ANSI_ARGS_((Ensemble *ensData, int pos)); static int HandleEnsemble _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static EnsembleParser* GetEnsembleParser _ANSI_ARGS_((Tcl_Interp *interp)); static void DeleteEnsParser _ANSI_ARGS_((ClientData clientData, Tcl_Interp* interp)); /* *---------------------------------------------------------------------- * * Itcl_EnsembleInit -- * * Called when any interpreter is created to make sure that * things are properly set up for ensembles. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes * wrong. * * Side effects: * On the first call, the "ensemble" object type is registered * with the Tcl compiler. If an error is encountered, an error * is left as the result in the interpreter. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Itcl_EnsembleInit(interp) Tcl_Interp *interp; /* interpreter being initialized */ { if (Tcl_GetObjType(itclEnsInvocType.name) == NULL) { Tcl_RegisterObjType(&itclEnsInvocType); } Tcl_CreateObjCommand(interp, "::itcl::ensemble", Itcl_EnsembleCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * Itcl_CreateEnsemble -- * * Creates an ensemble command, or adds a sub-ensemble to an * existing ensemble command. The ensemble name is a space- * separated list. The first word in the list is the command * name for the top-level ensemble. Other names do not have * commands associated with them; they are merely sub-ensembles * within the ensemble. So a name like "a::b::foo bar baz" * represents an ensemble command called "foo" in the namespace * "a::b" that has a sub-ensemble "bar", that has a sub-ensemble * "baz". * * If the name is a single word, then this procedure creates * a top-level ensemble and installs an access command for it. * If a command already exists with that name, it is deleted. * * If the name has more than one word, then the leading words * are treated as a path name for an existing ensemble. The * last word is treated as the name for a new sub-ensemble. * If an part already exists with that name, it is an error. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes * wrong. * * Side effects: * If an error is encountered, an error is left as the result * in the interpreter. * *---------------------------------------------------------------------- */ int Itcl_CreateEnsemble(interp, ensName) Tcl_Interp *interp; /* interpreter to be updated */ CONST char* ensName; /* name of the new ensemble */ { CONST char **nameArgv = NULL; int nameArgc; Ensemble *parentEnsData; Tcl_DString buffer; /* * Split the ensemble name into its path components. */ if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { goto ensCreateFail; } if (nameArgc < 1) { Tcl_AppendResult(interp, "invalid ensemble name \"", ensName, "\"", (char*)NULL); goto ensCreateFail; } /* * If there is more than one path component, then follow * the path down to the last component, to find the containing * ensemble. */ parentEnsData = NULL; if (nameArgc > 1) { if (FindEnsemble(interp, nameArgv, nameArgc-1, &parentEnsData) != TCL_OK) { goto ensCreateFail; } if (parentEnsData == NULL) { char *pname = Tcl_Merge(nameArgc-1, nameArgv); Tcl_AppendResult(interp, "invalid ensemble name \"", pname, "\"", (char*)NULL); ckfree(pname); goto ensCreateFail; } } /* * Create the ensemble. */ if (CreateEnsemble(interp, parentEnsData, nameArgv[nameArgc-1]) != TCL_OK) { goto ensCreateFail; } ckfree((char*)nameArgv); return TCL_OK; ensCreateFail: if (nameArgv) { ckfree((char*)nameArgv); } Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "\n (while creating ensemble \"", -1); Tcl_DStringAppend(&buffer, ensName, -1); Tcl_DStringAppend(&buffer, "\")", -1); Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); Tcl_DStringFree(&buffer); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Itcl_AddEnsemblePart -- * * Adds a part to an ensemble which has been created by * Itcl_CreateEnsemble. Ensembles are addressed by name, as * described in Itcl_CreateEnsemble. * * If the ensemble already has a part with the specified name, * this procedure returns an error. Otherwise, it adds a new * part to the ensemble. * * Any client data specified is automatically passed to the * handling procedure whenever the part is invoked. It is * automatically destroyed by the deleteProc when the part is * deleted. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes * wrong. * * Side effects: * If an error is encountered, an error is left as the result * in the interpreter. * *---------------------------------------------------------------------- */ int Itcl_AddEnsemblePart(interp, ensName, partName, usageInfo, objProc, clientData, deleteProc) Tcl_Interp *interp; /* interpreter to be updated */ CONST char* ensName; /* ensemble containing this part */ CONST char* partName; /* name of the new part */ CONST char* usageInfo; /* usage info for argument list */ Tcl_ObjCmdProc *objProc; /* handling procedure for part */ ClientData clientData; /* client data associated with part */ Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ { CONST char **nameArgv = NULL; int nameArgc; Ensemble *ensData; EnsemblePart *ensPart; Tcl_DString buffer; /* * Parse the ensemble name and look for a containing ensemble. */ if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { goto ensPartFail; } if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { goto ensPartFail; } if (ensData == NULL) { char *pname = Tcl_Merge(nameArgc, nameArgv); Tcl_AppendResult(interp, "invalid ensemble name \"", pname, "\"", (char*)NULL); ckfree(pname); goto ensPartFail; } /* * Install the new part into the part list. */ if (AddEnsemblePart(interp, ensData, partName, usageInfo, objProc, clientData, deleteProc, &ensPart) != TCL_OK) { goto ensPartFail; } ckfree((char*)nameArgv); return TCL_OK; ensPartFail: if (nameArgv) { ckfree((char*)nameArgv); } Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "\n (while adding to ensemble \"", -1); Tcl_DStringAppend(&buffer, ensName, -1); Tcl_DStringAppend(&buffer, "\")", -1); Tcl_AddObjErrorInfo(interp, Tcl_DStringValue(&buffer), -1); Tcl_DStringFree(&buffer); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Itcl_GetEnsemblePart -- * * Looks for a part within an ensemble, and returns information * about it. * * Results: * If the ensemble and its part are found, this procedure * loads information about the part into the "infoPtr" structure * and returns 1. Otherwise, it returns 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Itcl_GetEnsemblePart(interp, ensName, partName, infoPtr) Tcl_Interp *interp; /* interpreter to be updated */ CONST char *ensName; /* ensemble containing the part */ CONST char *partName; /* name of the desired part */ Tcl_CmdInfo *infoPtr; /* returns: info associated with part */ { CONST char **nameArgv = NULL; int nameArgc; Ensemble *ensData; EnsemblePart *ensPart; Command *cmdPtr; Itcl_InterpState state; /* * Parse the ensemble name and look for a containing ensemble. * Save the interpreter state before we do this. If we get any * errors, we don't want them to affect the interpreter. */ state = Itcl_SaveInterpState(interp, TCL_OK); if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { goto ensGetFail; } if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { goto ensGetFail; } if (ensData == NULL) { goto ensGetFail; } /* * Look for a part with the desired name. If found, load * its data into the "infoPtr" structure. */ if (FindEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK || ensPart == NULL) { goto ensGetFail; } cmdPtr = ensPart->cmdPtr; infoPtr->isNativeObjectProc = (cmdPtr->objProc != TclInvokeStringCommand); infoPtr->objProc = cmdPtr->objProc; infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace*)cmdPtr->nsPtr; Itcl_DiscardInterpState(state); return 1; ensGetFail: Itcl_RestoreInterpState(interp, state); return 0; } /* *---------------------------------------------------------------------- * * Itcl_IsEnsemble -- * * Determines whether or not an existing command is an ensemble. * * Results: * Returns non-zero if the command is an ensemble, and zero * otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Itcl_IsEnsemble(infoPtr) Tcl_CmdInfo* infoPtr; /* command info from Tcl_GetCommandInfo() */ { if (infoPtr) { return (infoPtr->deleteProc == DeleteEnsemble); } return 0; } /* *---------------------------------------------------------------------- * * Itcl_GetEnsembleUsage -- * * Returns a summary of all of the parts of an ensemble and * the meaning of their arguments. Each part is listed on * a separate line. Having this summary is sometimes useful * when building error messages for the "@error" handler in * an ensemble. * * Ensembles are accessed by name, as described in * Itcl_CreateEnsemble. * * Results: * If the ensemble is found, its usage information is appended * onto the object "objPtr", and this procedure returns * non-zero. It is the responsibility of the caller to * initialize and free the object. If anything goes wrong, * this procedure returns 0. * * Side effects: * Object passed in is modified. * *---------------------------------------------------------------------- */ int Itcl_GetEnsembleUsage(interp, ensName, objPtr) Tcl_Interp *interp; /* interpreter containing the ensemble */ CONST char *ensName; /* name of the ensemble */ Tcl_Obj *objPtr; /* returns: summary of usage info */ { CONST char **nameArgv = NULL; int nameArgc; Ensemble *ensData; Itcl_InterpState state; /* * Parse the ensemble name and look for the ensemble. * Save the interpreter state before we do this. If we get * any errors, we don't want them to affect the interpreter. */ state = Itcl_SaveInterpState(interp, TCL_OK); if (Tcl_SplitList(interp, ensName, &nameArgc, &nameArgv) != TCL_OK) { goto ensUsageFail; } if (FindEnsemble(interp, nameArgv, nameArgc, &ensData) != TCL_OK) { goto ensUsageFail; } if (ensData == NULL) { goto ensUsageFail; } /* * Add a summary of usage information to the return buffer. */ GetEnsembleUsage(ensData, objPtr); Itcl_DiscardInterpState(state); return 1; ensUsageFail: Itcl_RestoreInterpState(interp, state); return 0; } /* *---------------------------------------------------------------------- * * Itcl_GetEnsembleUsageForObj -- * * Returns a summary of all of the parts of an ensemble and * the meaning of their arguments. This procedure is just * like Itcl_GetEnsembleUsage, but it determines the desired * ensemble from a command line argument. The argument should * be the first argument on the command line--the ensemble * command or one of its parts. * * Results: * If the ensemble is found, its usage information is appended * onto the object "objPtr", and this procedure returns * non-zero. It is the responsibility of the caller to * initialize and free the object. If anything goes wrong, * this procedure returns 0. * * Side effects: * Object passed in is modified. * *---------------------------------------------------------------------- */ int Itcl_GetEnsembleUsageForObj(interp, ensObjPtr, objPtr) Tcl_Interp *interp; /* interpreter containing the ensemble */ Tcl_Obj *ensObjPtr; /* argument representing ensemble */ Tcl_Obj *objPtr; /* returns: summary of usage info */ { Ensemble *ensData; Tcl_Obj *chainObj; Tcl_Command cmd; Command *cmdPtr; /* * If the argument is an ensemble part, then follow the chain * back to the command word for the entire ensemble. */ chainObj = ensObjPtr; while (chainObj && chainObj->typePtr == &itclEnsInvocType) { chainObj = (Tcl_Obj*)chainObj->internalRep.twoPtrValue.ptr2; } if (chainObj) { cmd = Tcl_GetCommandFromObj(interp, chainObj); cmdPtr = (Command*)cmd; if (cmdPtr->deleteProc == DeleteEnsemble) { ensData = (Ensemble*)cmdPtr->objClientData; GetEnsembleUsage(ensData, objPtr); return 1; } } return 0; } /* *---------------------------------------------------------------------- * * GetEnsembleUsage -- * * * Returns a summary of all of the parts of an ensemble and * the meaning of their arguments. Each part is listed on * a separate line. This procedure is used internally to * generate usage information for error messages. * * Results: * Appends usage information onto the object in "objPtr". * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetEnsembleUsage(ensData, objPtr) Ensemble *ensData; /* ensemble data */ Tcl_Obj *objPtr; /* returns: summary of usage info */ { char *spaces = " "; int isOpenEnded = 0; int i; EnsemblePart *ensPart; for (i=0; i < ensData->numParts; i++) { ensPart = ensData->parts[i]; if (*ensPart->name == '@' && strcmp(ensPart->name,"@error") == 0) { isOpenEnded = 1; } else { Tcl_AppendToObj(objPtr, spaces, -1); GetEnsemblePartUsage(ensPart, objPtr); spaces = "\n "; } } if (isOpenEnded) { Tcl_AppendToObj(objPtr, "\n...and others described on the man page", -1); } } /* *---------------------------------------------------------------------- * * GetEnsemblePartUsage -- * * Determines the usage for a single part within an ensemble, * and appends a summary onto a dynamic string. The usage * is a combination of the part name and the argument summary. * It is the caller's responsibility to initialize and free * the dynamic string. * * Results: * Returns usage information in the object "objPtr". * * Side effects: * None. * *---------------------------------------------------------------------- */ static void GetEnsemblePartUsage(ensPart, objPtr) EnsemblePart *ensPart; /* ensemble part for usage info */ Tcl_Obj *objPtr; /* returns: usage information */ { EnsemblePart *part; Command *cmdPtr; char *name; Itcl_List trail; Itcl_ListElem *elem; Tcl_DString buffer; /* * Build the trail of ensemble names leading to this part. */ Tcl_DStringInit(&buffer); Itcl_InitList(&trail); for (part=ensPart; part; part=part->ensemble->parent) { Itcl_InsertList(&trail, (ClientData)part); } cmdPtr = (Command*)ensPart->ensemble->cmd; name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_DStringAppendElement(&buffer, name); for (elem=Itcl_FirstListElem(&trail); elem; elem=Itcl_NextListElem(elem)) { part = (EnsemblePart*)Itcl_GetListValue(elem); Tcl_DStringAppendElement(&buffer, part->name); } Itcl_DeleteList(&trail); /* * If the part has usage info, use it directly. */ if (ensPart->usage && *ensPart->usage != '\0') { Tcl_DStringAppend(&buffer, " ", 1); Tcl_DStringAppend(&buffer, ensPart->usage, -1); } /* * If the part is itself an ensemble, summarize its usage. */ else if (ensPart->cmdPtr && ensPart->cmdPtr->deleteProc == DeleteEnsemble) { Tcl_DStringAppend(&buffer, " option ?arg arg ...?", 21); } Tcl_AppendToObj(objPtr, Tcl_DStringValue(&buffer), Tcl_DStringLength(&buffer)); Tcl_DStringFree(&buffer); } /* *---------------------------------------------------------------------- * * CreateEnsemble -- * * Creates an ensemble command, or adds a sub-ensemble to an * existing ensemble command. Works like Itcl_CreateEnsemble, * except that the ensemble name is a single name, not a path. * If a parent ensemble is specified, then a new ensemble is * added to that parent. If a part already exists with the * same name, it is an error. If a parent ensemble is not * specified, then a top-level ensemble is created. If a * command already exists with the same name, it is deleted. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything goes * wrong. * * Side effects: * If an error is encountered, an error is left as the result * in the interpreter. * *---------------------------------------------------------------------- */ static int CreateEnsemble(interp, parentEnsData, ensName) Tcl_Interp *interp; /* interpreter to be updated */ Ensemble *parentEnsData; /* parent ensemble or NULL */ CONST char *ensName; /* name of the new ensemble */ { Ensemble *ensData; EnsemblePart *ensPart; Command *cmdPtr; Tcl_CmdInfo cmdInfo; /* * Create the data associated with the ensemble. */ ensData = (Ensemble*)ckalloc(sizeof(Ensemble)); ensData->interp = interp; ensData->numParts = 0; ensData->maxParts = 10; ensData->parts = (EnsemblePart**)ckalloc( (unsigned)(ensData->maxParts*sizeof(EnsemblePart*)) ); ensData->cmd = NULL; ensData->parent = NULL; /* * If there is no parent data, then this is a top-level * ensemble. Create the ensemble by installing its access * command. * * BE CAREFUL: Set the string-based proc to the wrapper * procedure TclInvokeObjectCommand. Otherwise, the * ensemble command may fail. For example, it will fail * when invoked as a hidden command. */ if (parentEnsData == NULL) { ensData->cmd = Tcl_CreateObjCommand(interp, ensName, HandleEnsemble, (ClientData)ensData, DeleteEnsemble); if (Tcl_GetCommandInfo(interp, ensName, &cmdInfo)) { cmdInfo.proc = TclInvokeObjectCommand; Tcl_SetCommandInfo(interp, ensName, &cmdInfo); } return TCL_OK; } /* * Otherwise, this ensemble is contained within another parent. * Install the new ensemble as a part within its parent. */ if (CreateEnsemblePart(interp, parentEnsData, ensName, &ensPart) != TCL_OK) { DeleteEnsemble((ClientData)ensData); return TCL_ERROR; } ensData->cmd = parentEnsData->cmd; ensData->parent = ensPart; /* * Initialize non-NULL data only. This allows us to handle the * structure differences between versions better. */ cmdPtr = (Command *) ckalloc(sizeof(Command)); memset((VOID *) cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = ((Command *) ensData->cmd)->nsPtr; cmdPtr->objProc = HandleEnsemble; cmdPtr->objClientData = (ClientData)ensData; cmdPtr->deleteProc = DeleteEnsemble; cmdPtr->deleteData = cmdPtr->objClientData; ensPart->cmdPtr = cmdPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * AddEnsemblePart -- * * Adds a part to an existing ensemble. Works like * Itcl_AddEnsemblePart, but the part name is a single word, * not a path. * * If the ensemble already has a part with the specified name, * this procedure returns an error. Otherwise, it adds a new * part to the ensemble. * * Any client data specified is automatically passed to the * handling procedure whenever the part is invoked. It is * automatically destroyed by the deleteProc when the part is * deleted. * * Results: * Returns TCL_OK if successful, along with a pointer to the * new part. Returns TCL_ERROR if anything goes wrong. * * Side effects: * If an error is encountered, an error is left as the result * in the interpreter. * *---------------------------------------------------------------------- */ static int AddEnsemblePart(interp, ensData, partName, usageInfo, objProc, clientData, deleteProc, rVal) Tcl_Interp *interp; /* interpreter to be updated */ Ensemble* ensData; /* ensemble that will contain this part */ CONST char* partName; /* name of the new part */ CONST char* usageInfo; /* usage info for argument list */ Tcl_ObjCmdProc *objProc; /* handling procedure for part */ ClientData clientData; /* client data associated with part */ Tcl_CmdDeleteProc *deleteProc; /* procedure used to destroy client data */ EnsemblePart **rVal; /* returns: new ensemble part */ { EnsemblePart *ensPart; Command *cmdPtr; /* * Install the new part into the part list. */ if (CreateEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { return TCL_ERROR; } if (usageInfo) { ensPart->usage = ckalloc((unsigned)(strlen(usageInfo)+1)); strcpy(ensPart->usage, usageInfo); } /* * Initialize non-NULL data only. This allows us to handle the * structure differences between versions better. */ cmdPtr = (Command *) ckalloc(sizeof(Command)); memset((VOID *) cmdPtr, 0, sizeof(Command)); cmdPtr->nsPtr = ((Command *) ensData->cmd)->nsPtr; cmdPtr->objProc = objProc; cmdPtr->objClientData = (ClientData)clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = (ClientData)clientData; ensPart->cmdPtr = cmdPtr; *rVal = ensPart; return TCL_OK; } /* *---------------------------------------------------------------------- * * DeleteEnsemble -- * * Invoked when the command associated with an ensemble is * destroyed, to delete the ensemble. Destroys all parts * included in the ensemble, and frees all memory associated * with it. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void DeleteEnsemble(clientData) ClientData clientData; /* ensemble data */ { Ensemble* ensData = (Ensemble*)clientData; /* * BE CAREFUL: Each ensemble part removes itself from the list. * So keep deleting the first part until all parts are gone. */ while (ensData->numParts > 0) { DeleteEnsemblePart(ensData->parts[0]); } ckfree((char*)ensData->parts); ckfree((char*)ensData); } /* *---------------------------------------------------------------------- * * FindEnsemble -- * * Searches for an ensemble command and follows a path to * sub-ensembles. * * Results: * Returns TCL_OK if the ensemble was found, along with a * pointer to the ensemble data in "ensDataPtr". Returns * TCL_ERROR if anything goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ static int FindEnsemble(interp, nameArgv, nameArgc, ensDataPtr) Tcl_Interp *interp; /* interpreter containing the ensemble */ CONST char **nameArgv; /* path of names leading to ensemble */ int nameArgc; /* number of strings in nameArgv */ Ensemble** ensDataPtr; /* returns: ensemble data */ { int i; Command* cmdPtr; Ensemble *ensData; EnsemblePart *ensPart; *ensDataPtr = NULL; /* assume that no data will be found */ /* * If there are no names in the path, then return an error. */ if (nameArgc < 1) { Tcl_AppendToObj(Tcl_GetObjResult(interp), "invalid ensemble name \"\"", -1); return TCL_ERROR; } /* * Use the first name to find the command for the top-level * ensemble. */ cmdPtr = (Command*) Tcl_FindCommand(interp, nameArgv[0], (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(interp, "command \"", nameArgv[0], "\" is not an ensemble", (char*)NULL); return TCL_ERROR; } ensData = (Ensemble*)cmdPtr->objClientData; /* * Follow the trail of sub-ensemble names. */ for (i=1; i < nameArgc; i++) { if (FindEnsemblePart(interp, ensData, nameArgv[i], &ensPart) != TCL_OK) { return TCL_ERROR; } if (ensPart == NULL) { char *pname = Tcl_Merge(i, nameArgv); Tcl_AppendResult(interp, "invalid ensemble name \"", pname, "\"", (char*)NULL); ckfree(pname); return TCL_ERROR; } cmdPtr = ensPart->cmdPtr; if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(interp, "part \"", nameArgv[i], "\" is not an ensemble", (char*)NULL); return TCL_ERROR; } ensData = (Ensemble*)cmdPtr->objClientData; } *ensDataPtr = ensData; return TCL_OK; } /* *---------------------------------------------------------------------- * * CreateEnsemblePart -- * * Creates a new part within an ensemble. * * Results: * If successful, this procedure returns TCL_OK, along with a * pointer to the new part in "ensPartPtr". If a part with the * same name already exists, this procedure returns TCL_ERROR. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ static int CreateEnsemblePart(interp, ensData, partName, ensPartPtr) Tcl_Interp *interp; /* interpreter containing the ensemble */ Ensemble *ensData; /* ensemble being modified */ CONST char* partName; /* name of the new part */ EnsemblePart **ensPartPtr; /* returns: new ensemble part */ { int i, pos, size; EnsemblePart** partList; EnsemblePart* part; /* * If a matching entry was found, then return an error. */ if (FindEnsemblePartIndex(ensData, partName, &pos)) { Tcl_AppendResult(interp, "part \"", partName, "\" already exists in ensemble", (char*)NULL); return TCL_ERROR; } /* * Otherwise, make room for a new entry. Keep the parts in * lexicographical order, so we can search them quickly * later. */ if (ensData->numParts >= ensData->maxParts) { size = ensData->maxParts*sizeof(EnsemblePart*); partList = (EnsemblePart**)ckalloc((unsigned)2*size); memcpy((VOID*)partList, (VOID*)ensData->parts, (size_t)size); ckfree((char*)ensData->parts); ensData->parts = partList; ensData->maxParts *= 2; } for (i=ensData->numParts; i > pos; i--) { ensData->parts[i] = ensData->parts[i-1]; } ensData->numParts++; part = (EnsemblePart*)ckalloc(sizeof(EnsemblePart)); part->name = (char*)ckalloc((unsigned)(strlen(partName)+1)); strcpy(part->name, partName); part->cmdPtr = NULL; part->usage = NULL; part->ensemble = ensData; ensData->parts[pos] = part; /* * Compare the new part against the one on either side of * it. Determine how many letters are needed in each part * to guarantee that an abbreviated form is unique. Update * the parts on either side as well, since they are influenced * by the new part. */ ComputeMinChars(ensData, pos); ComputeMinChars(ensData, pos-1); ComputeMinChars(ensData, pos+1); *ensPartPtr = part; return TCL_OK; } /* *---------------------------------------------------------------------- * * DeleteEnsemblePart -- * * Deletes a single part from an ensemble. The part must have * been created previously by CreateEnsemblePart. * * If the part has a delete proc, then it is called to free the * associated client data. * * Results: * None. * * Side effects: * Delete proc is called. * *---------------------------------------------------------------------- */ static void DeleteEnsemblePart(ensPart) EnsemblePart *ensPart; /* part being destroyed */ { int i, pos; Command *cmdPtr; Ensemble *ensData; cmdPtr = ensPart->cmdPtr; /* * If this part has a delete proc, then call it to free * up the client data. */ if (cmdPtr->deleteData && cmdPtr->deleteProc) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } ckfree((char*)cmdPtr); /* * Find this part within its ensemble, and remove it from * the list of parts. */ if (FindEnsemblePartIndex(ensPart->ensemble, ensPart->name, &pos)) { ensData = ensPart->ensemble; for (i=pos; i < ensData->numParts-1; i++) { ensData->parts[i] = ensData->parts[i+1]; } ensData->numParts--; } /* * Free the memory associated with the part. */ if (ensPart->usage) { ckfree(ensPart->usage); } ckfree(ensPart->name); ckfree((char*)ensPart); } /* *---------------------------------------------------------------------- * * FindEnsemblePart -- * * Searches for a part name within an ensemble. Recognizes * unique abbreviations for part names. * * Results: * If the part name is not a unique abbreviation, this procedure * returns TCL_ERROR. Otherwise, it returns TCL_OK. If the * part can be found, "rensPart" returns a pointer to the part. * Otherwise, it returns NULL. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ static int FindEnsemblePart(interp, ensData, partName, rensPart) Tcl_Interp *interp; /* interpreter containing the ensemble */ Ensemble *ensData; /* ensemble being searched */ CONST char* partName; /* name of the desired part */ EnsemblePart **rensPart; /* returns: pointer to the desired part */ { int pos = 0; int first, last, nlen; int i, cmp; *rensPart = NULL; /* * Search for the desired part name. * All parts are in lexicographical order, so use a * binary search to find the part quickly. Match only * as many characters as are included in the specified * part name. */ first = 0; last = ensData->numParts-1; nlen = strlen(partName); while (last >= first) { pos = (first+last)/2; if (*partName == *ensData->parts[pos]->name) { cmp = strncmp(partName, ensData->parts[pos]->name, nlen); if (cmp == 0) { break; /* found it! */ } } else if (*partName < *ensData->parts[pos]->name) { cmp = -1; } else { cmp = 1; } if (cmp > 0) { first = pos+1; } else { last = pos-1; } } /* * If a matching entry could not be found, then quit. */ if (last < first) { return TCL_OK; } /* * If a matching entry was found, there may be some ambiguity * if the user did not specify enough characters. Find the * top-most match in the list, and see if the part name has * enough characters. If there are two parts like "foo" * and "food", this allows us to match "foo" exactly. */ if (nlen < ensData->parts[pos]->minChars) { while (pos > 0) { pos--; if (strncmp(partName, ensData->parts[pos]->name, nlen) != 0) { pos++; break; } } } if (nlen < ensData->parts[pos]->minChars) { Tcl_Obj *resultPtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_AppendStringsToObj(resultPtr, "ambiguous option \"", partName, "\": should be one of...", (char*)NULL); for (i=pos; i < ensData->numParts; i++) { if (strncmp(partName, ensData->parts[i]->name, nlen) != 0) { break; } Tcl_AppendToObj(resultPtr, "\n ", 3); GetEnsemblePartUsage(ensData->parts[i], resultPtr); } Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } /* * Found a match. Return the desired part. */ *rensPart = ensData->parts[pos]; return TCL_OK; } /* *---------------------------------------------------------------------- * * FindEnsemblePartIndex -- * * Searches for a part name within an ensemble. The part name * must be an exact match for an existing part name in the * ensemble. This procedure is useful for managing (i.e., * creating and deleting) parts in an ensemble. * * Results: * If an exact match is found, this procedure returns * non-zero, along with the index of the part in posPtr. * Otherwise, it returns zero, along with an index in posPtr * indicating where the part should be. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int FindEnsemblePartIndex(ensData, partName, posPtr) Ensemble *ensData; /* ensemble being searched */ CONST char *partName; /* name of desired part */ int *posPtr; /* returns: index for part */ { int pos = 0; int first, last; int cmp; /* * Search for the desired part name. * All parts are in lexicographical order, so use a * binary search to find the part quickly. */ first = 0; last = ensData->numParts-1; while (last >= first) { pos = (first+last)/2; if (*partName == *ensData->parts[pos]->name) { cmp = strcmp(partName, ensData->parts[pos]->name); if (cmp == 0) { break; /* found it! */ } } else if (*partName < *ensData->parts[pos]->name) { cmp = -1; } else { cmp = 1; } if (cmp > 0) { first = pos+1; } else { last = pos-1; } } if (last >= first) { *posPtr = pos; return 1; } *posPtr = first; return 0; } /* *---------------------------------------------------------------------- * * ComputeMinChars -- * * Compares part names on an ensemble's part list and * determines the minimum number of characters needed for a * unique abbreviation. The parts on either side of a * particular part index are compared. As long as there is * a part on one side or the other, this procedure updates * the parts to have the proper minimum abbreviations. * * Results: * None. * * Side effects: * Updates three parts within the ensemble to remember * the minimum abbreviations. * *---------------------------------------------------------------------- */ static void ComputeMinChars(ensData, pos) Ensemble *ensData; /* ensemble being modified */ int pos; /* index of part being updated */ { int min, max; char *p, *q; /* * If the position is invalid, do nothing. */ if (pos < 0 || pos >= ensData->numParts) { return; } /* * Start by assuming that only the first letter is required * to uniquely identify this part. Then compare the name * against each neighboring part to determine the real minimum. */ ensData->parts[pos]->minChars = 1; if (pos-1 >= 0) { p = ensData->parts[pos]->name; q = ensData->parts[pos-1]->name; for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { p++; q++; } if (min > ensData->parts[pos]->minChars) { ensData->parts[pos]->minChars = min; } } if (pos+1 < ensData->numParts) { p = ensData->parts[pos]->name; q = ensData->parts[pos+1]->name; for (min=1; *p == *q && *p != '\0' && *q != '\0'; min++) { p++; q++; } if (min > ensData->parts[pos]->minChars) { ensData->parts[pos]->minChars = min; } } max = strlen(ensData->parts[pos]->name); if (ensData->parts[pos]->minChars > max) { ensData->parts[pos]->minChars = max; } } /* *---------------------------------------------------------------------- * * HandleEnsemble -- * * Invoked by Tcl whenever the user issues an ensemble-style * command. Handles commands of the form: * * ? ...? * * Looks for the within the ensemble, and if it * exists, the procedure transfers control to it. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything * goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ static int HandleEnsemble(clientData, interp, objc, objv) ClientData clientData; /* ensemble data */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { Ensemble *ensData = (Ensemble*)clientData; int i, result; Command *cmdPtr; EnsemblePart *ensPart; char *partName; int partNameLen; Tcl_Obj *cmdlinePtr, *chainObj; int cmdlinec; Tcl_Obj **cmdlinev; /* * If a part name is not specified, return an error that * summarizes the usage for this ensemble. */ if (objc < 2) { Tcl_Obj *resultPtr = Tcl_NewStringObj( "wrong # args: should be one of...\n", -1); GetEnsembleUsage(ensData, resultPtr); Tcl_SetObjResult(interp, resultPtr); return TCL_ERROR; } /* * Lookup the desired part. If an ambiguous abbrevition is * found, return an error immediately. */ partName = Tcl_GetStringFromObj(objv[1], &partNameLen); if (FindEnsemblePart(interp, ensData, partName, &ensPart) != TCL_OK) { return TCL_ERROR; } /* * If the part was not found, then look for an "@error" part * to handle the error. */ if (ensPart == NULL) { if (FindEnsemblePart(interp, ensData, "@error", &ensPart) != TCL_OK) { return TCL_ERROR; } if (ensPart != NULL) { cmdPtr = (Command*)ensPart->cmdPtr; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); return result; } } if (ensPart == NULL) { return Itcl_EnsembleErrorCmd((ClientData)ensData, interp, objc-1, objv+1); } /* * Pass control to the part, and return the result. */ chainObj = Tcl_NewObj(); chainObj->bytes = NULL; chainObj->typePtr = &itclEnsInvocType; chainObj->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; chainObj->internalRep.twoPtrValue.ptr2 = (VOID *) objv[0]; Tcl_IncrRefCount(objv[0]); cmdlinePtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, chainObj); for (i=2; i < objc; i++) { Tcl_ListObjAppendElement((Tcl_Interp*)NULL, cmdlinePtr, objv[i]); } Tcl_IncrRefCount(cmdlinePtr); result = Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, &cmdlinec, &cmdlinev); if (result == TCL_OK) { cmdPtr = (Command*)ensPart->cmdPtr; result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, cmdlinec, cmdlinev); } Tcl_DecrRefCount(cmdlinePtr); return result; } /* *---------------------------------------------------------------------- * * Itcl_EnsembleCmd -- * * Invoked by Tcl whenever the user issues the "ensemble" * command to manipulate an ensemble. Handles the following * syntax: * * ensemble ? ...? * ensemble { * part * ensemble { * ... * } * } * * Finds or creates the ensemble , and then executes * the commands to add parts. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything * goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ int Itcl_EnsembleCmd(clientData, interp, objc, objv) ClientData clientData; /* ensemble data */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int status; char *ensName; EnsembleParser *ensInfo; Ensemble *ensData, *savedEnsData; EnsemblePart *ensPart; Tcl_Command cmd; Command *cmdPtr; Tcl_Obj *objPtr; /* * Make sure that an ensemble name was specified. */ if (objc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetStringFromObj(objv[0], (int*)NULL), " name ?command arg arg...?\"", (char*)NULL); return TCL_ERROR; } /* * If this is the "ensemble" command in the main interpreter, * then the client data will be null. Otherwise, it is * the "ensemble" command in the ensemble body parser, and * the client data indicates which ensemble we are modifying. */ if (clientData) { ensInfo = (EnsembleParser*)clientData; } else { ensInfo = GetEnsembleParser(interp); } ensData = ensInfo->ensData; /* * Find or create the desired ensemble. If an ensemble is * being built, then this "ensemble" command is enclosed in * another "ensemble" command. Use the current ensemble as * the parent, and find or create an ensemble part within it. */ ensName = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (ensData) { if (FindEnsemblePart(interp, ensData, ensName, &ensPart) != TCL_OK) { ensPart = NULL; } if (ensPart == NULL) { if (CreateEnsemble(interp, ensData, ensName) != TCL_OK) { return TCL_ERROR; } if (FindEnsemblePart(interp, ensData, ensName, &ensPart) != TCL_OK) { Tcl_Panic("Itcl_EnsembleCmd: can't create ensemble"); } } cmdPtr = (Command*)ensPart->cmdPtr; if (cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(interp, "part \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), "\" is not an ensemble", (char*)NULL); return TCL_ERROR; } ensData = (Ensemble*)cmdPtr->objClientData; } /* * Otherwise, the desired ensemble is a top-level ensemble. * Find or create the access command for the ensemble, and * then get its data. */ else { cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); if (cmd == NULL) { if (CreateEnsemble(interp, (Ensemble*)NULL, ensName) != TCL_OK) { return TCL_ERROR; } cmd = Tcl_FindCommand(interp, ensName, (Tcl_Namespace*)NULL, 0); } cmdPtr = (Command*)cmd; if (cmdPtr == NULL || cmdPtr->deleteProc != DeleteEnsemble) { Tcl_AppendResult(interp, "command \"", Tcl_GetStringFromObj(objv[1], (int*)NULL), "\" is not an ensemble", (char*)NULL); return TCL_ERROR; } ensData = (Ensemble*)cmdPtr->objClientData; } /* * At this point, we have the data for the ensemble that is * being manipulated. Plug this into the parser, and then * interpret the rest of the arguments in the ensemble parser. */ status = TCL_OK; savedEnsData = ensInfo->ensData; ensInfo->ensData = ensData; if (objc == 3) { status = Tcl_EvalObj(ensInfo->parser, objv[2]); } else if (objc > 3) { objPtr = Tcl_NewListObj(objc-2, objv+2); Tcl_IncrRefCount(objPtr); /* stop Eval trashing it */ status = Tcl_EvalObj(ensInfo->parser, objPtr); Tcl_DecrRefCount(objPtr); /* we're done with the object */ } /* * Copy the result from the parser interpreter to the * master interpreter. If an error was encountered, * copy the error info first, and then set the result. * Otherwise, the offending command is reported twice. */ if (status == TCL_ERROR) { CONST char *errInfo = Tcl_GetVar2(ensInfo->parser, "::errorInfo", (char*)NULL, TCL_GLOBAL_ONLY); if (errInfo) { Tcl_AddObjErrorInfo(interp, errInfo, -1); } if (objc == 3) { char msg[128]; sprintf(msg, "\n (\"ensemble\" body line %d)", Tcl_GetErrorLine(ensInfo->parser)); Tcl_AddObjErrorInfo(interp, msg, -1); } } Tcl_SetObjResult(interp, Tcl_GetObjResult(ensInfo->parser)); ensInfo->ensData = savedEnsData; return status; } /* *---------------------------------------------------------------------- * * GetEnsembleParser -- * * Returns the slave interpreter that acts as a parser for * the body of an "ensemble" definition. The first time that * this is called for an interpreter, the parser is created * and registered as associated data. After that, it is * simply returned. * * Results: * Returns a pointer to the ensemble parser data structure. * * Side effects: * On the first call, the ensemble parser is created and * registered as "itcl_ensembleParser" with the interpreter. * *---------------------------------------------------------------------- */ static EnsembleParser* GetEnsembleParser(interp) Tcl_Interp *interp; /* interpreter handling the ensemble */ { Namespace *nsPtr; Tcl_Namespace *childNs; EnsembleParser *ensInfo; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Command cmd; /* * Look for an existing ensemble parser. If it is found, * return it immediately. */ ensInfo = (EnsembleParser*) Tcl_GetAssocData(interp, "itcl_ensembleParser", NULL); if (ensInfo) { return ensInfo; } /* * Create a slave interpreter that can be used to parse * the body of an ensemble definition. */ ensInfo = (EnsembleParser*)ckalloc(sizeof(EnsembleParser)); ensInfo->master = interp; ensInfo->parser = Tcl_CreateInterp(); ensInfo->ensData = NULL; /* * Remove all namespaces and all normal commands from the * parser interpreter. */ nsPtr = (Namespace*)Tcl_GetGlobalNamespace(ensInfo->parser); for (hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { childNs = (Tcl_Namespace*)Tcl_GetHashValue(hPtr); Tcl_DeleteNamespace(childNs); } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { cmd = (Tcl_Command)Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(ensInfo->parser, cmd); } /* * Add the allowed commands to the parser interpreter: * part, delete, ensemble */ Tcl_CreateObjCommand(ensInfo->parser, "part", Itcl_EnsPartCmd, (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(ensInfo->parser, "option", Itcl_EnsPartCmd, (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(ensInfo->parser, "ensemble", Itcl_EnsembleCmd, (ClientData)ensInfo, (Tcl_CmdDeleteProc*)NULL); /* * Install the parser data, so we'll have it the next time * we call this procedure. */ (void) Tcl_SetAssocData(interp, "itcl_ensembleParser", DeleteEnsParser, (ClientData)ensInfo); return ensInfo; } /* *---------------------------------------------------------------------- * * DeleteEnsParser -- * * Called when an interpreter is destroyed to clean up the * ensemble parser within it. Destroys the slave interpreter * and frees up the data associated with it. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void DeleteEnsParser(clientData, interp) ClientData clientData; /* client data for ensemble-related commands */ Tcl_Interp *interp; /* interpreter containing the data */ { EnsembleParser* ensInfo = (EnsembleParser*)clientData; Tcl_DeleteInterp(ensInfo->parser); ckfree((char*)ensInfo); } /* *---------------------------------------------------------------------- * * Itcl_EnsPartCmd -- * * Invoked by Tcl whenever the user issues the "part" command * to manipulate an ensemble. This command can only be used * inside the "ensemble" command, which handles ensembles. * Handles the following syntax: * * ensemble { * part * } * * Adds a new part called to the ensemble. If a * part already exists with that name, it is an error. The * new part is handled just like an ordinary Tcl proc, with * a list of and a of code to execute. * * Results: * Returns TCL_OK if successful, and TCL_ERROR if anything * goes wrong. * * Side effects: * If anything goes wrong, this procedure returns an error * message as the result in the interpreter. * *---------------------------------------------------------------------- */ int Itcl_EnsPartCmd(clientData, interp, objc, objv) ClientData clientData; /* ensemble data */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { EnsembleParser *ensInfo = (EnsembleParser*)clientData; Ensemble *ensData = (Ensemble*)ensInfo->ensData; int status, varArgs, space; char *partName, *usage; Proc *procPtr; Command *cmdPtr; CompiledLocal *localPtr; EnsemblePart *ensPart; Tcl_DString buffer; if (objc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", Tcl_GetStringFromObj(objv[0], (int*)NULL), " name args body\"", (char*)NULL); return TCL_ERROR; } /* * Create a Tcl-style proc definition using the specified args * and body. This is not a proc in the usual sense. It belongs * to the namespace that contains the ensemble, but it is * accessed through the ensemble, not through a Tcl command. */ partName = Tcl_GetStringFromObj(objv[1], (int*)NULL); cmdPtr = (Command*)ensData->cmd; if (TclCreateProc(interp, cmdPtr->nsPtr, partName, objv[2], objv[3], &procPtr) != TCL_OK) { return TCL_ERROR; } /* * Deduce the usage information from the argument list. * We'll register this when we create the part, in a moment. */ Tcl_DStringInit(&buffer); varArgs = 0; space = 0; for (localPtr=procPtr->firstLocalPtr; localPtr != NULL; localPtr=localPtr->nextPtr) { if (TclIsVarArgument(localPtr)) { varArgs = 0; if (strcmp(localPtr->name, "args") == 0) { varArgs = 1; } else if (localPtr->defValuePtr) { if (space) { Tcl_DStringAppend(&buffer, " ", 1); } Tcl_DStringAppend(&buffer, "?", 1); Tcl_DStringAppend(&buffer, localPtr->name, -1); Tcl_DStringAppend(&buffer, "?", 1); space = 1; } else { if (space) { Tcl_DStringAppend(&buffer, " ", 1); } Tcl_DStringAppend(&buffer, localPtr->name, -1); space = 1; } } } if (varArgs) { if (space) { Tcl_DStringAppend(&buffer, " ", 1); } Tcl_DStringAppend(&buffer, "?arg arg ...?", 13); } usage = Tcl_DStringValue(&buffer); /* * Create a new part within the ensemble. If successful, * plug the command token into the proc; we'll need it later * if we try to compile the Tcl code for the part. If * anything goes wrong, clean up before bailing out. */ status = AddEnsemblePart(interp, ensData, partName, usage, TclObjInterpProc, (ClientData)procPtr, TclProcDeleteProc, &ensPart); if (status == TCL_OK) { procPtr->cmdPtr = ensPart->cmdPtr; } else { TclProcDeleteProc((ClientData)procPtr); } Tcl_DStringFree(&buffer); return status; } /* *---------------------------------------------------------------------- * * Itcl_EnsembleErrorCmd -- * * Invoked when the user tries to access an unknown part for * an ensemble. Acts as the default handler for the "@error" * part. Generates an error message like: * * bad option "foo": should be one of... * info args procname * info body procname * info cmdcount * ... * * Results: * Always returns TCL_OK. * * Side effects: * Returns the error message as the result in the interpreter. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Itcl_EnsembleErrorCmd(clientData, interp, objc, objv) ClientData clientData; /* ensemble info */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { Ensemble *ensData = (Ensemble*)clientData; char *cmdName; Tcl_Obj *objPtr; cmdName = Tcl_GetStringFromObj(objv[0], (int*)NULL); objPtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_AppendStringsToObj(objPtr, "bad option \"", cmdName, "\": should be one of...\n", (char*)NULL); GetEnsembleUsage(ensData, objPtr); Tcl_SetObjResult(interp, objPtr); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * FreeEnsInvocInternalRep -- * * Frees the resources associated with an ensembleInvoc object's * internal representation. * * Results: * None. * * Side effects: * Decrements the ref count of the two objects referenced by * this object. If there are no more uses, this will free * the other objects. * *---------------------------------------------------------------------- */ static void FreeEnsInvocInternalRep(objPtr) register Tcl_Obj *objPtr; /* namespName object with internal * representation to free */ { Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; if (prevArgObj) { Tcl_DecrRefCount(prevArgObj); } } /* *---------------------------------------------------------------------- * * DupEnsInvocInternalRep -- * * Initializes the internal representation of an ensembleInvoc * object to a copy of the internal representation of * another ensembleInvoc object. * * This shouldn't be called. Normally, a temporary ensembleInvoc * object is created while an ensemble call is in progress. * This object may be converted to string form if an error occurs. * It does not stay around long, and there is no reason for it * to be duplicated. * * Results: * None. * * Side effects: * copyPtr's internal rep is set to duplicates of the objects * pointed to by srcPtr's internal rep. * *---------------------------------------------------------------------- */ static void DupEnsInvocInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { EnsemblePart *ensPart = (EnsemblePart*)srcPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *prevArgObj = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr2; Tcl_Obj *objPtr; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) ensPart; if (prevArgObj) { objPtr = Tcl_DuplicateObj(prevArgObj); Tcl_IncrRefCount(objPtr); copyPtr->internalRep.twoPtrValue.ptr2 = (VOID *) objPtr; } } /* *---------------------------------------------------------------------- * * SetEnsInvocFromAny -- * * Generates the internal representation for an ensembleInvoc * object. This conversion really shouldn't take place. * Normally, a temporary ensembleInvoc object is created while * an ensemble call is in progress. This object may be converted * to string form if an error occurs. But there is no reason * for any other object to be converted to ensembleInvoc form. * * Results: * Always returns TCL_OK. * * Side effects: * The string representation is saved as if it were the * command line argument for the ensemble invocation. The * reference to the ensemble part is set to NULL. * *---------------------------------------------------------------------- */ static int SetEnsInvocFromAny(interp, objPtr) Tcl_Interp *interp; /* Determines the context for name resolution */ register Tcl_Obj *objPtr; /* The object to convert */ { int length; char *name; Tcl_Obj *argObj; /* * Get objPtr's string representation. * Make it up-to-date if necessary. * THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS. */ name = Tcl_GetStringFromObj(objPtr, &length); /* * Make an argument object to contain the string, and * set the ensemble part definition to NULL. At this point, * we don't know anything about an ensemble, so we'll just * keep the string around as if it were the command line * invocation. */ argObj = Tcl_NewStringObj(name, length); /* * Free the old representation and install a new one. */ if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc != NULL) { (*objPtr->typePtr->freeIntRepProc)(objPtr); } objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) NULL; objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) argObj; objPtr->typePtr = &itclEnsInvocType; return TCL_OK; } /* *---------------------------------------------------------------------- * * UpdateStringOfEnsInvoc -- * * Updates the string representation for an ensembleInvoc object. * This is called when an error occurs in an ensemble part, when * the code tries to print objv[0] as the command name. This * code automatically chains together all of the names leading * to the ensemble part, so the error message references the * entire command, not just the part name. * * Note: This procedure does not free an existing old string rep * so storage will be lost if this has not already been done. * * Results: * None. * * Side effects: * The object's string is set to the full command name for * the ensemble part. * *---------------------------------------------------------------------- */ static void UpdateStringOfEnsInvoc(objPtr) register Tcl_Obj *objPtr; /* NamespName obj to update string rep. */ { EnsemblePart *ensPart = (EnsemblePart*)objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *prevArgObj = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr2; Tcl_DString buffer; int length; char *name; Tcl_DStringInit(&buffer); /* * Get the string representation for the previous argument. * This will force each ensembleInvoc argument up the line * to get its string representation. So we will get the * original command name, followed by the sub-ensemble, and * the next sub-ensemble, and so on. Then add the part * name from the ensPart argument. */ if (prevArgObj) { name = Tcl_GetStringFromObj(prevArgObj, &length); Tcl_DStringAppend(&buffer, name, length); } if (ensPart) { Tcl_DStringAppendElement(&buffer, ensPart->name); } /* * The following allocates an empty string on the heap if name is "" * (e.g., if the internal rep is NULL). */ name = Tcl_DStringValue(&buffer); length = strlen(name); objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); objPtr->bytes[length] = '\0'; objPtr->length = length; } itcl3.4.3/generic/itcl_methods.c0000644003604700454610000025017512632344510015242 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 commands available within a class scope. * In [incr Tcl], the term "method" is used for a procedure that has * access to object-specific data, while the term "proc" is used for * a procedure that has access only to common class data. * * ======================================================================== * 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" /* * FORWARD DECLARATIONS */ static int ItclParseConfig _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], ItclObject *contextObj, int *rargc, ItclVarDefn ***rvars, char ***rvals)); static int ItclHandleConfig _ANSI_ARGS_((Tcl_Interp *interp, int argc, ItclVarDefn **vars, char **vals, ItclObject *contextObj)); static void ItclReleaseMethod (ClientData cdata); /* * ------------------------------------------------------------------------ * Itcl_BodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::body" command to * define or redefine the implementation for a class method/proc. * Handles the following syntax: * * itcl::body :: * * Looks for an existing class member function with the name , * and if found, tries to assign the implementation. If an argument * list was specified in the original declaration, it must match * or an error is flagged. If has the form "@name" * then it is treated as a reference to a C handling procedure; * otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_BodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int status = TCL_OK; char *head, *tail, *token, *arglist, *body; ItclClass *cdefn; ItclMemberFunc *mfunc; Tcl_HashEntry *entry; Tcl_DString buffer; if (objc != 4) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "wrong # args: should be \"", token, " class::func arglist body\"", (char*)NULL); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::func". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendResult(interp, "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto bodyCmdDone; } /* * Find the function and try to change its implementation. * Note that command resolution table contains *all* functions, * even those in a base class. Make sure that the class * containing the method definition is the requested class. */ mfunc = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveCmds, tail); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); if (mfunc->member->classDefn != cdefn) { mfunc = NULL; } } if (mfunc == NULL) { Tcl_AppendResult(interp, "function \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto bodyCmdDone; } arglist = Tcl_GetStringFromObj(objv[2], (int*)NULL); body = Tcl_GetStringFromObj(objv[3], (int*)NULL); if (Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) != TCL_OK) { status = TCL_ERROR; goto bodyCmdDone; } bodyCmdDone: Tcl_DStringFree(&buffer); return status; } /* * ------------------------------------------------------------------------ * Itcl_ConfigBodyCmd() * * Invoked by Tcl whenever the user issues an "itcl::configbody" command * to define or redefine the configuration code associated with a * public variable. Handles the following syntax: * * itcl::configbody :: * * Looks for an existing public variable with the name , * and if found, tries to assign the implementation. If has * the form "@name" then it is treated as a reference to a C handling * procedure; otherwise, it is taken as a body of Tcl statements. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_ConfigBodyCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int status = TCL_OK; char *head, *tail, *token; Tcl_DString buffer; ItclClass *cdefn; ItclVarLookup *vlookup; ItclMember *member; ItclMemberCode *mcode; Tcl_HashEntry *entry; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "class::option body"); return TCL_ERROR; } /* * Parse the member name "namesp::namesp::class::option". * Make sure that a class name was specified, and that the * class exists. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); Itcl_ParseNamespPath(token, &buffer, &head, &tail); if (!head || *head == '\0') { Tcl_AppendResult(interp, "missing class specifier for body declaration \"", token, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } cdefn = Itcl_FindClass(interp, head, /* autoload */ 1); if (cdefn == NULL) { status = TCL_ERROR; goto configBodyCmdDone; } /* * Find the variable and change its implementation. * Note that variable resolution table has *all* variables, * even those in a base class. Make sure that the class * containing the variable definition is the requested class. */ vlookup = NULL; entry = Tcl_FindHashEntry(&cdefn->resolveVars, tail); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (vlookup->vdefn->member->classDefn != cdefn) { vlookup = NULL; } } if (vlookup == NULL) { Tcl_AppendResult(interp, "option \"", tail, "\" is not defined in class \"", cdefn->fullname, "\"", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } member = vlookup->vdefn->member; if (member->protection != ITCL_PUBLIC) { Tcl_AppendResult(interp, "option \"", member->fullname, "\" is not a public configuration option", (char*)NULL); status = TCL_ERROR; goto configBodyCmdDone; } token = Tcl_GetStringFromObj(objv[2], (int*)NULL); if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, token, &mcode) != TCL_OK) { status = TCL_ERROR; goto configBodyCmdDone; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); if (member->code) { Itcl_ReleaseData((ClientData)member->code); } member->code = mcode; configBodyCmdDone: Tcl_DStringFree(&buffer); return status; } /* * ------------------------------------------------------------------------ * Itcl_CreateMethod() * * Installs a method into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. * * Returns TCL_OK on success, or TCL_ERROR (along with an error message * in the specified interp) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_CreateMethod(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new method */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ { ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the method name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendResult(interp, "bad method name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the method definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Build a fully-qualified name for the method, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); Itcl_PreserveData((ClientData)mfunc); mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecMethod, (ClientData)mfunc, ItclReleaseMethod); Tcl_DStringFree(&buffer); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateProc() * * Installs a class proc into the namespace associated with a class. * If another command with the same name is already installed, then * it is overwritten. Returns TCL_OK on success, or TCL_ERROR (along * with an error message in the specified interp) if anything goes * wrong. * ------------------------------------------------------------------------ */ int Itcl_CreateProc(interp, cdefn, name, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new proc */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the proc */ { ItclMemberFunc *mfunc; Tcl_DString buffer; /* * Make sure that the proc name does not contain anything * goofy like a "::" scope qualifier. */ if (strstr(name,"::")) { Tcl_AppendResult(interp, "bad proc name \"", name, "\"", (char*)NULL); return TCL_ERROR; } /* * Create the proc definition. */ if (Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, &mfunc) != TCL_OK) { return TCL_ERROR; } /* * Mark procs as "common". This distinguishes them from methods. */ mfunc->member->flags |= ITCL_COMMON; /* * Build a fully-qualified name for the proc, and install * the command handler. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, cdefn->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "::", 2); Tcl_DStringAppend(&buffer, name, -1); name = Tcl_DStringValue(&buffer); Itcl_PreserveData((ClientData)mfunc); mfunc->accessCmd = Tcl_CreateObjCommand(interp, name, Itcl_ExecProc, (ClientData)mfunc, ItclReleaseMethod); Tcl_DStringFree(&buffer); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_CreateMemberFunc() * * Creates the data record representing a member function. This * includes the argument list and the body of the function. If the * body is of the form "@name", then it is treated as a label for * a C procedure registered by Itcl_RegisterC(). * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mfuncPtr" returns a pointer to the new * member function. * ------------------------------------------------------------------------ */ int Itcl_CreateMemberFunc(interp, cdefn, name, arglist, body, mfuncPtr) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new member */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ ItclMemberFunc** mfuncPtr; /* returns: pointer to new method defn */ { int newEntry; ItclMemberFunc *mfunc; ItclMemberCode *mcode; Tcl_HashEntry *entry; /* * Add the member function to the list of functions for * the class. Make sure that a member function with the * same name doesn't already exist. */ entry = Tcl_CreateHashEntry(&cdefn->functions, name, &newEntry); if (!newEntry) { Tcl_AppendResult(interp, "\"", name, "\" already defined in class \"", cdefn->fullname, "\"", (char*)NULL); return TCL_ERROR; } /* * Try to create the implementation for this command member. */ if (Itcl_CreateMemberCode(interp, cdefn, arglist, body, &mcode) != TCL_OK) { Tcl_DeleteHashEntry(entry); return TCL_ERROR; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); /* * Allocate a member function definition and return. */ mfunc = (ItclMemberFunc*)ckalloc(sizeof(ItclMemberFunc)); mfunc->member = Itcl_CreateMember(interp, cdefn, name); mfunc->member->code = mcode; if (mfunc->member->protection == ITCL_DEFAULT_PROTECT) { mfunc->member->protection = ITCL_PUBLIC; } mfunc->arglist = NULL; mfunc->argcount = 0; mfunc->accessCmd = NULL; if (arglist) { mfunc->member->flags |= ITCL_ARG_SPEC; } if (mcode->arglist) { Itcl_CreateArgList(interp, arglist, &mfunc->argcount, &mfunc->arglist); } if (strcmp(name,"constructor") == 0) { mfunc->member->flags |= ITCL_CONSTRUCTOR; } if (strcmp(name,"destructor") == 0) { mfunc->member->flags |= ITCL_DESTRUCTOR; } Tcl_SetHashValue(entry, (ClientData)mfunc); Itcl_PreserveData((ClientData)mfunc); Itcl_EventuallyFree((ClientData)mfunc, (Tcl_FreeProc*) Itcl_DeleteMemberFunc); *mfuncPtr = mfunc; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_ChangeMemberFunc() * * Modifies the data record representing a member function. This * is usually the body of the function, but can include the argument * list if it was not defined when the member was first created. * If the body is of the form "@name", then it is treated as a label * for a C procedure registered by Itcl_RegisterC(). * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mfuncPtr" returns a pointer to the new * member function. * ------------------------------------------------------------------------ */ int Itcl_ChangeMemberFunc(interp, mfunc, arglist, body) Tcl_Interp* interp; /* interpreter managing this action */ ItclMemberFunc* mfunc; /* command member being changed */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ { ItclMemberCode *mcode = NULL; Tcl_Obj *objPtr; /* * Try to create the implementation for this command member. */ if (Itcl_CreateMemberCode(interp, mfunc->member->classDefn, arglist, body, &mcode) != TCL_OK) { return TCL_ERROR; } /* * If the argument list was defined when the function was * created, compare the arg lists or usage strings to make sure * that the interface is not being redefined. */ if ((mfunc->member->flags & ITCL_ARG_SPEC) != 0 && !Itcl_EquivArgLists(mfunc->arglist, mfunc->argcount, mcode->arglist, mcode->argcount)) { objPtr = Itcl_ArgList(mfunc->argcount, mfunc->arglist); Tcl_IncrRefCount(objPtr); Tcl_AppendResult(interp, "argument list changed for function \"", mfunc->member->fullname, "\": should be \"", Tcl_GetStringFromObj(objPtr, (int*)NULL), "\"", (char*)NULL); Tcl_DecrRefCount(objPtr); Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } /* * Free up the old implementation and install the new one. */ Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); Itcl_ReleaseData((ClientData)mfunc->member->code); mfunc->member->code = mcode; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteMemberFunc() * * Destroys all data associated with the given member function definition. * Usually invoked by the interpreter when a member function is deleted. * ------------------------------------------------------------------------ */ void Itcl_DeleteMemberFunc(cdata) CONST char* cdata; /* pointer to member function definition */ { ItclMemberFunc* mfunc = (ItclMemberFunc*)cdata; if (mfunc) { Itcl_DeleteMember(mfunc->member); if (mfunc->arglist) { Itcl_DeleteArgList(mfunc->arglist); } ckfree((char*)mfunc); } } /* * ------------------------------------------------------------------------ * Itcl_CreateMemberCode() * * Creates the data record representing the implementation behind a * class member function. This includes the argument list and the body * of the function. If the body is of the form "@name", then it is * treated as a label for a C procedure registered by Itcl_RegisterC(). * * The implementation is kept by the member function definition, and * controlled by a preserve/release paradigm. That way, if it is in * use while it is being redefined, it will stay around long enough * to avoid a core dump. * * If any errors are encountered, this procedure returns TCL_ERROR * along with an error message in the interpreter. Otherwise, it * returns TCL_OK, and "mcodePtr" returns a pointer to the new * implementation. * ------------------------------------------------------------------------ */ int Itcl_CreateMemberCode(interp, cdefn, arglist, body, mcodePtr) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class containing this member */ CONST char* arglist; /* space-separated list of arg names */ CONST char* body; /* body of commands for the method */ ItclMemberCode** mcodePtr; /* returns: pointer to new implementation */ { int argc; CompiledLocal *args, *localPtr; ItclMemberCode *mcode; Proc *procPtr; /* * Allocate some space to hold the implementation. */ mcode = (ItclMemberCode*)ckalloc(sizeof(ItclMemberCode)); memset(mcode, 0, sizeof(ItclMemberCode)); if (arglist) { if (Itcl_CreateArgList(interp, arglist, &argc, &args) != TCL_OK) { Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } mcode->argcount = argc; mcode->arglist = args; mcode->flags |= ITCL_ARG_SPEC; } else { argc = 0; args = NULL; } /* * Create a standard Tcl Proc representation for this code body. * This is required, since the Tcl compiler looks for a proc * when handling things such as the call frame context and * compiled locals. */ procPtr = (Proc*)ckalloc(sizeof(Proc)); mcode->procPtr = procPtr; procPtr->iPtr = (Interp*)interp; procPtr->refCount = 1; procPtr->cmdPtr = (Command*)ckalloc(sizeof(Command)); memset(procPtr->cmdPtr, 0, sizeof(Command)); procPtr->cmdPtr->nsPtr = (Namespace*)cdefn->namesp; if (body) { procPtr->bodyPtr = Tcl_NewStringObj(body, -1); } else { procPtr->bodyPtr = Tcl_NewStringObj("", -1); mcode->flags |= ITCL_IMPLEMENT_NONE; } Tcl_IncrRefCount(procPtr->bodyPtr); /* * Plug the argument list into the "compiled locals" list. * * NOTE: The storage for this argument list is owned by * the caller, so although we plug it in here, it is not * our responsibility to free it. */ procPtr->firstLocalPtr = args; procPtr->lastLocalPtr = NULL; for (localPtr=mcode->arglist; localPtr; localPtr=localPtr->nextPtr) { procPtr->lastLocalPtr = localPtr; } procPtr->numArgs = argc; procPtr->numCompiledLocals = argc; /* * If the body definition starts with '@', then treat the value * as a symbolic name for a C procedure. */ if (body == NULL) { /* No-op */ } else if (*body == '@') { Tcl_CmdProc *argCmdProc; Tcl_ObjCmdProc *objCmdProc; ClientData cdata; if (!Itcl_FindC(interp, body+1, &argCmdProc, &objCmdProc, &cdata)) { Tcl_AppendResult(interp, "no registered C procedure with name \"", body+1, "\"", (char*)NULL); Itcl_DeleteMemberCode((char*)mcode); return TCL_ERROR; } if (objCmdProc != NULL) { mcode->flags |= ITCL_IMPLEMENT_OBJCMD; mcode->cfunc.objCmd = objCmdProc; mcode->clientData = cdata; } else if (argCmdProc != NULL) { mcode->flags |= ITCL_IMPLEMENT_ARGCMD; mcode->cfunc.argCmd = argCmdProc; mcode->clientData = cdata; } } /* * Otherwise, treat the body as a chunk of Tcl code. */ else { mcode->flags |= ITCL_IMPLEMENT_TCL; } *mcodePtr = mcode; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteMemberCode() * * Destroys all data associated with the given command implementation. * Invoked automatically by Itcl_ReleaseData() when the implementation * is no longer being used. * ------------------------------------------------------------------------ */ void Itcl_DeleteMemberCode(cdata) CONST char* cdata; /* pointer to member function definition */ { ItclMemberCode* mcode = (ItclMemberCode*)cdata; /* * Free the argument list. If empty, free the compiled locals, if any. */ if (mcode->arglist) { Itcl_DeleteArgList(mcode->arglist); } else if (mcode->procPtr && mcode->procPtr->firstLocalPtr) { Itcl_DeleteArgList(mcode->procPtr->firstLocalPtr); } if (mcode->procPtr) { ckfree((char*) mcode->procPtr->cmdPtr); if (mcode->procPtr->bodyPtr) { Tcl_DecrRefCount(mcode->procPtr->bodyPtr); } ckfree((char*)mcode->procPtr); } ckfree((char*)mcode); } /* * ------------------------------------------------------------------------ * Itcl_GetMemberCode() * * Makes sure that the implementation for an [incr Tcl] code body is * ready to run. Note that a member function can be declared without * being defined. The class definition may contain a declaration of * the member function, but its body may be defined in a separate file. * If an undefined function is encountered, this routine automatically * attempts to autoload it. If the body is implemented via Tcl code, * then it is compiled here as well. * * Returns TCL_ERROR (along with an error message in the interpreter) * if an error is encountered, or if the implementation is not defined * and cannot be autoloaded. Returns TCL_OK if implementation is * ready to use. * ------------------------------------------------------------------------ */ int Itcl_GetMemberCode(interp, member) Tcl_Interp* interp; /* interpreter managing this action */ ItclMember* member; /* member containing code body */ { int result; ItclMemberCode *mcode = member->code; assert(mcode != NULL); /* * If the implementation has not yet been defined, try to * autoload it now. */ if (!Itcl_IsMemberCodeImplemented(mcode)) { result = Tcl_VarEval(interp, "::auto_load ", member->fullname, (char*)NULL); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while autoloading code for \"%.100s\")", member->fullname); Tcl_AddErrorInfo(interp, msg); return result; } Tcl_ResetResult(interp); /* get rid of 1/0 status */ } /* * If the implementation is still not available, then * autoloading must have failed. * * TRICKY NOTE: If code has been autoloaded, then the * old mcode pointer is probably invalid. Go back to * the member and look at the current code pointer again. */ mcode = member->code; assert(mcode != NULL); if (!Itcl_IsMemberCodeImplemented(mcode)) { Tcl_AppendResult(interp, "member function \"", member->fullname, "\" is not defined and cannot be autoloaded", (char*)NULL); return TCL_ERROR; } /* * If the member is a constructor and the class has an * initialization command, compile it here. */ if ((member->flags & ITCL_CONSTRUCTOR) != 0 && (member->classDefn->initCode != NULL)) { result = TclProcCompileProc(interp, mcode->procPtr, member->classDefn->initCode, (Namespace*)member->classDefn->namesp, "initialization code for", member->fullname); if (result != TCL_OK) { return result; } } /* * If the code body has a Tcl implementation, then compile it here. */ if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { /* * UGLY UGLY UGLY hackery to accommodate changing Tcl * internals in Tcl 8.6. */ int saveNumArgs = mcode->procPtr->numArgs; mcode->procPtr->numArgs = mcode->procPtr->numCompiledLocals; result = TclProcCompileProc(interp, mcode->procPtr, mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, "body for", member->fullname); mcode->procPtr->numArgs = saveNumArgs; if (result != TCL_OK) { return result; } } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_EvalMemberCode() * * Used to execute an ItclMemberCode representation of a code * fragment. This code may be a body of Tcl commands, or a C handler * procedure. * * Executes the command with the given arguments (objc,objv) and * returns an integer status code (TCL_OK/TCL_ERROR). Returns the * result string or an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv) Tcl_Interp *interp; /* current interpreter */ ItclMemberFunc *mfunc; /* member func, or NULL (for error messages) */ ItclMember *member; /* command member containing code */ ItclObject *contextObj; /* object context, or NULL */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int result = TCL_OK; Itcl_CallFrame *oldFramePtr = NULL; int i, transparent, newEntry; ItclObjectInfo *info; ItclMemberCode *mcode; ItclContext context; Itcl_CallFrame *framePtr, *transFramePtr; /* * If this code does not have an implementation yet, then * try to autoload one. Also, if this is Tcl code, make sure * that it's compiled and ready to use. */ if (Itcl_GetMemberCode(interp, member) != TCL_OK) { return TCL_ERROR; } mcode = member->code; /* * Bump the reference count on this code, in case it is * redefined or deleted during execution. */ Itcl_PreserveData((ClientData)mcode); /* * Install a new call frame context for the current code. * If the current call frame is marked as "transparent", then * do an "uplevel" operation to move past it. Transparent * call frames are installed by Itcl_HandleInstance. They * provide a way of entering an object context without * interfering with the normal call stack. */ transparent = 0; info = member->classDefn->info; framePtr = _Tcl_GetCallFrame(interp, 0); for (i = Itcl_GetStackSize(&info->transparentFrames)-1; i >= 0; i--) { transFramePtr = (Itcl_CallFrame*) Itcl_GetStackValue(&info->transparentFrames, i); if (framePtr == transFramePtr) { transparent = 1; break; } } if (transparent) { framePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, framePtr); } if (Itcl_PushContext(interp, member, member->classDefn, contextObj, &context) != TCL_OK) { return TCL_ERROR; } /* * If this is a method with a Tcl implementation, or a * constructor with initCode, then parse its arguments now. */ if (mfunc && objc > 0) { if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0 || ( (member->flags & ITCL_CONSTRUCTOR) != 0 && (member->classDefn->initCode != NULL) ) ) { if (Itcl_AssignArgs(interp, objc, objv, mfunc) != TCL_OK) { result = TCL_ERROR; goto evalMemberCodeDone; } } } /* * If this code is a constructor, and if it is being invoked * when an object is first constructed (i.e., the "constructed" * table is still active within the object), then handle the * "initCode" associated with the constructor and make sure that * all base classes are properly constructed. * * TRICKY NOTE: * The "initCode" must be executed here. This is the only * opportunity where the arguments of the constructor are * available in a call frame. */ if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && contextObj->constructed) { result = Itcl_ConstructBase(interp, contextObj, member->classDefn); if (result != TCL_OK) { goto evalMemberCodeDone; } } /* * Execute the code body... */ if ((mcode->flags & ITCL_IMPLEMENT_OBJCMD) != 0) { result = (*mcode->cfunc.objCmd)(mcode->clientData, interp, objc, objv); } else if ((mcode->flags & ITCL_IMPLEMENT_ARGCMD) != 0) { CONST char **argv; argv = (CONST char**)ckalloc( (unsigned)(objc*sizeof(char*)) ); for (i=0; i < objc; i++) { argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); } result = (*mcode->cfunc.argCmd)(mcode->clientData, interp, objc, argv); ckfree((char*)argv); } else if ((mcode->flags & ITCL_IMPLEMENT_TCL) != 0) { result = Tcl_EvalObj(interp, mcode->procPtr->bodyPtr); } else { Tcl_Panic("itcl: bad implementation flag for %s", member->fullname); } /* * If this is a constructor or destructor, and if it is being * invoked at the appropriate time, keep track of which methods * have been called. This information is used to implicitly * invoke constructors/destructors as needed. */ if ((member->flags & ITCL_DESTRUCTOR) && contextObj && contextObj->destructed) { Tcl_CreateHashEntry(contextObj->destructed, member->classDefn->fullname, &newEntry); } if ((member->flags & ITCL_CONSTRUCTOR) && contextObj && contextObj->constructed) { Tcl_CreateHashEntry(contextObj->constructed, member->classDefn->name, &newEntry); } evalMemberCodeDone: Itcl_PopContext(interp, &context); if (transparent) { (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); } Itcl_ReleaseData((ClientData)mcode); return result; } /* * ------------------------------------------------------------------------ * Itcl_CreateArgList() * * Parses a Tcl list representing an argument declaration and returns * a linked list of CompiledLocal values. Usually invoked as part * of Itcl_CreateMemberFunc() when a new method or procedure is being * defined. * ------------------------------------------------------------------------ */ int Itcl_CreateArgList(interp, decl, argcPtr, argPtr) Tcl_Interp* interp; /* interpreter managing this function */ CONST char* decl; /* string representing argument list */ int* argcPtr; /* returns number of args in argument list */ CompiledLocal** argPtr; /* returns pointer to parsed argument list */ { int status = TCL_OK; /* assume that this will succeed */ int i, argc, fargc; CONST char **argv, **fargv; CompiledLocal *localPtr, *last; *argPtr = last = NULL; *argcPtr = 0; if (decl) { if (Tcl_SplitList(interp, decl, &argc, &argv) != TCL_OK) { return TCL_ERROR; } for (i=0; i < argc && status == TCL_OK; i++) { if (Tcl_SplitList(interp, argv[i], &fargc, &fargv) != TCL_OK) { status = TCL_ERROR; } else { localPtr = NULL; if (fargc == 0 || *fargv[0] == '\0') { char mesg[100]; sprintf(mesg, "argument #%d has no name", i); Tcl_SetResult(interp, mesg, TCL_VOLATILE); status = TCL_ERROR; } else if (fargc > 2) { Tcl_AppendResult(interp, "too many fields in argument specifier \"", argv[i], "\"", (char*)NULL); status = TCL_ERROR; } else if (strstr(fargv[0],"::")) { Tcl_AppendResult(interp, "bad argument name \"", fargv[0], "\"", (char*)NULL); status = TCL_ERROR; } else if (fargc == 1) { localPtr = Itcl_CreateArg(fargv[0], (char*)NULL); } else { localPtr = Itcl_CreateArg(fargv[0], fargv[1]); } if (localPtr) { localPtr->frameIndex = i; if (*argPtr == NULL) { *argPtr = last = localPtr; } else { last->nextPtr = localPtr; last = localPtr; } } } ckfree((char*)fargv); } ckfree((char*)argv); } /* * If anything went wrong, destroy whatever arguments were * created and return an error. */ if (status == TCL_OK) { *argcPtr = argc; } else { Itcl_DeleteArgList(*argPtr); *argPtr = NULL; } return status; } /* * ------------------------------------------------------------------------ * Itcl_CreateArg() * * Creates a new Tcl Arg structure and fills it with the given * information. Returns a pointer to the new Arg structure. * ------------------------------------------------------------------------ */ CompiledLocal* Itcl_CreateArg(name, init) CONST char* name; /* name of new argument */ CONST char* init; /* initial value */ { CompiledLocal *localPtr = NULL; int nameLen; if (name == NULL) { name = ""; } nameLen = strlen(name); localPtr = (CompiledLocal*)ckalloc( (unsigned)(sizeof(CompiledLocal)-sizeof(localPtr->name) + nameLen+1) ); localPtr->nextPtr = NULL; localPtr->nameLength = nameLen; localPtr->frameIndex = 0; /* set this later */ ItclInitVarArgument(localPtr); localPtr->resolveInfo = NULL; if (init != NULL) { localPtr->defValuePtr = Tcl_NewStringObj(init, -1); Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } strcpy(localPtr->name, name); return localPtr; } /* * ------------------------------------------------------------------------ * Itcl_DeleteArgList() * * Destroys a chain of arguments acting as an argument list. Usually * invoked when a method/proc is being destroyed, to discard its * argument list. * ------------------------------------------------------------------------ */ void Itcl_DeleteArgList(arglist) CompiledLocal *arglist; /* first argument in arg list chain */ { CompiledLocal *localPtr, *next; for (localPtr=arglist; localPtr; localPtr=next) { if (localPtr->defValuePtr != NULL) { Tcl_DecrRefCount(localPtr->defValuePtr); } if (localPtr->resolveInfo) { if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { ckfree((char*)localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } next = localPtr->nextPtr; ckfree((char*)localPtr); } } /* * ------------------------------------------------------------------------ * Itcl_ArgList() * * Returns a Tcl_Obj containing the string representation for the * given argument list. This object has a reference count of 1. * The reference count should be decremented when the string is no * longer needed, and it will free itself. * ------------------------------------------------------------------------ */ Tcl_Obj* Itcl_ArgList(argc, arglist) int argc; /* number of arguments */ CompiledLocal* arglist; /* first argument in arglist */ { char *val; Tcl_Obj *objPtr; Tcl_DString buffer; Tcl_DStringInit(&buffer); while (arglist && argc-- > 0) { if (arglist->defValuePtr) { val = Tcl_GetStringFromObj(arglist->defValuePtr, (int*)NULL); Tcl_DStringStartSublist(&buffer); Tcl_DStringAppendElement(&buffer, arglist->name); Tcl_DStringAppendElement(&buffer, val); Tcl_DStringEndSublist(&buffer); } else { Tcl_DStringAppendElement(&buffer, arglist->name); } arglist = arglist->nextPtr; } objPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), Tcl_DStringLength(&buffer)); Tcl_DStringFree(&buffer); return objPtr; } /* * ------------------------------------------------------------------------ * Itcl_EquivArgLists() * * Compares two argument lists to see if they are equivalent. The * first list is treated as a prototype, and the second list must * match it. Argument names may be different, but they must match in * meaning. If one argument is optional, the corresponding argument * must also be optional. If the prototype list ends with the magic * "args" argument, then it matches everything in the other list. * * Returns non-zero if the argument lists are equivalent. * ------------------------------------------------------------------------ */ int Itcl_EquivArgLists(arg1, arg1c, arg2, arg2c) CompiledLocal* arg1; /* prototype argument list */ int arg1c; /* number of args in prototype arg list */ CompiledLocal* arg2; /* another argument list to match against */ int arg2c; /* number of args in matching list */ { char *dval1, *dval2; while (arg1 && arg1c > 0 && arg2 && arg2c > 0) { /* * If the prototype argument list ends with the magic "args" * argument, then it matches everything in the other list. */ if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { return 1; } /* * If one has a default value, then the other must have the * same default value. */ if (arg1->defValuePtr) { if (arg2->defValuePtr == NULL) { return 0; } dval1 = Tcl_GetStringFromObj(arg1->defValuePtr, (int*)NULL); dval2 = Tcl_GetStringFromObj(arg2->defValuePtr, (int*)NULL); if (strcmp(dval1, dval2) != 0) { return 0; } } else if (arg2->defValuePtr) { return 0; } arg1 = arg1->nextPtr; arg1c--; arg2 = arg2->nextPtr; arg2c--; } if (arg1c == 1 && strcmp(arg1->name,"args") == 0) { return 1; } return (arg1c == 0 && arg2c == 0); } /* * ------------------------------------------------------------------------ * Itcl_GetMemberFuncUsage() * * Returns a string showing how a command member should be invoked. * If the command member is a method, then the specified object name * is reported as part of the invocation path: * * obj method arg ?arg arg ...? * * Otherwise, the "obj" pointer is ignored, and the class name is * used as the invocation path: * * class::proc arg ?arg arg ...? * * Returns the string by appending it onto the Tcl_Obj passed in as * an argument. * ------------------------------------------------------------------------ */ void Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr) ItclMemberFunc *mfunc; /* command member being examined */ ItclObject *contextObj; /* invoked with respect to this object */ Tcl_Obj *objPtr; /* returns: string showing usage */ { int argcount; char *name; CompiledLocal *arglist, *argPtr; Tcl_HashEntry *entry; ItclMemberFunc *mf; ItclClass *cdefnPtr; /* * If the command is a method and an object context was * specified, then add the object context. If the method * was a constructor, and if the object is being created, * then report the invocation via the class creation command. */ if ((mfunc->member->flags & ITCL_COMMON) == 0) { if ((mfunc->member->flags & ITCL_CONSTRUCTOR) != 0 && contextObj->constructed) { cdefnPtr = (ItclClass*)contextObj->classDefn; mf = NULL; entry = Tcl_FindHashEntry(&cdefnPtr->resolveCmds, "constructor"); if (entry) { mf = (ItclMemberFunc*)Tcl_GetHashValue(entry); } if (mf == mfunc) { Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->classDefn->accessCmd, objPtr); Tcl_AppendToObj(objPtr, " ", -1); name = (char *) Tcl_GetCommandName( contextObj->classDefn->interp, contextObj->accessCmd); Tcl_AppendToObj(objPtr, name, -1); } else { Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); } } else if (contextObj && contextObj->accessCmd) { name = (char *) Tcl_GetCommandName(contextObj->classDefn->interp, contextObj->accessCmd); Tcl_AppendStringsToObj(objPtr, name, " ", mfunc->member->name, (char*)NULL); } else { Tcl_AppendStringsToObj(objPtr, " ", mfunc->member->name, (char*)NULL); } } else { Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); } /* * Add the argument usage info. */ if (mfunc->member->code) { arglist = mfunc->member->code->arglist; argcount = mfunc->member->code->argcount; } else if (mfunc->arglist) { arglist = mfunc->arglist; argcount = mfunc->argcount; } else { arglist = NULL; argcount = 0; } if (arglist) { for (argPtr=arglist; argPtr && argcount > 0; argPtr=argPtr->nextPtr, argcount--) { if (argcount == 1 && strcmp(argPtr->name, "args") == 0) { Tcl_AppendToObj(objPtr, " ?arg arg ...?", -1); } else if (argPtr->defValuePtr) { Tcl_AppendStringsToObj(objPtr, " ?", argPtr->name, "?", (char*)NULL); } else { Tcl_AppendStringsToObj(objPtr, " ", argPtr->name, (char*)NULL); } } } } /* * ------------------------------------------------------------------------ * Itcl_ExecMethod() * * Invoked by Tcl to handle the execution of a user-defined method. * A method is similar to the usual Tcl proc, but has access to * object-specific data. If for some reason there is no current * object context, then a method call is inappropriate, and an error * is returned. * * Methods are implemented either as Tcl code fragments, or as C-coded * procedures. For Tcl code fragments, command arguments are parsed * according to the argument list, and the body is executed in the * scope of the class where it was defined. For C procedures, the * arguments are passed in "as-is", and the procedure is executed in * the most-specific class scope. * ------------------------------------------------------------------------ */ int Itcl_ExecMethod(clientData, interp, objc, objv) ClientData clientData; /* method definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; ItclMember *member = mfunc->member; int result = TCL_OK; char *token; Tcl_HashEntry *entry; ItclClass *contextClass; ItclObject *contextObj; /* * Make sure that the current namespace context includes an * object that is being manipulated. Methods can be executed * only if an object context exists. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { return TCL_ERROR; } if (contextObj == NULL) { Tcl_AppendResult(interp, "cannot access object-specific info without an object context", (char*)NULL); return TCL_ERROR; } /* * Make sure that this command member can be accessed from * the current namespace context. */ if (mfunc->member->protection != ITCL_PUBLIC) { Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, contextClass->info); if (!Itcl_CanAccessFunc(mfunc, contextNs)) { Tcl_AppendResult(interp, "can't access \"", member->fullname, "\": ", Itcl_ProtectionStr(member->protection), " function", (char*)NULL); return TCL_ERROR; } } /* * All methods should be "virtual" unless they are invoked with * a "::" scope qualifier. * * To implement the "virtual" behavior, find the most-specific * implementation for the method by looking in the "resolveCmds" * table for this class. */ token = Tcl_GetStringFromObj(objv[0], (int*)NULL); if (strstr(token, "::") == NULL) { entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveCmds, member->name); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); member = mfunc->member; } } /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, objc, objv); result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); Itcl_ReleaseData((ClientData)mfunc); return result; } /* * ------------------------------------------------------------------------ * Itcl_ExecProc() * * Invoked by Tcl to handle the execution of a user-defined proc. * * Procs are implemented either as Tcl code fragments, or as C-coded * procedures. For Tcl code fragments, command arguments are parsed * according to the argument list, and the body is executed in the * scope of the class where it was defined. For C procedures, the * arguments are passed in "as-is", and the procedure is executed in * the most-specific class scope. * ------------------------------------------------------------------------ */ int Itcl_ExecProc(clientData, interp, objc, objv) ClientData clientData; /* proc definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclMemberFunc *mfunc = (ItclMemberFunc*)clientData; ItclMember *member = mfunc->member; int result = TCL_OK; /* * Make sure that this command member can be accessed from * the current namespace context. */ if (mfunc->member->protection != ITCL_PUBLIC) { Tcl_Namespace *contextNs = Itcl_GetTrueNamespace(interp, mfunc->member->classDefn->info); if (!Itcl_CanAccessFunc(mfunc, contextNs)) { Tcl_AppendResult(interp, "can't access \"", member->fullname, "\": ", Itcl_ProtectionStr(member->protection), " function", (char*)NULL); return TCL_ERROR; } } /* * Execute the code for the proc. Be careful to protect * the proc in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, (ItclObject*)NULL, objc, objv); result = Itcl_ReportFuncErrors(interp, mfunc, (ItclObject*)NULL, result); Itcl_ReleaseData((ClientData)mfunc); return result; } /* * ------------------------------------------------------------------------ * Itcl_PushContext() * * Sets up the class/object context so that a body of [incr Tcl] * code can be executed. This procedure pushes a call frame with * the proper namespace context for the class. If an object context * is supplied, the object's instance variables are integrated into * the call frame so they can be accessed as local variables. * ------------------------------------------------------------------------ */ int Itcl_PushContext(interp, member, contextClass, contextObj, contextPtr) Tcl_Interp *interp; /* interpreter managing this body of code */ ItclMember *member; /* member containing code body */ ItclClass *contextClass; /* class context */ ItclObject *contextObj; /* object context, or NULL */ ItclContext *contextPtr; /* storage space for class/object context */ { ItclCallFrame *framePtr = (ItclCallFrame *) &contextPtr->frame; int result, localCt, newEntry; ItclMemberCode *mcode; Proc *procPtr; Tcl_HashEntry *entry; /* * Activate the call frame. If this fails, we'll bail out * before allocating any resources. * * NOTE: Always push a call frame that looks like a proc. * This causes global variables to be handled properly * inside methods/procs. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame*)framePtr, contextClass->namesp, /* isProcCallFrame */ 1); if (result != TCL_OK) { return result; } contextPtr->classDefn = contextClass; contextPtr->compiledLocals = &contextPtr->localStorage[0]; /* * If this is an object context, register it in a hash table * of all known contexts. We'll need this later if we * call Itcl_GetContext to get the object context for the * current call frame. */ if (contextObj) { entry = Tcl_CreateHashEntry(&contextClass->info->contextFrames, (char*)framePtr, &newEntry); Itcl_PreserveData((ClientData)contextObj); Tcl_SetHashValue(entry, (ClientData)contextObj); } /* * Set up the compiled locals in the call frame and assign * argument variables. */ if (member) { mcode = member->code; procPtr = mcode->procPtr; /* * Invoking TclInitCompiledLocals with a framePtr->procPtr->bodyPtr * that is not a compiled byte code type leads to a crash. So * make sure that the body is compiled here. This needs to * be done even if the body of the Itcl method is not implemented * as a Tcl proc or has no implementation. The empty string should * have been defined as the body if no implementation was defined. */ assert(mcode->procPtr->bodyPtr != NULL); result = TclProcCompileProc(interp, mcode->procPtr, mcode->procPtr->bodyPtr, (Namespace*)member->classDefn->namesp, "body for", member->fullname); if (result != TCL_OK) { return result; } /* * If there are too many compiled locals to fit in the default * storage space for the context, then allocate more space. */ localCt = procPtr->numCompiledLocals; if (localCt > (int)(sizeof(contextPtr->localStorage)/itclVarLocalSize)) { contextPtr->compiledLocals = (Var*)ckalloc( (unsigned)(localCt * itclVarLocalSize) ); } /* * Initialize and resolve compiled variable references. * Class variables will have special resolution rules. * In that case, we call their "resolver" procs to get our * hands on the variable, and we make the compiled local a * link to the real variable. */ framePtr->procPtr = procPtr; framePtr->numCompiledLocals = localCt; framePtr->compiledLocals = contextPtr->compiledLocals; TclInitCompiledLocals(interp, (CallFrame *) framePtr, (Namespace*)contextClass->namesp); } return result; } /* * ------------------------------------------------------------------------ * Itcl_PopContext() * * Removes a class/object context previously set up by Itcl_PushContext. * Usually called after an [incr Tcl] code body has been executed, * to clean up. * ------------------------------------------------------------------------ */ void Itcl_PopContext(interp, contextPtr) Tcl_Interp *interp; /* interpreter managing this body of code */ ItclContext *contextPtr; /* storage space for class/object context */ { Itcl_CallFrame *framePtr; ItclObjectInfo *info; ItclObject *contextObj; Tcl_HashEntry *entry; /* * See if the current call frame has an object context * associated with it. If so, release the claim on the * object info. */ framePtr = _Tcl_GetCallFrame(interp, 0); info = contextPtr->classDefn->info; entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); if (entry != NULL) { contextObj = (ItclObject*)Tcl_GetHashValue(entry); Itcl_ReleaseData((ClientData)contextObj); Tcl_DeleteHashEntry(entry); } /* * Remove the call frame. */ Tcl_PopCallFrame(interp); /* * Free the compiledLocals array if malloc'ed storage was used. */ if (contextPtr->compiledLocals != &contextPtr->localStorage[0]) { ckfree((char*)contextPtr->compiledLocals); } } /* * ------------------------------------------------------------------------ * Itcl_GetContext() * * Convenience routine for looking up the current object/class context. * Useful in implementing methods/procs to see what class, and perhaps * what object, is active. * * Returns TCL_OK if the current namespace is a class namespace. * Also returns pointers to the class definition, and to object * data if an object context is active. Returns TCL_ERROR (along * with an error message in the interpreter) if a class namespace * is not active. * ------------------------------------------------------------------------ */ int Itcl_GetContext(interp, cdefnPtr, odefnPtr) Tcl_Interp *interp; /* current interpreter */ ItclClass **cdefnPtr; /* returns: class definition or NULL */ ItclObject **odefnPtr; /* returns: object data or NULL */ { Tcl_Namespace *activeNs = Tcl_GetCurrentNamespace(interp); ItclObjectInfo *info; Itcl_CallFrame *framePtr; Tcl_HashEntry *entry; /* * Return NULL for anything that cannot be found. */ *cdefnPtr = NULL; *odefnPtr = NULL; /* * If the active namespace is a class namespace, then return * all known info. See if the current call frame is a known * object context, and if so, return that context. */ if (Itcl_IsClassNamespace(activeNs)) { *cdefnPtr = (ItclClass*)activeNs->clientData; framePtr = _Tcl_GetCallFrame(interp, 0); info = (*cdefnPtr)->info; entry = Tcl_FindHashEntry(&info->contextFrames, (char*)framePtr); if (entry != NULL) { *odefnPtr = (ItclObject*)Tcl_GetHashValue(entry); } return TCL_OK; } /* * If there is no class/object context, return an error message. */ Tcl_AppendResult(interp, "namespace \"", activeNs->fullName, "\" is not a class namespace", (char*)NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itcl_AssignArgs() * * Matches a list of arguments against a Tcl argument specification. * Supports all of the rules regarding arguments for Tcl procs, including * default arguments and variable-length argument lists. * * Assumes that a local call frame is already installed. As variables * are successfully matched, they are stored as variables in the call * frame. Returns TCL_OK on success, or TCL_ERROR (along with an error * message in interp->result) on error. * ------------------------------------------------------------------------ */ int Itcl_AssignArgs(interp, objc, objv, mfunc) Tcl_Interp *interp; /* interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ ItclMemberFunc *mfunc; /* member function info (for error messages) */ { ItclMemberCode *mcode = mfunc->member->code; int result = TCL_OK; int defargc; CONST char **defargv = NULL; Tcl_Obj **defobjv = NULL; int configc = 0; ItclVarDefn **configVars = NULL; char **configVals = NULL; int vi, argsLeft; ItclClass *contextClass; ItclObject *contextObj; CompiledLocal *argPtr; ItclCallFrame *framePtr; Var *varPtr; Tcl_Obj *objPtr, *listPtr; char *value; framePtr = (ItclCallFrame *) _Tcl_GetCallFrame(interp, 0); framePtr->objc = objc; framePtr->objv = objv; /* ref counts for args are incremented below */ /* * See if there is a current object context. We may need * it later on. */ (void) Itcl_GetContext(interp, &contextClass, &contextObj); Tcl_ResetResult(interp); /* * Match the actual arguments against the procedure's formal * parameters to compute local variables. */ varPtr = framePtr->compiledLocals; for (argsLeft=mcode->argcount, argPtr=mcode->arglist, objv++, objc--; argsLeft > 0; argPtr=argPtr->nextPtr, argsLeft--, ItclNextLocal(varPtr), objv++, objc--) { if (!TclIsVarArgument(argPtr)) { Tcl_Panic("local variable %s is not argument but should be", argPtr->name); return TCL_ERROR; } if (TclIsVarTemporary(argPtr)) { Tcl_Panic("local variable is temporary but should be an argument"); return TCL_ERROR; } /* * Handle the special case of the last formal being "args". * When it occurs, assign it a list consisting of all the * remaining actual arguments. */ if ((argsLeft == 1) && (strcmp(argPtr->name, "args") == 0)) { if (objc < 0) objc = 0; listPtr = Tcl_NewListObj(objc, objv); ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); objc = 0; break; } /* * Handle the special case of the last formal being "config". * When it occurs, treat all remaining arguments as public * variable assignments. Set the local "config" variable * to the list of public variables assigned. */ else if ( (argsLeft == 1) && (strcmp(argPtr->name, "config") == 0) && contextObj ) { /* * If this is not an old-style method, discourage against * the use of the "config" argument. */ if ((mfunc->member->flags & ITCL_OLD_STYLE) == 0) { Tcl_AppendResult(interp, "\"config\" argument is an anachronism\n", "[incr Tcl] no longer supports the \"config\" argument.\n", "Instead, use the \"args\" argument and then use the\n", "built-in configure method to handle args like this:\n", " eval configure $args", (char*)NULL); result = TCL_ERROR; goto argErrors; } /* * Otherwise, handle the "config" argument in the usual way... * - parse all "-name value" assignments * - set "config" argument to the list of variable names */ if (objc > 0) { /* still have some arguments left? */ result = ItclParseConfig(interp, objc, objv, contextObj, &configc, &configVars, &configVals); if (result != TCL_OK) { goto argErrors; } listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); for (vi=0; vi < configc; vi++) { objPtr = Tcl_NewStringObj( configVars[vi]->member->classDefn->name, -1); Tcl_AppendToObj(objPtr, "::", -1); Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); } ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); objc = 0; /* all remaining args handled */ } else if (argPtr->defValuePtr) { value = Tcl_GetStringFromObj(argPtr->defValuePtr, (int*)NULL); result = Tcl_SplitList(interp, value, &defargc, &defargv); if (result != TCL_OK) { goto argErrors; } defobjv = (Tcl_Obj**)ckalloc( (unsigned)(defargc*sizeof(Tcl_Obj*)) ); for (vi=0; vi < defargc; vi++) { objPtr = Tcl_NewStringObj(defargv[vi], -1); Tcl_IncrRefCount(objPtr); defobjv[vi] = objPtr; } result = ItclParseConfig(interp, defargc, defobjv, contextObj, &configc, &configVars, &configVals); if (result != TCL_OK) { goto argErrors; } listPtr = Tcl_NewListObj(0, (Tcl_Obj**)NULL); for (vi=0; vi < configc; vi++) { objPtr = Tcl_NewStringObj( configVars[vi]->member->classDefn->name, -1); Tcl_AppendToObj(objPtr, "::", -1); Tcl_AppendToObj(objPtr, configVars[vi]->member->name, -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); } ItclVarObjValue(varPtr) = listPtr; Tcl_IncrRefCount(listPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); } else { objPtr = Tcl_NewStringObj("", 0); ItclVarObjValue(varPtr) = objPtr; Tcl_IncrRefCount(objPtr); /* local var is a reference */ ItclClearVarUndefined(varPtr); } } /* * Resume the usual processing of arguments... */ else if (objc > 0) { /* take next arg as value */ objPtr = *objv; ItclVarObjValue(varPtr) = objPtr; ItclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else if (argPtr->defValuePtr) { /* ...or use default value */ objPtr = argPtr->defValuePtr; ItclVarObjValue(varPtr) = objPtr; ItclClearVarUndefined(varPtr); Tcl_IncrRefCount(objPtr); /* local var is a reference */ } else { if (mfunc) { objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); Tcl_AppendToObj(objPtr, "\"", -1); } else { Tcl_AppendResult(interp, "no value given for parameter \"", argPtr->name, "\"", (char*)NULL); } result = TCL_ERROR; goto argErrors; } } if (objc > 0) { if (mfunc) { objPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1); Itcl_GetMemberFuncUsage(mfunc, contextObj, objPtr); Tcl_AppendToObj(objPtr, "\"", -1); } else { Tcl_AppendResult(interp, "too many arguments", (char*)NULL); } result = TCL_ERROR; goto argErrors; } /* * Handle any "config" assignments. */ if (configc > 0) { if (ItclHandleConfig(interp, configc, configVars, configVals, contextObj) != TCL_OK) { result = TCL_ERROR; goto argErrors; } } /* * All arguments were successfully matched. */ result = TCL_OK; /* * If any errors were found, clean up and return error status. */ argErrors: if (defobjv) { for (vi=0; vi < defargc; vi++) { Tcl_DecrRefCount(defobjv[vi]); } ckfree((char*)defobjv); } if (defargv) { ckfree((char*)defargv); } if (configVars) { ckfree((char*)configVars); } if (configVals) { ckfree((char*)configVals); } return result; } /* * ------------------------------------------------------------------------ * ItclReleaseMethod() * * Nulls the reference to the Tcl access command when it went away, * preventing us from leaving behind a dangling pointer for the resolver * to promote into bytecode, leading to double-free and heap corruption. * ------------------------------------------------------------------------ */ static void ItclReleaseMethod (ClientData cdata) { ItclMemberFunc *mfunc = (ItclMemberFunc*) cdata; mfunc->accessCmd = NULL; Itcl_ReleaseData (cdata); } /* * ------------------------------------------------------------------------ * ItclParseConfig() * * Parses a set of arguments as "-variable value" assignments. * Interprets all variable names in the most-specific class scope, * so that an inherited method with a "config" parameter will work * correctly. Returns a list of public variable names and their * corresponding values; both lists should passed to ItclHandleConfig() * to perform assignments, and freed when no longer in use. Returns a * status TCL_OK/TCL_ERROR and returns error messages in the interpreter. * ------------------------------------------------------------------------ */ static int ItclParseConfig(interp, objc, objv, contextObj, rargc, rvars, rvals) Tcl_Interp *interp; /* interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ ItclObject *contextObj; /* object whose public vars are being config'd */ int *rargc; /* return: number of variables accessed */ ItclVarDefn ***rvars; /* return: list of variables */ char ***rvals; /* return: list of values */ { int result = TCL_OK; ItclVarLookup *vlookup; Tcl_HashEntry *entry; char *varName, *value; if (objc < 0) objc = 0; *rargc = 0; *rvars = (ItclVarDefn**)ckalloc((unsigned)(objc*sizeof(ItclVarDefn*))); *rvals = (char**)ckalloc((unsigned)(objc*sizeof(char*))); while (objc-- > 0) { /* * Next argument should be "-variable" */ varName = Tcl_GetStringFromObj(*objv, (int*)NULL); if (*varName != '-') { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": should be \"-variable value\"", (char*)NULL); result = TCL_ERROR; break; } else if (objc-- <= 0) { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": should be \"-variable value\" (missing value)", (char*)NULL); result = TCL_ERROR; break; } entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, varName+1); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); value = Tcl_GetStringFromObj(*(objv+1), (int*)NULL); (*rvars)[*rargc] = vlookup->vdefn; /* variable definition */ (*rvals)[*rargc] = value; /* config value */ (*rargc)++; objv += 2; } else { Tcl_AppendResult(interp, "syntax error in config assignment \"", varName, "\": unrecognized variable", (char*)NULL); result = TCL_ERROR; break; } } return result; } /* * ------------------------------------------------------------------------ * ItclHandleConfig() * * Handles the assignment of "config" values to public variables. * The list of assignments is parsed in ItclParseConfig(), but the * actual assignments are performed here. If the variables have any * associated "config" code, it is invoked here as well. If errors * are detected during assignment or "config" code execution, the * variable is set back to its previous value and an error is returned. * * Returns a status TCL_OK/TCL_ERROR, and returns any error messages * in the given interpreter. * ------------------------------------------------------------------------ */ static int ItclHandleConfig(interp, argc, vars, vals, contextObj) Tcl_Interp *interp; /* interpreter currently in control */ int argc; /* number of assignments */ ItclVarDefn **vars; /* list of public variable definitions */ char **vals; /* list of public variable values */ ItclObject *contextObj; /* object whose public vars are being config'd */ { int result = TCL_OK; int i; CONST char *val; Tcl_DString lastval; ItclContext context; Itcl_CallFrame *oldFramePtr, *uplevelFramePtr; Tcl_DStringInit(&lastval); /* * All "config" assignments are performed in the most-specific * class scope, so that inherited methods with "config" arguments * will work correctly. */ result = Itcl_PushContext(interp, (ItclMember*)NULL, contextObj->classDefn, contextObj, &context); if (result != TCL_OK) { return TCL_ERROR; } /* * Perform each assignment and execute the "config" code * associated with each variable. If any errors are encountered, * set the variable back to its previous value, and return an error. */ for (i=0; i < argc; i++) { val = Tcl_GetVar2(interp, vars[i]->member->fullname, (char*)NULL, 0); if (!val) { val = ""; } Tcl_DStringSetLength(&lastval, 0); Tcl_DStringAppend(&lastval, val, -1); /* * Set the variable to the specified value. */ if (!Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, vals[i], 0)) { char msg[256]; sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); Tcl_AddErrorInfo(interp, msg); result = TCL_ERROR; break; } /* * If the variable has a "config" condition, then execute it. * If it fails, put the variable back the way it was and return * an error. * * TRICKY NOTE: Be careful to evaluate the code one level * up in the call stack, so that it's executed in the * calling context, and not in the context that we've * set up for public variable access. */ if (vars[i]->member->code) { uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr); result = Itcl_EvalMemberCode(interp, (ItclMemberFunc*)NULL, vars[i]->member, contextObj, 0, (Tcl_Obj* CONST*)NULL); (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); if (result != TCL_OK) { char msg[256]; sprintf(msg, "\n (while configuring public variable \"%.100s\")", vars[i]->member->fullname); Tcl_AddErrorInfo(interp, msg); Tcl_SetVar2(interp, vars[i]->member->fullname, (char*)NULL, Tcl_DStringValue(&lastval), 0); break; } } } /* * Clean up and return. */ Itcl_PopContext(interp, &context); Tcl_DStringFree(&lastval); return result; } /* * ------------------------------------------------------------------------ * Itcl_ConstructBase() * * Usually invoked just before executing the body of a constructor * when an object is first created. This procedure makes sure that * all base classes are properly constructed. If an "initCode" fragment * was defined with the constructor for the class, then it is invoked. * After that, the list of base classes is checked for constructors * that are defined but have not yet been invoked. Each of these is * invoked implicitly with no arguments. * * Assumes that a local call frame is already installed, and that * constructor arguments have already been matched and are sitting in * this frame. Returns TCL_OK on success; otherwise, this procedure * returns TCL_ERROR, along with an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_ConstructBase(interp, contextObj, contextClass) Tcl_Interp *interp; /* interpreter */ ItclObject *contextObj; /* object being constructed */ ItclClass *contextClass; /* current class being constructed */ { int result; Itcl_ListElem *elem; ItclClass *cdefn; Tcl_HashEntry *entry; /* * If the class has an "initCode", invoke it in the current context. * * TRICKY NOTE: * This context is the call frame containing the arguments * for the constructor. The "initCode" makes sense right * now--just before the body of the constructor is executed. */ if (contextClass->initCode) { if (Tcl_EvalObj(interp, contextClass->initCode) != TCL_OK) { return TCL_ERROR; } } /* * Scan through the list of base classes and see if any of these * have not been constructed. Invoke base class constructors * implicitly, as needed. Go through the list of base classes * in reverse order, so that least-specific classes are constructed * first. */ elem = Itcl_LastListElem(&contextClass->bases); while (elem) { cdefn = (ItclClass*)Itcl_GetListValue(elem); if (!Tcl_FindHashEntry(contextObj->constructed, cdefn->name)) { result = Itcl_InvokeMethodIfExists(interp, "constructor", cdefn, contextObj, 0, (Tcl_Obj* CONST*)NULL); if (result != TCL_OK) { return TCL_ERROR; } /* * The base class may not have a constructor, but its * own base classes could have one. If the constructor * wasn't found in the last step, then other base classes * weren't constructed either. Make sure that all of its * base classes are properly constructed. */ entry = Tcl_FindHashEntry(&cdefn->functions, "constructor"); if (entry == NULL) { result = Itcl_ConstructBase(interp, contextObj, cdefn); if (result != TCL_OK) { return TCL_ERROR; } } } elem = Itcl_PrevListElem(elem); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_InvokeMethodIfExists() * * Looks for a particular method in the specified class. If the * method is found, it is invoked with the given arguments. Any * protection level (protected/private) for the method is ignored. * If the method does not exist, this procedure does nothing. * * This procedure is used primarily to invoke the constructor/destructor * when an object is created/destroyed. * * Returns TCL_OK on success; otherwise, this procedure returns * TCL_ERROR along with an error message in the interpreter. * ------------------------------------------------------------------------ */ int Itcl_InvokeMethodIfExists(interp, name, contextClass, contextObj, objc, objv) Tcl_Interp *interp; /* interpreter */ CONST char *name; /* name of desired method */ ItclClass *contextClass; /* current class being constructed */ ItclObject *contextObj; /* object being constructed */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int result = TCL_OK; ItclMemberFunc *mfunc; ItclMember *member; Tcl_HashEntry *entry; Tcl_Obj *cmdlinePtr; int cmdlinec; Tcl_Obj **cmdlinev; /* * Scan through the list of base classes and see if any of these * have not been constructed. Invoke base class constructors * implicitly, as needed. Go through the list of base classes * in reverse order, so that least-specific classes are constructed * first. */ entry = Tcl_FindHashEntry(&contextClass->functions, name); if (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); member = mfunc->member; /* * Prepend the method name to the list of arguments. */ cmdlinePtr = Itcl_CreateArgs(interp, name, objc, objv); (void) Tcl_ListObjGetElements((Tcl_Interp*)NULL, cmdlinePtr, &cmdlinec, &cmdlinev); /* * Execute the code for the method. Be careful to protect * the method in case it gets deleted during execution. */ Itcl_PreserveData((ClientData)mfunc); result = Itcl_EvalMemberCode(interp, mfunc, member, contextObj, cmdlinec, cmdlinev); result = Itcl_ReportFuncErrors(interp, mfunc, contextObj, result); Itcl_ReleaseData((ClientData)mfunc); Tcl_DecrRefCount(cmdlinePtr); } return result; } /* * ------------------------------------------------------------------------ * Itcl_ReportFuncErrors() * * Used to interpret the status code returned when the body of a * Tcl-style proc is executed. Handles the "errorInfo" and "errorCode" * variables properly, and adds error information into the interpreter * if anything went wrong. Returns a new status code that should be * treated as the return status code for the command. * * This same operation is usually buried in the Tcl InterpProc() * procedure. It is defined here so that it can be reused more easily. * ------------------------------------------------------------------------ */ int Itcl_ReportFuncErrors(interp, mfunc, contextObj, result) Tcl_Interp* interp; /* interpreter being modified */ ItclMemberFunc *mfunc; /* command member that was invoked */ ItclObject *contextObj; /* object context for this command */ int result; /* integer status code from proc body */ { Interp* iPtr = (Interp*)interp; Tcl_Obj *objPtr; char num[20]; if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { objPtr = Tcl_NewStringObj("\n ", -1); Tcl_IncrRefCount(objPtr); if (mfunc->member->flags & ITCL_CONSTRUCTOR) { Tcl_AppendToObj(objPtr, "while constructing object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" in ", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, " (", -1); } } else if (mfunc->member->flags & ITCL_DESTRUCTOR) { Tcl_AppendToObj(objPtr, "while deleting object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" in ", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, " (", -1); } } else { Tcl_AppendToObj(objPtr, "(", -1); if (contextObj && contextObj->accessCmd) { Tcl_AppendToObj(objPtr, "object \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\" ", -1); } if ((mfunc->member->flags & ITCL_COMMON) != 0) { Tcl_AppendToObj(objPtr, "procedure", -1); } else { Tcl_AppendToObj(objPtr, "method", -1); } Tcl_AppendToObj(objPtr, " \"", -1); Tcl_AppendToObj(objPtr, mfunc->member->fullname, -1); Tcl_AppendToObj(objPtr, "\" ", -1); } if ((mfunc->member->code->flags & ITCL_IMPLEMENT_TCL) != 0) { Tcl_AppendToObj(objPtr, "body line ", -1); sprintf(num, "%d", Tcl_GetErrorLine((Tcl_Interp *)iPtr)); Tcl_AppendToObj(objPtr, num, -1); Tcl_AppendToObj(objPtr, ")", -1); } else { Tcl_AppendToObj(objPtr, ")", -1); } Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); Tcl_DecrRefCount(objPtr); } else if (result == TCL_BREAK) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"break\" outside of a loop", -1); result = TCL_ERROR; } else if (result == TCL_CONTINUE) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "invoked \"continue\" outside of a loop", -1); result = TCL_ERROR; } } return result; } itcl3.4.3/generic/itclInt.h0000644003604700454610000003770612536627705014217 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. * * ADDING [incr Tcl] TO A Tcl-BASED APPLICATION: * * To add [incr Tcl] facilities to a Tcl application, modify the * Tcl_AppInit() routine as follows: * * 1) Include this header file near the top of the file containing * Tcl_AppInit(): * * #include "itcl.h" * * 2) Within the body of Tcl_AppInit(), add the following lines: * * if (Itcl_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * 3) Link your application with libitcl.a * * NOTE: An example file "tclAppInit.c" containing the changes shown * above is included in this distribution. * * ======================================================================== * 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. */ #ifndef ITCLINT_H #define ITCLINT_H #include "tclInt.h" #include "itcl.h" #ifdef BUILD_itcl # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT #endif /* * Handle hiding of errorLine in 8.6 */ #if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6) #define Tcl_GetErrorLine(interp) ((interp)->errorLine) #endif #define ITCL_TCL_PRE_8_5 (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5) #define ItclCallFrame CallFrame #if !ITCL_TCL_PRE_8_5 #define Itcl_CallFrame Tcl_CallFrame #if defined(USE_TCL_STUBS) /* * Fix Tcl bug #803489 the right way. We need to always use the old Stub * slot positions, not the new broken ones part of TIP 127. I do like * that these functions have moved to the public space (about time), but * the slot change is the killer and is the painful side affect. */ # undef Tcl_CreateNamespace # define Tcl_CreateNamespace \ (tclIntStubsPtr->tcl_CreateNamespace) # undef Tcl_DeleteNamespace # define Tcl_DeleteNamespace \ (tclIntStubsPtr->tcl_DeleteNamespace) # undef Tcl_AppendExportList # define Tcl_AppendExportList \ (tclIntStubsPtr->tcl_AppendExportList) # undef Tcl_Export # define Tcl_Export \ (tclIntStubsPtr->tcl_Export) # undef Tcl_Import # define Tcl_Import \ (tclIntStubsPtr->tcl_Import) # undef Tcl_ForgetImport # define Tcl_ForgetImport \ (tclIntStubsPtr->tcl_ForgetImport) # undef Tcl_GetCurrentNamespace # define Tcl_GetCurrentNamespace \ (tclIntStubsPtr->tcl_GetCurrentNamespace) # undef Tcl_GetGlobalNamespace # define Tcl_GetGlobalNamespace \ (tclIntStubsPtr->tcl_GetGlobalNamespace) # undef Tcl_FindNamespace # define Tcl_FindNamespace \ (tclIntStubsPtr->tcl_FindNamespace) # undef Tcl_FindCommand # define Tcl_FindCommand \ (tclIntStubsPtr->tcl_FindCommand) # undef Tcl_GetCommandFromObj # define Tcl_GetCommandFromObj \ (tclIntStubsPtr->tcl_GetCommandFromObj) # undef Tcl_GetCommandFullName # define Tcl_GetCommandFullName \ (tclIntStubsPtr->tcl_GetCommandFullName) #endif /* use stubs */ #define ItclInitVarFlags(varPtr) \ (varPtr)->flags = 0 #define ItclInitVarArgument(varPtr) \ (varPtr)->flags = VAR_ARGUMENT #define ItclVarHashCreateVar(tablePtr, key, newPtr) \ TclVarHashCreateVar((tablePtr), (key), (newPtr)) #define ItclVarRefCount(varPtr) VarHashRefCount(varPtr) #define ItclClearVarUndefined(varPtr) #define ItclNextLocal(varPtr) ((varPtr)++) #define ItclVarObjValue(varPtr) ((varPtr)->value.objPtr) #define itclVarInHashSize sizeof(VarInHash) #define itclVarLocalSize sizeof(Var) #else /* Compiling on Tcl8.x, x<5 */ typedef struct Itcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; int dummy2; void *dummy3; void *dummy4; void *dummy5; int dummy6; void *dummy7; void *dummy8; int dummy9; void *dummy10; void *dummy11; void *dummy12; void *dummy13; } Itcl_CallFrame; /* * Definition of runtime behaviour to be able to run irrespective of the Tcl * version. */ #define VarInHash Var #define TclVarHashTable Tcl_HashTable typedef struct ItclShortVar { int flags; union { Tcl_Obj *objPtr; TclVarHashTable *tablePtr; struct Var *linkPtr; } value; } ItclShortVar; typedef struct ItclVarInHash { ItclShortVar var; int refCount; Tcl_HashEntry entry; } ItclVarInHash; #define ItclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) #define itclOldRuntime (itclVarFlagOffset!=0) extern int itclVarFlagOffset; extern int itclVarRefCountOffset; extern int itclVarInHashSize; extern int itclVarLocalSize; extern int itclVarValueOffset; /* * VarReform related macros: provide access to the Var fields with offsets * determined at load time, so that the same code copes with the different * structs in Tcl8.5 and previous Tcl. */ #define ItclNextLocal(varPtr) \ ((varPtr) = (Var *) (((char *)(varPtr))+itclVarLocalSize)) #define ItclVarObjValue(varPtr) \ (*((Tcl_Obj **) (((char *)(varPtr))+itclVarValueOffset))) #define ItclVarRefCount(varPtr) \ (*((int *) (((char *)(varPtr))+itclVarRefCountOffset))) #define ItclVarFlags(varPtr) \ (*((int *)(((char *)(varPtr))+itclVarFlagOffset))) /* Note that itclVarFlagOffset==0 exactly when we are running in Tcl8.5 */ #define ItclInitVarFlags(varPtr) \ if (itclOldRuntime) { \ (varPtr)->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE);\ } else { \ ((ItclShortVar *)(varPtr))->flags = 0;\ } /* This is used for CompiledLocal, not for Var & Co. That struct did not * change, but the correct flag init did! The flags bits themselves are * unchanged */ #define ItclInitVarArgument(varPtr) \ if (itclOldRuntime) { \ (varPtr)->flags = (VAR_SCALAR | VAR_ARGUMENT);\ } else { \ (varPtr)->flags = VAR_ARGUMENT;\ } #define TclIsVarNamespaceVar(varPtr) \ (ItclVarFlags(varPtr) & VAR_NAMESPACE_VAR) #define TclSetVarNamespaceVar(varPtr) \ if (!TclIsVarNamespaceVar(varPtr)) {\ ItclVarFlags(varPtr) |= VAR_NAMESPACE_VAR;\ ItclVarRefCount(varPtr)++;\ } #define ItclClearVarUndefined(varPtr) \ if (itclOldRuntime) { \ ItclVarFlags(varPtr) &= ~VAR_UNDEFINED;\ } #ifndef MODULE_SCOPE #define MODULE_SCOPE #endif MODULE_SCOPE Var * ItclVarHashCreateVar (TclVarHashTable * tablePtr, const char * key, int * newPtr); #endif /* Version dependent defs and macros */ #define ItclVarHashFindVar(tablePtr, key) \ ItclVarHashCreateVar((tablePtr), (key), NULL) /* * Common info for managing all known objects. * Each interpreter has one of these data structures stored as * clientData in the "itcl" namespace. It is also accessible * as associated data via the key ITCL_INTERP_DATA. */ struct ItclObject; typedef struct ItclObjectInfo { Tcl_Interp *interp; /* interpreter that manages this info */ Tcl_HashTable objects; /* list of all known objects */ Itcl_Stack transparentFrames; /* stack of call frames that should be * treated transparently. When * Itcl_EvalMemberCode is invoked in * one of these contexts, it does an * "uplevel" to get past the transparent * frame and back to the calling context. */ Tcl_HashTable contextFrames; /* object contexts for active call frames */ int protection; /* protection level currently in effect */ Itcl_Stack cdefnStack; /* stack of class definitions currently * being parsed */ } ItclObjectInfo; #define ITCL_INTERP_DATA "itcl_data" /* * Representation for each [incr Tcl] class. */ typedef struct ItclClass { char *name; /* class name */ char *fullname; /* fully qualified class name */ Tcl_Interp *interp; /* interpreter that manages this info */ Tcl_Namespace *namesp; /* namespace representing class scope */ Tcl_Command accessCmd; /* access command for creating instances */ struct ItclObjectInfo *info; /* info about all known objects */ Itcl_List bases; /* list of base classes */ Itcl_List derived; /* list of all derived classes */ Tcl_HashTable heritage; /* table of all base classes. Look up * by pointer to class definition. This * provides fast lookup for inheritance * tests. */ Tcl_Obj *initCode; /* initialization code for new objs */ Tcl_HashTable variables; /* definitions for all data members in this class. Look up simple string names and get back ItclVarDefn* ptrs */ Tcl_HashTable functions; /* definitions for all member functions in this class. Look up simple string names and get back ItclMemberFunc* ptrs */ int numInstanceVars; /* number of instance vars in variables table */ Tcl_HashTable resolveVars; /* all possible names for variables in * this class (e.g., x, foo::x, etc.) */ Tcl_HashTable resolveCmds; /* all possible names for functions in * this class (e.g., x, foo::x, etc.) */ int unique; /* unique number for #auto generation */ int flags; /* maintains class status */ } ItclClass; typedef struct ItclHierIter { ItclClass *current; /* current position in hierarchy */ Itcl_Stack stack; /* stack used for traversal */ } ItclHierIter; /* * Representation for each [incr Tcl] object. */ typedef struct ItclObject { ItclClass *classDefn; /* most-specific class */ Tcl_Command accessCmd; /* object access command */ int dataSize; /* number of elements in data array */ Var** data; /* all object-specific data members */ Tcl_HashTable* constructed; /* temp storage used during construction */ Tcl_HashTable* destructed; /* temp storage used during destruction */ } ItclObject; #define ITCL_IGNORE_ERRS 0x002 /* useful for construction/destruction */ /* * Implementation for any code body in an [incr Tcl] class. */ typedef struct ItclMemberCode { int flags; /* flags describing implementation */ CompiledLocal *arglist; /* list of arg names and initial values */ int argcount; /* number of args in arglist */ Proc *procPtr; /* Tcl proc representation (needed to * handle compiled locals) */ union { Tcl_CmdProc *argCmd; /* (argc,argv) C implementation */ Tcl_ObjCmdProc *objCmd; /* (objc,objv) C implementation */ } cfunc; ClientData clientData; /* client data for C implementations */ } ItclMemberCode; #define Itcl_IsMemberCodeImplemented(mcode) \ (((mcode)->flags & ITCL_IMPLEMENT_NONE) == 0) /* * Basic representation for class members (commands/variables) */ typedef struct ItclMember { Tcl_Interp* interp; /* interpreter containing the class */ ItclClass* classDefn; /* class containing this member */ char* name; /* member name */ char* fullname; /* member name with "class::" qualifier */ int protection; /* protection level */ int flags; /* flags describing member (see below) */ ItclMemberCode *code; /* code associated with member */ } ItclMember; /* * Flag bits for ItclMemberCode and ItclMember: */ #define ITCL_IMPLEMENT_NONE 0x001 /* no implementation */ #define ITCL_IMPLEMENT_TCL 0x002 /* Tcl implementation */ #define ITCL_IMPLEMENT_ARGCMD 0x004 /* (argc,argv) C implementation */ #define ITCL_IMPLEMENT_OBJCMD 0x008 /* (objc,objv) C implementation */ #define ITCL_IMPLEMENT_C 0x00c /* either kind of C implementation */ #define ITCL_CONSTRUCTOR 0x010 /* non-zero => is a constructor */ #define ITCL_DESTRUCTOR 0x020 /* non-zero => is a destructor */ #define ITCL_COMMON 0x040 /* non-zero => is a "proc" */ #define ITCL_ARG_SPEC 0x080 /* non-zero => has an argument spec */ #define ITCL_OLD_STYLE 0x100 /* non-zero => old-style method * (process "config" argument) */ #define ITCL_THIS_VAR 0x200 /* non-zero => built-in "this" variable */ /* * Representation of member functions in an [incr Tcl] class. */ typedef struct ItclMemberFunc { ItclMember *member; /* basic member info */ Tcl_Command accessCmd; /* Tcl command installed for this function */ CompiledLocal *arglist; /* list of arg names and initial values */ int argcount; /* number of args in arglist */ } ItclMemberFunc; /* * Instance variables. */ typedef struct ItclVarDefn { ItclMember *member; /* basic member info */ char* init; /* initial value */ } ItclVarDefn; /* * Instance variable lookup entry. */ typedef struct ItclVarLookup { ItclVarDefn* vdefn; /* variable definition */ int usage; /* number of uses for this record */ int accessible; /* non-zero => accessible from class with * this lookup record in its resolveVars */ char *leastQualName; /* simplist name for this variable, with * the fewest qualifiers. This string is * taken from the resolveVars table, so * it shouldn't be freed. */ union { int index; /* index into virtual table (instance data) */ Tcl_Var common; /* variable (common data) */ } var; } ItclVarLookup; /* * Representation for the context in which a body of [incr Tcl] * code executes. In ordinary Tcl, this is a CallFrame. But for * [incr Tcl] code bodies, we must be careful to set up the * CallFrame properly, to plug in instance variables before * executing the code body. */ typedef struct ItclContext { ItclClass *classDefn; /* class definition */ Itcl_CallFrame frame; /* call frame for object context */ Var *compiledLocals; /* points to storage for compiled locals */ Var localStorage[20]; /* default storage for compiled locals */ } ItclContext; /* * Compatibility flags. Used to support small "hacks". These are stored * in the global variable named itclCompatFlags. */ extern int itclCompatFlags; #define ITCL_COMPAT_USE_ISTATE_API 0x2 /* Tcl 8.5a2 added interp state APIs */ #include "itclIntDecls.h" /* * Since the Tcl/Tk distribution doesn't perform any asserts, * dynamic loading can fail to find the __assert function. * As a workaround, we'll include our own. */ #undef assert #ifndef DEBUG #define assert(EX) ((void)0) #else #define assert(EX) (void)((EX) || (Itcl_Assert(STRINGIFY(EX), __FILE__, __LINE__), 0)) #endif /* DEBUG */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* ITCLINT_H */ itcl3.4.3/generic/itcl.decls0000644003604700454610000000622612536627705014400 0ustar dgp771div# itcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Itcl library via the stubs table. # This file is used to generate the itclDecls.h, itclPlatDecls.h, # itclStub.c, and itclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. library itcl # Define the itcl interface with several sub interfaces: # itclPlat - platform specific public # itclInt - generic private # itclPlatInt - platform specific private interface itcl hooks {itclInt} # Declare each of the functions in the public Tcl interface. Note that # the an index should never be reused for a different function in order # to preserve backwards compatibility. declare 0 generic { int Itcl_Init(Tcl_Interp *interp) } declare 1 generic { int Itcl_SafeInit(Tcl_Interp *interp) } declare 2 generic { int Itcl_RegisterC(Tcl_Interp *interp, CONST char *name, \ Tcl_CmdProc *proc, ClientData clientData, \ Tcl_CmdDeleteProc *deleteProc) } declare 3 generic { int Itcl_RegisterObjC (Tcl_Interp *interp, CONST char *name, \ Tcl_ObjCmdProc *proc, ClientData clientData, \ Tcl_CmdDeleteProc *deleteProc) } declare 4 generic { int Itcl_FindC(Tcl_Interp *interp, CONST char *name, \ Tcl_CmdProc **argProcPtr, Tcl_ObjCmdProc **objProcPtr, \ ClientData *cDataPtr) } declare 5 generic { void Itcl_InitStack(Itcl_Stack *stack) } declare 6 generic { void Itcl_DeleteStack(Itcl_Stack *stack) } declare 7 generic { void Itcl_PushStack(ClientData cdata, Itcl_Stack *stack) } declare 8 generic { ClientData Itcl_PopStack(Itcl_Stack *stack) } declare 9 generic { ClientData Itcl_PeekStack(Itcl_Stack *stack) } declare 10 generic { ClientData Itcl_GetStackValue(Itcl_Stack *stack, int pos) } declare 11 generic { void Itcl_InitList(Itcl_List *listPtr) } declare 12 generic { void Itcl_DeleteList(Itcl_List *listPtr) } declare 13 generic { Itcl_ListElem* Itcl_CreateListElem(Itcl_List *listPtr) } declare 14 generic { Itcl_ListElem* Itcl_DeleteListElem(Itcl_ListElem *elemPtr) } declare 15 generic { Itcl_ListElem* Itcl_InsertList(Itcl_List *listPtr, ClientData val) } declare 16 generic { Itcl_ListElem* Itcl_InsertListElem (Itcl_ListElem *pos, ClientData val) } declare 17 generic { Itcl_ListElem* Itcl_AppendList(Itcl_List *listPtr, ClientData val) } declare 18 generic { Itcl_ListElem* Itcl_AppendListElem(Itcl_ListElem *pos, ClientData val) } declare 19 generic { void Itcl_SetListValue(Itcl_ListElem *elemPtr, ClientData val) } declare 20 generic { void Itcl_EventuallyFree(ClientData cdata, Tcl_FreeProc *fproc) } declare 21 generic { void Itcl_PreserveData(ClientData cdata) } declare 22 generic { void Itcl_ReleaseData(ClientData cdata) } declare 23 generic { Itcl_InterpState Itcl_SaveInterpState(Tcl_Interp* interp, int status) } declare 24 generic { int Itcl_RestoreInterpState(Tcl_Interp* interp, Itcl_InterpState state) } declare 25 generic { void Itcl_DiscardInterpState(Itcl_InterpState state) } itcl3.4.3/generic/itcl_class.c0000644003604700454610000016567512632344507014724 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 class definitions. Classes are composed of * data members (public/protected/common) and the member functions * (methods/procs) that operate on them. Each class has its own * namespace which manages the class scope. * * ======================================================================== * 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; /* * FORWARD DECLARATIONS */ static void ItclDestroyClass _ANSI_ARGS_((ClientData cdata)); static void ItclDestroyClassNamesp _ANSI_ARGS_((ClientData cdata)); static void ItclFreeClass _ANSI_ARGS_((char* cdata)); static Tcl_Var ItclClassRuntimeVarResolver _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr)); extern int itclCompatFlags; /* * ------------------------------------------------------------------------ * Itcl_CreateClass() * * Creates a namespace and its associated class definition data. * If a namespace already exists with that name, then this routine * returns TCL_ERROR, along with an error message in the interp. * If successful, it returns TCL_OK and a pointer to the new class * definition. * ------------------------------------------------------------------------ */ int Itcl_CreateClass(interp, path, info, rPtr) Tcl_Interp* interp; /* interpreter that will contain new class */ CONST char* path; /* name of new class */ ItclObjectInfo *info; /* info for all known objects */ ItclClass **rPtr; /* returns: pointer to class definition */ { char *head, *tail; Tcl_DString buffer; Tcl_Command cmd; Tcl_Namespace *classNs; ItclClass *cdPtr; ItclVarDefn *vdefn; Tcl_HashEntry *entry; int newEntry; /* * Make sure that a class with the given name does not * already exist in the current namespace context. If a * namespace exists, that's okay. It may have been created * to contain stubs during a "namespace import" operation. * We'll just replace the namespace data below with the * proper class data. */ classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL, /* flags */ 0); if (classNs != NULL && Itcl_IsClassNamespace(classNs)) { Tcl_AppendResult(interp, "class \"", path, "\" already exists", (char*)NULL); return TCL_ERROR; } /* * Make sure that a command with the given class name does not * already exist in the current namespace. This prevents the * usual Tcl commands from being clobbered when a programmer * makes a bogus call like "class info". */ cmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL, /* flags */ TCL_NAMESPACE_ONLY); if (cmd != NULL && !Itcl_IsStub(cmd)) { Tcl_AppendResult(interp, "command \"", path, "\" already exists", (char*)NULL); if (strstr(path,"::") == NULL) { Tcl_AppendResult(interp, " in namespace \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", (char*)NULL); } return TCL_ERROR; } /* * Make sure that the class name does not have any goofy * characters: * * . => reserved for member access like: class.publicVar */ Itcl_ParseNamespPath(path, &buffer, &head, &tail); if (strstr(tail,".")) { Tcl_AppendResult(interp, "bad class name \"", tail, "\"", (char*)NULL); Tcl_DStringFree(&buffer); return TCL_ERROR; } Tcl_DStringFree(&buffer); /* * Allocate class definition data. */ cdPtr = (ItclClass*)ckalloc(sizeof(ItclClass)); cdPtr->name = NULL; cdPtr->fullname = NULL; cdPtr->interp = interp; cdPtr->info = info; Itcl_PreserveData((ClientData)info); cdPtr->namesp = NULL; cdPtr->accessCmd = NULL; Tcl_InitHashTable(&cdPtr->variables, TCL_STRING_KEYS); Tcl_InitHashTable(&cdPtr->functions, TCL_STRING_KEYS); cdPtr->numInstanceVars = 0; Tcl_InitHashTable(&cdPtr->resolveVars, TCL_STRING_KEYS); Tcl_InitHashTable(&cdPtr->resolveCmds, TCL_STRING_KEYS); Itcl_InitList(&cdPtr->bases); Itcl_InitList(&cdPtr->derived); cdPtr->initCode = NULL; cdPtr->unique = 0; cdPtr->flags = 0; /* * Initialize the heritage info--each class starts with its * own class definition in the heritage. Base classes are * added to the heritage from the "inherit" statement. */ Tcl_InitHashTable(&cdPtr->heritage, TCL_ONE_WORD_KEYS); (void) Tcl_CreateHashEntry(&cdPtr->heritage, (char*)cdPtr, &newEntry); /* * Create a namespace to represent the class. Add the class * definition info as client data for the namespace. If the * namespace already exists, then replace any existing client * data with the class data. */ Itcl_PreserveData((ClientData)cdPtr); if (classNs == NULL) { classNs = Tcl_CreateNamespace(interp, path, (ClientData)cdPtr, ItclDestroyClassNamesp); } else { if (classNs->clientData && classNs->deleteProc) { (*classNs->deleteProc)(classNs->clientData); } classNs->clientData = (ClientData)cdPtr; classNs->deleteProc = ItclDestroyClassNamesp; } Itcl_EventuallyFree((ClientData)cdPtr, ItclFreeClass); if (classNs == NULL) { Itcl_ReleaseData((ClientData)cdPtr); return TCL_ERROR; } cdPtr->namesp = classNs; cdPtr->name = (char*)ckalloc((unsigned)(strlen(classNs->name)+1)); strcpy(cdPtr->name, classNs->name); cdPtr->fullname = (char*)ckalloc((unsigned)(strlen(classNs->fullName)+1)); strcpy(cdPtr->fullname, classNs->fullName); /* * Add special name resolution procedures to the class namespace * so that members are accessed according to the rules for * [incr Tcl]. */ Tcl_SetNamespaceResolvers(classNs, (Tcl_ResolveCmdProc*)Itcl_ClassCmdResolver, (Tcl_ResolveVarProc*)Itcl_ClassVarResolver, (Tcl_ResolveCompiledVarProc*)Itcl_ClassCompiledVarResolver); /* * Add the built-in "this" variable to the list of data members. */ (void) Itcl_CreateVarDefn(interp, cdPtr, "this", (char*)NULL, (char*)NULL, &vdefn); vdefn->member->protection = ITCL_PROTECTED; /* always "protected" */ vdefn->member->flags |= ITCL_THIS_VAR; /* mark as "this" variable */ entry = Tcl_CreateHashEntry(&cdPtr->variables, "this", &newEntry); Tcl_SetHashValue(entry, (ClientData)vdefn); /* * Create a command in the current namespace to manage the class: * * ?? */ Itcl_PreserveData((ClientData)cdPtr); cdPtr->accessCmd = Tcl_CreateObjCommand(interp, cdPtr->fullname, Itcl_HandleClass, (ClientData)cdPtr, ItclDestroyClass); *rPtr = cdPtr; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteClass() * * Deletes a class by deleting all derived classes and all objects in * that class, and finally, by destroying the class namespace. This * procedure provides a friendly way of doing this. If any errors * are detected along the way, the process is aborted. * * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_DeleteClass(interp, cdefnPtr) Tcl_Interp *interp; /* interpreter managing this class */ ItclClass *cdefnPtr; /* class namespace */ { ItclClass *cdPtr = NULL; Itcl_ListElem *elem; ItclObject *contextObj; Tcl_HashEntry *entry; Tcl_HashSearch place; Tcl_DString buffer; /* * Destroy all derived classes, since these lose their meaning * when the base class goes away. If anything goes wrong, * abort with an error. * * TRICKY NOTE: When a derived class is destroyed, it * automatically deletes itself from the "derived" list. */ elem = Itcl_FirstListElem(&cdefnPtr->derived); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); elem = Itcl_NextListElem(elem); /* advance here--elem will go away */ if (Itcl_DeleteClass(interp, cdPtr) != TCL_OK) { goto deleteClassFail; } } /* * Scan through and find all objects that belong to this class. * Note that more specialized objects have already been * destroyed above, when derived classes were destroyed. * Destroy objects and report any errors. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); while (entry) { contextObj = (ItclObject*)Tcl_GetHashValue(entry); if (contextObj->classDefn == cdefnPtr) { if (Itcl_DeleteObject(interp, contextObj) != TCL_OK) { cdPtr = cdefnPtr; goto deleteClassFail; } /* * 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. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); continue; } entry = Tcl_NextHashEntry(&place); } /* * Destroy the namespace associated with this class. * * TRICKY NOTE: * The cleanup procedure associated with the namespace is * invoked automatically. It does all of the same things * above, but it also disconnects this class from its * base-class lists, and removes the class access command. */ Tcl_DeleteNamespace(cdefnPtr->namesp); return TCL_OK; deleteClassFail: Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "\n (while deleting class \"", -1); Tcl_DStringAppend(&buffer, cdPtr->namesp->fullName, -1); Tcl_DStringAppend(&buffer, "\")", -1); Tcl_AddErrorInfo(interp, Tcl_DStringValue(&buffer)); Tcl_DStringFree(&buffer); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * ItclDestroyClass() * * Invoked whenever the access command for a class is destroyed. * Destroys the namespace associated with the class, which also * destroys all objects in the class and all derived classes. * Disconnects this class from the "derived" class lists of its * base classes, and releases any claim to the class definition * data. If this is the last use of that data, the class will * completely vanish at this point. * ------------------------------------------------------------------------ */ static void ItclDestroyClass(cdata) ClientData cdata; /* class definition to be destroyed */ { ItclClass *cdefnPtr = (ItclClass*)cdata; cdefnPtr->accessCmd = NULL; Tcl_DeleteNamespace(cdefnPtr->namesp); Itcl_ReleaseData((ClientData)cdefnPtr); } /* * ------------------------------------------------------------------------ * ItclDestroyClassNamesp() * * Invoked whenever the namespace associated with a class is destroyed. * Destroys all objects associated with this class and all derived * classes. Disconnects this class from the "derived" class lists * of its base classes, and removes the class access command. Releases * any claim to the class definition data. If this is the last use * of that data, the class will completely vanish at this point. * ------------------------------------------------------------------------ */ static void ItclDestroyClassNamesp(cdata) ClientData cdata; /* class definition to be destroyed */ { ItclClass *cdefnPtr = (ItclClass*)cdata; ItclObject *contextObj; Itcl_ListElem *elem, *belem; ItclClass *cdPtr, *basePtr, *derivedPtr; Tcl_HashEntry *entry; Tcl_HashSearch place; /* * Destroy all derived classes, since these lose their meaning * when the base class goes away. * * TRICKY NOTE: When a derived class is destroyed, it * automatically deletes itself from the "derived" list. */ elem = Itcl_FirstListElem(&cdefnPtr->derived); while (elem) { cdPtr = (ItclClass*)Itcl_GetListValue(elem); Tcl_DeleteNamespace(cdPtr->namesp); /* As the first namespace is now destroyed we have to get the * new first element of the hash table. We cannot go to the * next element from the current one, because the current one * is deleted. itcl Patch #593112, for Bug #577719. */ elem = Itcl_FirstListElem(&cdefnPtr->derived); } /* * Scan through and find all objects that belong to this class. * Destroy them quietly by deleting their access command. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); while (entry) { contextObj = (ItclObject*)Tcl_GetHashValue(entry); if (contextObj->classDefn == cdefnPtr) { Tcl_DeleteCommandFromToken(cdefnPtr->interp, contextObj->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. */ entry = Tcl_FirstHashEntry(&cdefnPtr->info->objects, &place); continue; } entry = Tcl_NextHashEntry(&place); } /* * Next, remove this class from the "derived" list in * all base classes. */ belem = Itcl_FirstListElem(&cdefnPtr->bases); while (belem) { basePtr = (ItclClass*)Itcl_GetListValue(belem); elem = Itcl_FirstListElem(&basePtr->derived); while (elem) { derivedPtr = (ItclClass*)Itcl_GetListValue(elem); if (derivedPtr == cdefnPtr) { Itcl_ReleaseData( Itcl_GetListValue(elem) ); elem = Itcl_DeleteListElem(elem); } else { elem = Itcl_NextListElem(elem); } } belem = Itcl_NextListElem(belem); } /* * Next, destroy the access command associated with the class. */ if (cdefnPtr->accessCmd) { Command *cmdPtr = (Command*)cdefnPtr->accessCmd; cmdPtr->deleteProc = Itcl_ReleaseData; Tcl_DeleteCommandFromToken(cdefnPtr->interp, cdefnPtr->accessCmd); } /* * Release the namespace's claim on the class definition. */ Itcl_ReleaseData((ClientData)cdefnPtr); } /* * ------------------------------------------------------------------------ * ItclFreeClass() * * Frees all memory associated with a class definition. This is * usually invoked automatically by Itcl_ReleaseData(), when class * data is no longer being used. * ------------------------------------------------------------------------ */ static void ItclFreeClass(cdata) char *cdata; /* class definition to be destroyed */ { ItclClass *cdefnPtr = (ItclClass*)cdata; Itcl_ListElem *elem; Tcl_HashSearch place; Tcl_HashEntry *entry; ItclVarDefn *vdefn; ItclVarLookup *vlookup; VarInHash *varPtr; /* * Tear down the list of derived classes. This list should * really be empty if everything is working properly, but * release it here just in case. */ elem = Itcl_FirstListElem(&cdefnPtr->derived); while (elem) { Itcl_ReleaseData( Itcl_GetListValue(elem) ); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&cdefnPtr->derived); /* * Tear down the variable resolution table. Some records * appear multiple times in the table (for x, foo::x, etc.) * so each one has a reference count. */ entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); while (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (--vlookup->usage == 0) { /* * If this is a common variable owned by this class, * then release the class's hold on it. If it's no * longer being used, move it into a variable table * for destruction. */ if ( (vlookup->vdefn->member->flags & ITCL_COMMON) != 0 && vlookup->vdefn->member->classDefn == cdefnPtr ) { varPtr = (VarInHash*)vlookup->var.common; if (--ItclVarRefCount(varPtr) == 0) { /* * This is called after the namespace is already gone: the * variable is already unset and ready to be freed. */ ckfree((char *)varPtr); } } ckfree((char*)vlookup); } entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&cdefnPtr->resolveVars); /* * Tear down the virtual method table... */ Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); /* * Delete all variable definitions. */ entry = Tcl_FirstHashEntry(&cdefnPtr->variables, &place); while (entry) { vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); Itcl_DeleteVarDefn(vdefn); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&cdefnPtr->variables); /* * Delete all function definitions. */ entry = Tcl_FirstHashEntry(&cdefnPtr->functions, &place); while (entry) { Itcl_ReleaseData( Tcl_GetHashValue(entry) ); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&cdefnPtr->functions); /* * Release the claim on all base classes. */ elem = Itcl_FirstListElem(&cdefnPtr->bases); while (elem) { Itcl_ReleaseData( Itcl_GetListValue(elem) ); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&cdefnPtr->bases); Tcl_DeleteHashTable(&cdefnPtr->heritage); /* * Free up the object initialization code. */ if (cdefnPtr->initCode) { Tcl_DecrRefCount(cdefnPtr->initCode); } Itcl_ReleaseData((ClientData)cdefnPtr->info); ckfree(cdefnPtr->name); ckfree(cdefnPtr->fullname); ckfree((char*)cdefnPtr); } /* * ------------------------------------------------------------------------ * Itcl_IsClassNamespace() * * Checks to see whether or not the given namespace represents an * [incr Tcl] class. Returns non-zero if so, and zero otherwise. * ------------------------------------------------------------------------ */ int Itcl_IsClassNamespace(namesp) Tcl_Namespace *namesp; /* namespace being tested */ { Namespace *nsPtr = (Namespace*)namesp; if (nsPtr != NULL) { return (nsPtr->deleteProc == ItclDestroyClassNamesp); } return 0; } /* * ------------------------------------------------------------------------ * Itcl_IsClass() * * Checks the given Tcl command to see if it represents an itcl class. * Returns non-zero if the command is associated with a class. * ------------------------------------------------------------------------ */ int Itcl_IsClass(cmd) Tcl_Command cmd; /* command being tested */ { Command *cmdPtr = (Command*)cmd; if (cmdPtr->deleteProc == ItclDestroyClass) { return 1; } /* * This may be an imported command. Try to get the real * command and see if it represents a class. */ cmdPtr = (Command*)TclGetOriginalCommand(cmd); if (cmdPtr && cmdPtr->deleteProc == ItclDestroyClass) { return 1; } return 0; } /* * ------------------------------------------------------------------------ * Itcl_FindClass() * * Searches for the specified class in the active namespace. If the * class is found, this procedure returns a pointer to the class * definition. Otherwise, if the autoload flag is non-zero, an * attempt will be made to autoload the class definition. If it * still can't be found, this procedure returns NULL, along with an * error message in the interpreter. * ------------------------------------------------------------------------ */ ItclClass* Itcl_FindClass(interp, path, autoload) Tcl_Interp* interp; /* interpreter containing class */ CONST char* path; /* path name for class */ int autoload; /* should class be loaded */ { Tcl_Namespace* classNs; /* * Search for a namespace with the specified name, and if * one is found, see if it is a class namespace. */ classNs = Itcl_FindClassNamespace(interp, path); if (classNs && Itcl_IsClassNamespace(classNs)) { return (ItclClass*)classNs->clientData; } /* * If the autoload flag is set, try to autoload the class * definition. */ if (autoload) { if (Tcl_VarEval(interp, "::auto_load ", path, (char*)NULL) != TCL_OK) { char msg[256]; sprintf(msg, "\n (while attempting to autoload class \"%.200s\")", path); Tcl_AddErrorInfo(interp, msg); return NULL; } Tcl_ResetResult(interp); classNs = Itcl_FindClassNamespace(interp, path); if (classNs && Itcl_IsClassNamespace(classNs)) { return (ItclClass*)classNs->clientData; } } Tcl_AppendResult(interp, "class \"", path, "\" not found in context \"", Tcl_GetCurrentNamespace(interp)->fullName, "\"", (char*)NULL); return NULL; } /* * ------------------------------------------------------------------------ * Itcl_FindClassNamespace() * * Searches for the specified class namespace. The normal Tcl procedure * Tcl_FindNamespace also searches for namespaces, but only in the * current namespace context. This makes it hard to find one class * from within another. For example, suppose. you have two namespaces * Foo and Bar. If you're in the context of Foo and you look for * Bar, you won't find it with Tcl_FindNamespace. This behavior is * okay for namespaces, but wrong for classes. * * This procedure search for a class namespace. If the name is * absolute (i.e., starts with "::"), then that one name is checked, * and the class is either found or not. But if the name is relative, * it is sought in the current namespace context and in the global * context, just like the normal command lookup. * * This procedure returns a pointer to the desired namespace, or * NULL if the namespace was not found. * ------------------------------------------------------------------------ */ Tcl_Namespace* Itcl_FindClassNamespace(interp, path) Tcl_Interp* interp; /* interpreter containing class */ CONST char* path; /* path name for class */ { Tcl_Namespace* contextNs = Tcl_GetCurrentNamespace(interp); Tcl_Namespace* classNs; Tcl_DString buffer; /* * Look up the namespace. If the name is not absolute, then * see if it's the current namespace, and try the global * namespace as well. */ classNs = Tcl_FindNamespace(interp, path, (Tcl_Namespace*)NULL, /* flags */ 0); if ( !classNs && contextNs->parentPtr != NULL && !(*path == ':' && *(path+1) == ':') ) { if (strcmp(contextNs->name, path) == 0) { classNs = contextNs; } else { Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "::", -1); Tcl_DStringAppend(&buffer, path, -1); classNs = Tcl_FindNamespace(interp, Tcl_DStringValue(&buffer), (Tcl_Namespace*)NULL, /* flags */ 0); Tcl_DStringFree(&buffer); } } return classNs; } /* * ------------------------------------------------------------------------ * Itcl_HandleClass() * * Invoked by Tcl whenever the user issues the command associated with * a class name. Handles the following syntax: * * * ?...? * * Without any arguments, the command does nothing. In the olden days, * this allowed the class name to be invoked by itself to prompt the * autoloader to load the class definition. Today, this behavior is * retained for backward compatibility with old releases. * * If arguments are specified, then this procedure creates a new * object named in the appropriate class. Note that if * contains "#auto", that part is automatically replaced * by a unique string built from the class name. * ------------------------------------------------------------------------ */ int Itcl_HandleClass(clientData, interp, objc, objv) ClientData clientData; /* class definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclClass *cdefnPtr = (ItclClass*)clientData; int result = TCL_OK; Tcl_DString buffer; /* buffer used to build object names */ char *token, *objName, *match; ItclObject *newObj; Itcl_CallFrame frame; /* * If the command is invoked without an object name, then do nothing. * This used to support autoloading--that the class name could be * invoked as a command by itself, prompting the autoloader to * load the class definition. We retain the behavior here for * backward-compatibility with earlier releases. */ if (objc == 1) { return TCL_OK; } /* * If the object name is "::", and if this is an old-style class * definition, then treat the remaining arguments as a command * in the class namespace. This used to be the way of invoking * a class proc, but the new syntax is "class::proc" (without * spaces). */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); if ((*token == ':') && (strcmp(token,"::") == 0) && (objc > 2)) { if ((cdefnPtr->flags & ITCL_OLD_STYLE) != 0) { result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, cdefnPtr->namesp, /* isProcCallFrame */ 0); if (result != TCL_OK) { return result; } result = Itcl_EvalArgs(interp, objc-2, objv+2); Tcl_PopCallFrame(interp); return result; } /* * If this is not an old-style class, then return an error * describing the syntax change. */ Tcl_AppendResult(interp, "syntax \"class :: proc\" is an anachronism\n", "[incr Tcl] no longer supports this syntax.\n", "Instead, remove the spaces from your procedure invocations:\n", " ", Tcl_GetStringFromObj(objv[0], (int*)NULL), "::", Tcl_GetStringFromObj(objv[2], (int*)NULL), " ?args?", (char*)NULL); return TCL_ERROR; } /* * Otherwise, we have a proper object name. Create a new instance * with that name. If the name contains "#auto", replace this with * a uniquely generated string based on the class name. */ Tcl_DStringInit(&buffer); objName = token; match = strstr(token, "#auto"); if (match != NULL) { int len; char unique[TCL_INTEGER_SPACE]; /* for unique part of object names */ Tcl_CmdInfo dummy; Tcl_UniChar ch; Tcl_DStringAppend(&buffer, token, (match - token)); /* * Only lowercase the first char of $class, per itcl #auto semantics */ len = Tcl_UtfToUniChar(cdefnPtr->name, &ch); ch = Tcl_UniCharToLower(ch); Tcl_UniCharToUtfDString(&ch, 1, &buffer); Tcl_DStringAppend(&buffer, cdefnPtr->name + len, -1); /* * Substitute a unique part in for "#auto", and keep * incrementing a counter until a valid name is found. */ len = Tcl_DStringLength(&buffer); do { sprintf(unique, "%d", cdefnPtr->unique++); Tcl_DStringTrunc(&buffer, len); Tcl_DStringAppend(&buffer, unique, -1); Tcl_DStringAppend(&buffer, match+5, -1); objName = Tcl_DStringValue(&buffer); /* * [Fix 227811] Check for any command with the given name, not * only objects. */ if (Tcl_GetCommandInfo (interp, objName, &dummy) == 0) { break; /* if an error is found, bail out! */ } } while (1); } /* * Try to create a new object. If successful, return the * object name as the result of this command. */ result = Itcl_CreateObject(interp, objName, cdefnPtr, objc-2, objv+2, &newObj); if (result == TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj(objName, -1)); } Tcl_DStringFree(&buffer); return result; } /* * ------------------------------------------------------------------------ * 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(interp, name, context, flags, rPtr) Tcl_Interp *interp; /* current interpreter */ CONST char* name; /* name of the command being accessed */ Tcl_Namespace *context; /* 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 */ { ItclClass *cdefn = (ItclClass*)context->clientData; Tcl_HashEntry *entry; ItclMemberFunc *mfunc; Command *cmdPtr; /* * If the command is a member function, and if it is * accessible, return its Tcl command handle. */ entry = Tcl_FindHashEntry(&cdefn->resolveCmds, name); if (!entry) { return TCL_CONTINUE; } mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); /* * For protected/private functions, figure out whether or * not the function is accessible from the current context. * * TRICKY NOTE: Use Itcl_GetTrueNamespace to determine * the current context. If the current call frame is * "transparent", this handles it properly. */ if (mfunc->member->protection != ITCL_PUBLIC) { context = Itcl_GetTrueNamespace(interp, cdefn->info); if (!Itcl_CanAccessFunc(mfunc, context)) { if ((flags & TCL_LEAVE_ERR_MSG) != 0) { Tcl_AppendResult(interp, "can't access \"", name, "\": ", Itcl_ProtectionStr(mfunc->member->protection), " variable", (char*)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. */ cmdPtr = (Command*)mfunc->accessCmd; if (!cmdPtr || cmdPtr->flags & CMD_IS_DELETED) { mfunc->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)", (char*)NULL); } return TCL_ERROR; /* disallow access! */ } *rPtr = mfunc->accessCmd; return TCL_OK; } /* * ------------------------------------------------------------------------ * 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(interp, name, context, flags, rPtr) Tcl_Interp *interp; /* current interpreter */ CONST char* name; /* name of the variable being accessed */ Tcl_Namespace *context; /* 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 */ { Interp *iPtr = (Interp *) interp; ItclCallFrame *varFramePtr = (ItclCallFrame *) iPtr->varFramePtr; ItclClass *cdefn = (ItclClass*)context->clientData; ItclObject *contextObj; Itcl_CallFrame *framePtr; Tcl_HashEntry *entry; ItclVarLookup *vlookup; assert(Itcl_IsClassNamespace(context)); /* * 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, and we do not want to * override Tcl's normal resolution of the local var. We return * TCL_CONTINUE to let Tcl take control back. */ if (varFramePtr && varFramePtr->isProcCallFrame && strstr(name,"::") == NULL) { Proc *procPtr = varFramePtr->procPtr; /* * Search through compiled locals first... */ if (procPtr) { int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; Var *localVarPtr = varFramePtr->compiledLocals; int nameLen = strlen(name); int i; for (i=0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { register char *localName = localPtr->name; if ((name[0] == localName[0]) && (nameLen == localPtr->nameLength) && (strcmp(name, localName) == 0)) { return TCL_CONTINUE; } } ItclNextLocal(localVarPtr); localPtr = localPtr->nextPtr; } } /* * If it's not a compiled local, then look in the frame's * var hash table next. This variable may have been * created on the fly. */ if (varFramePtr->varTablePtr != NULL) { *rPtr = (Tcl_Var) ItclVarHashFindVar(varFramePtr->varTablePtr, name); if (*rPtr) { return TCL_CONTINUE; } } } /* * See if the variable is a known data member and accessible. */ entry = Tcl_FindHashEntry(&cdefn->resolveVars, name); if (entry == NULL) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 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->vdefn->member->flags & ITCL_COMMON) != 0) { *rPtr = vlookup->var.common; return TCL_OK; } /* * If this is an instance variable, then we have to * find the object context, then index into its data * array to get the actual variable. */ framePtr = _Tcl_GetCallFrame(interp, 0); entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); if (entry == NULL) { return TCL_CONTINUE; } contextObj = (ItclObject*)Tcl_GetHashValue(entry); /* * TRICKY NOTE: We've resolved the variable in the current * class context, but we must also be careful to get its * index from the most-specific class context. Variables * are arranged differently depending on which class * constructed the object. */ if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, vlookup->vdefn->member->fullname); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); } } if (vlookup->var.index >= contextObj->dataSize) { return TCL_CONTINUE; } *rPtr = (Tcl_Var)contextObj->data[vlookup->var.index]; return TCL_OK; } /* * ------------------------------------------------------------------------ * 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(interp, name, length, context, rPtr) Tcl_Interp *interp; /* current interpreter */ CONST char* name; /* name of the variable being accessed */ int length; /* number of characters in name */ Tcl_Namespace *context; /* namespace performing the resolution */ Tcl_ResolvedVarInfo **rPtr; /* returns: info that makes it possible to * resolve the variable at runtime */ { ItclClass *cdefn = (ItclClass*)context->clientData; Tcl_HashEntry *entry; ItclVarLookup *vlookup; char *buffer, storage[64]; assert(Itcl_IsClassNamespace(context)); /* * Copy the name to local storage so we can NULL terminate it. * If the name is long, allocate extra space for it. */ if (length < sizeof(storage)) { buffer = storage; } else { buffer = (char*)ckalloc((unsigned)(length+1)); } memcpy((void*)buffer, (void*)name, (size_t)length); buffer[length] = '\0'; entry = Tcl_FindHashEntry(&cdefn->resolveVars, 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 (entry == NULL) { return TCL_CONTINUE; } vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); 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(interp, resVarInfo) Tcl_Interp *interp; /* current interpreter */ Tcl_ResolvedVarInfo *resVarInfo; /* contains ItclVarLookup rep * for variable */ { ItclVarLookup *vlookup = ((ItclResolvedVarInfo*)resVarInfo)->vlookup; Itcl_CallFrame *framePtr; ItclClass *cdefn; ItclObject *contextObj; Tcl_HashEntry *entry; /* * If this is a common data member, then the associated * variable is known directly. */ if ((vlookup->vdefn->member->flags & ITCL_COMMON) != 0) { return vlookup->var.common; } cdefn = vlookup->vdefn->member->classDefn; /* * 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. */ framePtr = _Tcl_GetCallFrame(interp, 0); entry = Tcl_FindHashEntry(&cdefn->info->contextFrames, (char*)framePtr); if (entry) { contextObj = (ItclObject*)Tcl_GetHashValue(entry); if (contextObj != NULL) { if (contextObj->classDefn != vlookup->vdefn->member->classDefn) { entry = Tcl_FindHashEntry(&contextObj->classDefn->resolveVars, vlookup->vdefn->member->fullname); if (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); } } return (Tcl_Var)contextObj->data[vlookup->var.index]; } } return NULL; } /* * ------------------------------------------------------------------------ * Itcl_BuildVirtualTables() * * Invoked whenever the class heritage changes or members are added or * removed from a class definition to rebuild the member lookup * tables. There are two tables: * * METHODS: resolveCmds * Used primarily in Itcl_ClassCmdResolver() to resolve all * command references in a namespace. * * DATA MEMBERS: resolveVars * Used primarily in Itcl_ClassVarResolver() to quickly resolve * variable references in each class scope. * * These tables store every possible name for each command/variable * (member, class::member, namesp::class::member, etc.). Members * in a derived class may shadow members with the same name in a * base class. In that case, the simple name in the resolution * table will point to the most-specific member. * ------------------------------------------------------------------------ */ void Itcl_BuildVirtualTables(cdefnPtr) ItclClass* cdefnPtr; /* class definition being updated */ { Tcl_HashEntry *entry; Tcl_HashSearch place; ItclVarLookup *vlookup; ItclVarDefn *vdefn; ItclMemberFunc *mfunc; ItclHierIter hier; ItclClass *cdPtr; Namespace* nsPtr; Tcl_DString buffer, buffer2; int newEntry; Tcl_DStringInit(&buffer); Tcl_DStringInit(&buffer2); /* * Clear the variable resolution table. */ entry = Tcl_FirstHashEntry(&cdefnPtr->resolveVars, &place); while (entry) { vlookup = (ItclVarLookup*)Tcl_GetHashValue(entry); if (--vlookup->usage == 0) { ckfree((char*)vlookup); } entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&cdefnPtr->resolveVars); Tcl_InitHashTable(&cdefnPtr->resolveVars, TCL_STRING_KEYS); cdefnPtr->numInstanceVars = 0; /* * Set aside the first object-specific slot for the built-in * "this" variable. Only allocate one of these, even though * there is a definition for "this" in each class scope. */ cdefnPtr->numInstanceVars++; /* * Scan through all classes in the hierarchy, from most to * least specific. Add a lookup entry for each variable * into the table. */ Itcl_InitHierIter(&hier, cdefnPtr); cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr != NULL) { entry = Tcl_FirstHashEntry(&cdPtr->variables, &place); while (entry) { vdefn = (ItclVarDefn*)Tcl_GetHashValue(entry); vlookup = (ItclVarLookup*)ckalloc(sizeof(ItclVarLookup)); vlookup->vdefn = vdefn; vlookup->usage = 0; vlookup->leastQualName = NULL; /* * If this variable is PRIVATE to another class scope, * then mark it as "inaccessible". */ vlookup->accessible = ( vdefn->member->protection != ITCL_PRIVATE || vdefn->member->classDefn == cdefnPtr ); /* * If this is a common variable, then keep a reference to * the variable directly. Otherwise, keep an index into * the object's variable table. */ if ((vdefn->member->flags & ITCL_COMMON) != 0) { nsPtr = (Namespace*)cdPtr->namesp; vlookup->var.common = (Tcl_Var) ItclVarHashFindVar(&nsPtr->varTable, vdefn->member->name); assert(vlookup->var.common != NULL); } else { /* * If this is a reference to the built-in "this" * variable, then its index is "0". Otherwise, * add another slot to the end of the table. */ if ((vdefn->member->flags & ITCL_THIS_VAR) != 0) { vlookup->var.index = 0; } else { vlookup->var.index = cdefnPtr->numInstanceVars++; } } /* * Create all possible names for this variable and enter * them into the variable resolution table: * var * class::var * namesp1::class::var * namesp2::namesp1::class::var * ... */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, vdefn->member->name, -1); nsPtr = (Namespace*)cdPtr->namesp; while (1) { entry = Tcl_CreateHashEntry(&cdefnPtr->resolveVars, Tcl_DStringValue(&buffer), &newEntry); if (newEntry) { Tcl_SetHashValue(entry, (ClientData)vlookup); vlookup->usage++; if (!vlookup->leastQualName) { vlookup->leastQualName = Tcl_GetHashKey(&cdefnPtr->resolveVars, entry); } } if (nsPtr == NULL) { break; } Tcl_DStringSetLength(&buffer2, 0); Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, nsPtr->name, -1); Tcl_DStringAppend(&buffer, "::", -1); Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); nsPtr = nsPtr->parentPtr; } /* * If this record is not needed, free it now. */ if (vlookup->usage == 0) { ckfree((char*)vlookup); } entry = Tcl_NextHashEntry(&place); } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); /* * Clear the command resolution table. */ Tcl_DeleteHashTable(&cdefnPtr->resolveCmds); Tcl_InitHashTable(&cdefnPtr->resolveCmds, TCL_STRING_KEYS); /* * Scan through all classes in the hierarchy, from most to * least specific. Look for the first (most-specific) definition * of each member function, and enter it into the table. */ Itcl_InitHierIter(&hier, cdefnPtr); cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr != NULL) { entry = Tcl_FirstHashEntry(&cdPtr->functions, &place); while (entry) { mfunc = (ItclMemberFunc*)Tcl_GetHashValue(entry); /* * Create all possible names for this function and enter * them into the command resolution table: * func * class::func * namesp1::class::func * namesp2::namesp1::class::func * ... */ Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, mfunc->member->name, -1); nsPtr = (Namespace*)cdPtr->namesp; while (1) { entry = Tcl_CreateHashEntry(&cdefnPtr->resolveCmds, Tcl_DStringValue(&buffer), &newEntry); if (newEntry) { Tcl_SetHashValue(entry, (ClientData)mfunc); } if (nsPtr == NULL) { break; } Tcl_DStringSetLength(&buffer2, 0); Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer), -1); Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, nsPtr->name, -1); Tcl_DStringAppend(&buffer, "::", -1); Tcl_DStringAppend(&buffer, Tcl_DStringValue(&buffer2), -1); nsPtr = nsPtr->parentPtr; } entry = Tcl_NextHashEntry(&place); } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); Tcl_DStringFree(&buffer); Tcl_DStringFree(&buffer2); } /* * ------------------------------------------------------------------------ * Itcl_CreateVarDefn() * * Creates a new class variable definition. If this is a public * variable, it may have a bit of "config" code that is used to * update the object whenever the variable is modified via the * built-in "configure" method. * * Returns TCL_ERROR along with an error message in the specified * interpreter if anything goes wrong. Otherwise, this returns * TCL_OK and a pointer to the new variable definition in "vdefnPtr". * ------------------------------------------------------------------------ */ int Itcl_CreateVarDefn(interp, cdefn, name, init, config, vdefnPtr) Tcl_Interp *interp; /* interpreter managing this transaction */ ItclClass* cdefn; /* class containing this variable */ char* name; /* variable name */ char* init; /* initial value */ char* config; /* code invoked when variable is configured */ ItclVarDefn** vdefnPtr; /* returns: new variable definition */ { int newEntry; ItclVarDefn *vdefn; ItclMemberCode *mcode; Tcl_HashEntry *entry; /* * Add this variable to the variable table for the class. * Make sure that the variable name does not already exist. */ entry = Tcl_CreateHashEntry(&cdefn->variables, name, &newEntry); if (!newEntry) { Tcl_AppendResult(interp, "variable name \"", name, "\" already defined in class \"", cdefn->fullname, "\"", (char*)NULL); return TCL_ERROR; } /* * If this variable has some "config" code, try to capture * its implementation. */ if (config) { if (Itcl_CreateMemberCode(interp, cdefn, (char*)NULL, config, &mcode) != TCL_OK) { Tcl_DeleteHashEntry(entry); return TCL_ERROR; } Itcl_PreserveData((ClientData)mcode); Itcl_EventuallyFree((ClientData)mcode, (Tcl_FreeProc*) Itcl_DeleteMemberCode); } else { mcode = NULL; } /* * If everything looks good, create the variable definition. */ vdefn = (ItclVarDefn*)ckalloc(sizeof(ItclVarDefn)); vdefn->member = Itcl_CreateMember(interp, cdefn, name); vdefn->member->code = mcode; if (vdefn->member->protection == ITCL_DEFAULT_PROTECT) { vdefn->member->protection = ITCL_PROTECTED; } if (init) { vdefn->init = (char*)ckalloc((unsigned)(strlen(init)+1)); strcpy(vdefn->init, init); } else { vdefn->init = NULL; } Tcl_SetHashValue(entry, (ClientData)vdefn); *vdefnPtr = vdefn; return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_DeleteVarDefn() * * Destroys a variable definition created by Itcl_CreateVarDefn(), * freeing all resources associated with it. * ------------------------------------------------------------------------ */ void Itcl_DeleteVarDefn(vdefn) ItclVarDefn *vdefn; /* variable definition to be destroyed */ { Itcl_DeleteMember(vdefn->member); if (vdefn->init) { ckfree(vdefn->init); } ckfree((char*)vdefn); } /* * ------------------------------------------------------------------------ * Itcl_GetCommonVar() * * Returns the current value for a common class variable. The member * name is interpreted with respect to the given class scope. That * scope is installed as the current context before querying the * variable. This by-passes the protection level in case the variable * is "private". * * If successful, this procedure returns a pointer to a string value * which remains alive until the variable changes it value. If * anything goes wrong, this returns NULL. * ------------------------------------------------------------------------ */ CONST char* Itcl_GetCommonVar(interp, name, contextClass) Tcl_Interp *interp; /* current interpreter */ CONST char *name; /* name of desired instance variable */ ItclClass *contextClass; /* name is interpreted in this scope */ { CONST char *val = NULL; int result; Itcl_CallFrame frame; /* * Activate the namespace for the given class. That installs * the appropriate name resolution rules and by-passes any * security restrictions. */ result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, contextClass->namesp, /*isProcCallFrame*/ 0); if (result == TCL_OK) { val = Tcl_GetVar2(interp, name, (char*)NULL, 0); Tcl_PopCallFrame(interp); } return val; } /* * ------------------------------------------------------------------------ * Itcl_CreateMember() * * Creates the data record representing a class member. This is the * generic representation for a data member or member function. * Returns a pointer to the new representation. * ------------------------------------------------------------------------ */ ItclMember* Itcl_CreateMember(interp, cdefn, name) Tcl_Interp* interp; /* interpreter managing this action */ ItclClass *cdefn; /* class definition */ CONST char* name; /* name of new member */ { ItclMember *memPtr; int fullsize; /* * Allocate the memory for a class member and fill in values. */ memPtr = (ItclMember*)ckalloc(sizeof(ItclMember)); memPtr->interp = interp; memPtr->classDefn = cdefn; memPtr->flags = 0; memPtr->protection = Itcl_Protection(interp, 0); memPtr->code = NULL; fullsize = strlen(cdefn->fullname) + strlen(name) + 2; memPtr->fullname = (char*)ckalloc((unsigned)(fullsize+1)); strcpy(memPtr->fullname, cdefn->fullname); strcat(memPtr->fullname, "::"); strcat(memPtr->fullname, name); memPtr->name = (char*)ckalloc((unsigned)(strlen(name)+1)); strcpy(memPtr->name, name); return memPtr; } /* * ------------------------------------------------------------------------ * Itcl_DeleteMember() * * Destroys all data associated with the given member function definition. * Usually invoked by the interpreter when a member function is deleted. * ------------------------------------------------------------------------ */ void Itcl_DeleteMember(memPtr) ItclMember *memPtr; /* pointer to member function definition */ { if (memPtr) { ckfree(memPtr->name); ckfree(memPtr->fullname); if (memPtr->code) { Itcl_ReleaseData((ClientData)memPtr->code); } memPtr->code = NULL; ckfree((char*)memPtr); } } /* * ------------------------------------------------------------------------ * Itcl_InitHierIter() * * Initializes an iterator for traversing the hierarchy of the given * class. Subsequent calls to Itcl_AdvanceHierIter() will return * the base classes in order from most-to-least specific. * ------------------------------------------------------------------------ */ void Itcl_InitHierIter(iter,cdefn) ItclHierIter *iter; /* iterator used for traversal */ ItclClass *cdefn; /* class definition for start of traversal */ { Itcl_InitStack(&iter->stack); Itcl_PushStack((ClientData)cdefn, &iter->stack); iter->current = cdefn; } /* * ------------------------------------------------------------------------ * Itcl_DeleteHierIter() * * Destroys an iterator for traversing class hierarchies, freeing * all memory associated with it. * ------------------------------------------------------------------------ */ void Itcl_DeleteHierIter(iter) ItclHierIter *iter; /* iterator used for traversal */ { Itcl_DeleteStack(&iter->stack); iter->current = NULL; } /* * ------------------------------------------------------------------------ * Itcl_AdvanceHierIter() * * Moves a class hierarchy iterator forward to the next base class. * Returns a pointer to the current class definition, or NULL when * the end of the hierarchy has been reached. * ------------------------------------------------------------------------ */ ItclClass* Itcl_AdvanceHierIter(iter) ItclHierIter *iter; /* iterator used for traversal */ { register Itcl_ListElem *elem; ItclClass *cdPtr; iter->current = (ItclClass*)Itcl_PopStack(&iter->stack); /* * Push classes onto the stack in reverse order, so that * they will be popped off in the proper order. */ if (iter->current) { cdPtr = (ItclClass*)iter->current; elem = Itcl_LastListElem(&cdPtr->bases); while (elem) { Itcl_PushStack(Itcl_GetListValue(elem), &iter->stack); elem = Itcl_PrevListElem(elem); } } return iter->current; } itcl3.4.3/generic/itcl_bicmds.c0000644003604700454610000015276312632344507015052 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 built-in class methods, including the * "isa" method (to query hierarchy info) and the "info" method * (to query class/object data). * * ======================================================================== * 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" /* * Standard list of built-in methods for all objects. */ typedef struct BiMethod { char* name; /* method name */ char* usage; /* string describing usage */ char* registration; /* registration name for C proc */ Tcl_ObjCmdProc *proc; /* implementation C proc */ } BiMethod; static BiMethod BiMethodList[] = { { "cget", "-option", "@itcl-builtin-cget", Itcl_BiCgetCmd }, { "configure", "?-option? ?value -option value...?", "@itcl-builtin-configure", Itcl_BiConfigureCmd }, { "isa", "className", "@itcl-builtin-isa", Itcl_BiIsaCmd }, }; static int BiMethodListLen = sizeof(BiMethodList)/sizeof(BiMethod); /* * FORWARD DECLARATIONS */ static Tcl_Obj* ItclReportPublicOpt _ANSI_ARGS_((Tcl_Interp *interp, ItclVarDefn *vdefn, ItclObject *contextObj)); /* * ------------------------------------------------------------------------ * Itcl_BiInit() * * Creates a namespace full of built-in methods/procs for [incr Tcl] * classes. This includes things like the "isa" method and "info" * for querying class info. Usually invoked by Itcl_Init() when * [incr Tcl] is first installed into an interpreter. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ int Itcl_BiInit(interp) Tcl_Interp *interp; /* current interpreter */ { int i; Tcl_Namespace *itclBiNs; /* * Declare all of the built-in methods as C procedures. */ for (i=0; i < BiMethodListLen; i++) { if (Itcl_RegisterObjC(interp, BiMethodList[i].registration+1, BiMethodList[i].proc, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { return TCL_ERROR; } } /* * Create the "::itcl::builtin" namespace for built-in class * commands. These commands are imported into each class * just before the class definition is parsed. */ Tcl_CreateObjCommand(interp, "::itcl::builtin::chain", Itcl_BiChainCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL); if (Itcl_CreateEnsemble(interp, "::itcl::builtin::info") != TCL_OK) { return TCL_ERROR; } if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "class", "", Itcl_BiInfoClassCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "inherit", "", Itcl_BiInfoInheritCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "heritage", "", Itcl_BiInfoHeritageCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "function", "?name? ?-protection? ?-type? ?-name? ?-args? ?-body?", Itcl_BiInfoFunctionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "variable", "?name? ?-protection? ?-type? ?-name? ?-init? ?-value? ?-config?", Itcl_BiInfoVariableCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "args", "procname", Itcl_BiInfoArgsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "body", "procname", Itcl_BiInfoBodyCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ) { return TCL_ERROR; } /* * Add an error handler to support all of the usual inquiries * for the "info" command in the global namespace. */ if (Itcl_AddEnsemblePart(interp, "::itcl::builtin::info", "@error", "", Itcl_DefaultInfoCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ) { return TCL_ERROR; } /* * Export all commands in the built-in namespace so we can * import them later on. */ itclBiNs = Tcl_FindNamespace(interp, "::itcl::builtin", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (!itclBiNs || Tcl_Export(interp, itclBiNs, "*", /* resetListFirst */ 1) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_InstallBiMethods() * * Invoked when a class is first created, just after the class * definition has been parsed, to add definitions for built-in * methods to the class. If a method already exists in the class * with the same name as the built-in, then the built-in is skipped. * Otherwise, a method definition for the built-in method is added. * * Returns TCL_OK if successful, or TCL_ERROR (along with an error * message in the interpreter) if anything goes wrong. * ------------------------------------------------------------------------ */ int Itcl_InstallBiMethods(interp, cdefn) Tcl_Interp *interp; /* current interpreter */ ItclClass *cdefn; /* class definition to be updated */ { int result = TCL_OK; Tcl_HashEntry *entry = NULL; int i; ItclHierIter hier; ItclClass *cdPtr; /* * Scan through all of the built-in methods and see if * that method already exists in the class. If not, add * it in. * * TRICKY NOTE: The virtual tables haven't been built yet, * so look for existing methods the hard way--by scanning * through all classes. */ for (i=0; i < BiMethodListLen; i++) { Itcl_InitHierIter(&hier, cdefn); cdPtr = Itcl_AdvanceHierIter(&hier); while (cdPtr) { entry = Tcl_FindHashEntry(&cdPtr->functions, BiMethodList[i].name); if (entry) { break; } cdPtr = Itcl_AdvanceHierIter(&hier); } Itcl_DeleteHierIter(&hier); if (!entry) { result = Itcl_CreateMethod(interp, cdefn, BiMethodList[i].name, BiMethodList[i].usage, BiMethodList[i].registration); if (result != TCL_OK) { break; } } } return result; } /* * ------------------------------------------------------------------------ * Itcl_BiIsaCmd() * * Invoked whenever the user issues the "isa" method for an object. * Handles the following syntax: * * isa * * Checks to see if the object has the given anywhere * in its heritage. Returns 1 if so, and 0 otherwise. * ------------------------------------------------------------------------ */ /* ARGSUSED */ int Itcl_BiIsaCmd(clientData, interp, objc, objv) ClientData clientData; /* class definition */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclClass *contextClass, *cdefn; ItclObject *contextObj; char *token; /* * Make sure that this command is being invoked in the proper * context. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK) { return TCL_ERROR; } if (!contextObj) { Tcl_AppendResult(interp, "improper usage: should be \"object isa className\"", (char*)NULL); return TCL_ERROR; } if (objc != 2) { token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "wrong # args: should be \"object ", token, " className\"", (char*)NULL); return TCL_ERROR; } /* * Look for the requested class. If it is not found, then * try to autoload it. If it absolutely cannot be found, * signal an error. */ token = Tcl_GetStringFromObj(objv[1], (int*)NULL); cdefn = Itcl_FindClass(interp, token, /* autoload */ 1); if (cdefn == NULL) { return TCL_ERROR; } if (Itcl_ObjectIsa(contextObj, cdefn)) { Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); } else { Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itcl_BiConfigureCmd() * * Invoked whenever the user issues the "configure" method for an object. * Handles the following syntax: * * configure ?-