itk3.4/0000755003604700454610000000000012663605160010472 5ustar dgp771divitk3.4/aclocal.m40000664003604700454610000000004212453237753012336 0ustar dgp771divbuiltin(include,tclconfig/tcl.m4) itk3.4/Makefile.in0000664003604700454610000003623112632343222012540 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 should need to be changed. # Please check the TARGETS section below to make sure the make targets # are correct. #======================================================================== itk_LIB_FILE = @itk_LIB_FILE@ itkstub_LIB_FILE = @itkstub_LIB_FILE@ itclstub_LIB_FILE = @itclstub_LIB_FILE@ #======================================================================== # Add additional lines to handle any additional AC_SUBST cases that # have been added to the configure script. #======================================================================== ITK_GENERIC_DIR_NATIVE = @ITK_GENERIC_DIR_NATIVE@ ITK_UNIX_DIR_NATIVE = @ITK_UNIX_DIR_NATIVE@ ITK_WIN_DIR_NATIVE = @ITK_WIN_DIR_NATIVE@ #======================================================================== # 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) 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 = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_VERSION = @PACKAGE_VERSION@ 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@ TK_SRC_DIR = @TK_SRC_DIR@ TK_BIN_DIR = @TK_BIN_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):$(TK_BIN_DIR) TCLSH_ENV = TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` \ TK_LIBRARY=`@CYGPATH@ $(TK_SRC_DIR)/library` \ ITCL_LIBRARY=`@CYGPATH@ @itcl_SRC_DIR@/library` \ ITK_LIBRARY=`@CYGPATH@ $(srcdir)/library` \ @LD_LIBRARY_PATH_VAR@="$(EXTRA_PATH):$(@LD_LIBRARY_PATH_VAR@)" \ PATH="$(EXTRA_PATH):$(PATH)" \ TCLLIBPATH="$(top_builddir) @itcl_BIN_DIR@" TCLSH_PROG = @TCLSH_PROG@ WISH_PROG = @WISH_PROG@ TCLSH = $(TCLSH_ENV) $(TCLSH_PROG) WISH = $(TCLSH_ENV) $(WISH_PROG) INCLUDES = @PKG_INCLUDES@ @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@ PKG_CFLAGS = @PKG_CFLAGS@ DEFS = @DEFS@ $(PKG_CFLAGS) \ -DITK_LIBRARY=\"$(pkglibdir)\" -DUSE_NON_CONST CONFIG_CLEAN_FILES = @CONFIG_CLEAN_FILES@ Makefile itkConfig.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 @mkdir -p $(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 @mkdir -p $(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 $(WISH) `@CYGPATH@ $(srcdir)/tests/all.tcl` -load "package require Itk $(PACKAGE_VERSION)" $(TESTFLAGS) | cat shell: binaries libraries @$(WISH) $(SCRIPT) gdb: $(TCLSH_ENV) gdb $(WISH_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)/src/win/exampleA.c # $(COMPILE) -c `@CYGPATH@ $(srcdir)/src/win/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 #COMPRESS = tar cvf $(PKG_DIR).tar $(PKG_DIR); compress $(PKG_DIR).tar COMPRESS = $(TAR) zcvf $(PKG_DIR).tar.gz $(PKG_DIR) DIST_ROOT = /tmp/dist DIST_DIR = $(DIST_ROOT)/$(PKG_DIR) dist-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='demos doc examples 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: @mkdir -p $(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) itkConfig.sh $(DESTDIR)$(libdir) #======================================================================== # Install binary executables (e.g. .exe files) # # You should not have to modify this target. #======================================================================== install-bin-binaries: @mkdir -p $(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: itk3.4/tests/0000755003604700454610000000000012663605160011634 5ustar dgp771divitk3.4/tests/defs0000644003604700454610000002504112453243363012502 0ustar dgp771div# This file contains support code for the Tcl test suite. It is # normally sourced by the individual files in the test suite before # they run their tests. This improved approach to testing was designed # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. # # Copyright (c) 1990-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------ # THIS SCRIPT IS NOW DEPRECATED! It is kept for older Tcl # installations that don't have the "tcltest" package. # Instead, use "package require tcltest" in the test suite. # ------------------------------------------------------------------ if ![info exists VERBOSE] { set VERBOSE 0 } if ![info exists TESTS] { set TESTS {} } # If tests are being run as root, issue a warning message and set a # variable to prevent some tests from running at all. set user {} if {$tcl_platform(platform) == "unix"} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } if {$user == ""} {set user root} if {$user == "root"} { puts stdout "Warning: you're executing as root. I'll have to" puts stdout "skip some of the tests, since they'll fail as root." } } # Some of the tests don't work on some system configurations due to # differences in word length, file system configuration, etc. In order # to prevent false alarms, these tests are generally only run in the # master development directory for Tcl. The presence of a file # "doAllTests" in this directory is used to indicate that the non-portable # tests should be run. set doNonPortableTests [file exists doAllTests] # If there is no "memory" command (because memory debugging isn't # enabled), generate a dummy command that does nothing. if {[info commands memory] == ""} { proc memory args {} } # Check configuration information that will determine which tests # to run. To do this, create an array testConfig. Each element # has a 0 or 1 value, and the following elements are defined: # unixOnly - 1 means this is a UNIX platform, so it's OK # to run tests that only work under UNIX. # macOnly - 1 means this is a Mac platform, so it's OK # to run tests that only work on Macs. # pcOnly - 1 means this is a PC platform, so it's OK to # run tests that only work on PCs. # unixOrPc - 1 means this is a UNIX or PC platform. # macOrPc - 1 means this is a Mac or PC platform. # macOrUnix - 1 means this is a Mac or UNIX platform. # nonPortable - 1 means this the tests are being running in # the master Tcl/Tk development environment; # Some tests are inherently non-portable because # they depend on things like word length, file system # configuration, window manager, etc. These tests # are only run in the main Tcl development directory # where the configuration is well known. The presence # of the file "doAllTests" in this directory indicates # that it is safe to run non-portable tests. # tempNotPc - The inverse of pcOnly. This flag is used to # temporarily disable a test. # nonBlockFiles - 1 means this platform supports setting files into # nonblocking mode. # asyncPipeClose- 1 means this platform supports async flush and # async close on a pipe. # unixExecs - 1 means this machine has commands such as 'cat', # 'echo' etc available. package require Itk catch {unset testConfig} if {$tcl_platform(platform) == "unix"} { set testConfig(unixOnly) 1 set testConfig(tempNotPc) 1 } else { set testConfig(unixOnly) 0 } if {$tcl_platform(platform) == "macintosh"} { set testConfig(tempNotPc) 1 set testConfig(macOnly) 1 } else { set testConfig(macOnly) 0 } if {$tcl_platform(platform) == "windows"} { set testConfig(pcOnly) 1 } else { set testConfig(pcOnly) 0 } set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)] set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)] set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)] set testConfig(nonPortable) [file exists doAllTests] set f [open defs r] if {[expr [catch {fconfigure $f -blocking off}]] == 0} { set testConfig(nonBlockFiles) 1 } else { set testConfig(nonBlockFiles) 0 } close $f # Test for SCO Unix - cannot run async flushing tests because a potential # problem with select is apparently interfering. (Mark Diekhans). if {$tcl_platform(platform) == "unix"} { if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} { set testConfig(asyncPipeClose) 0 } else { set testConfig(asyncPipeClose) 1 } } else { set testConfig(asyncPipeClose) 1 } # Test to see if execed commands such as cat, echo, rm and so forth are # present on this machine. set testConfig(unixExecs) 1 if {$tcl_platform(platform) == "macintosh"} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && ($tcl_platform(platform) == "windows")} { if {[catch {exec cat defs}] == 1} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && ([catch {exec echo hello}] == 1)} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && \ ([catch {exec sh -c echo hello}] == 1)} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && ([catch {exec wc defs}] == 1)} { set testConfig(unixExecs) 0 } if {$testConfig(unixExecs) == 1} { exec echo hello > removeMe if {[catch {exec rm removeMe}] == 1} { set testConfig(unixExecs) 0 } } if {($testConfig(unixExecs) == 1) && ([catch {exec sleep 1}] == 1)} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && \ ([catch {exec fgrep unixExecs defs}] == 1)} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && ([catch {exec ps}] == 1)} { set testConfig(unixExecs) 0 } if {($testConfig(unixExecs) == 1) && \ ([catch {exec echo abc > removeMe}] == 0) && \ ([catch {exec chmod 644 removeMe}] == 1) && \ ([catch {exec rm removeMe}] == 0)} { set testConfig(unixExecs) 0 } else { catch {exec rm -f removeMe} } if {($testConfig(unixExecs) == 1) && \ ([catch {exec mkdir removeMe}] == 1)} { set testConfig(unixExecs) 0 } else { catch {exec rm -r removeMe} } if {$testConfig(unixExecs) == 0} { puts stdout "Warning: Unix-style executables are not available, so" puts stdout "some tests will be skipped." } } proc print_verbose {name description script code answer} { puts stdout "\n" puts stdout "==== $name $description" puts stdout "==== Contents of test case:" puts stdout "$script" if {$code != 0} { if {$code == 1} { puts stdout "==== Test generated error:" puts stdout $answer } elseif {$code == 2} { puts stdout "==== Test generated return exception; result was:" puts stdout $answer } elseif {$code == 3} { puts stdout "==== Test generated break exception" } elseif {$code == 4} { puts stdout "==== Test generated continue exception" } else { puts stdout "==== Test generated exception $code; message was:" puts stdout $answer } } else { puts stdout "==== Result was:" puts stdout "$answer" } } # test -- # This procedure runs a test and prints an error message if the # test fails. If VERBOSE has been set, it also prints a message # even if the test succeeds. The test will be skipped if it # doesn't match the TESTS variable, or if one of the elements # of "constraints" turns out not to be true. # # Arguments: # name - Name of test, in the form foo-1.2. # description - Short textual description of the test, to # help humans understand what it does. # constraints - A list of one or more keywords, each of # which must be the name of an element in # the array "testConfig". If any of these # elements is zero, the test is skipped. # This argument may be omitted. # script - Script to run to carry out the test. It must # return a result that can be checked for # correctness. # answer - Expected result from script. proc test {name description script answer args} { global VERBOSE TESTS testConfig if {[string compare $TESTS ""] != 0} then { set ok 0 foreach test $TESTS { if [string match $test $name] then { set ok 1 break } } if !$ok then return } set i [llength $args] if {$i == 0} { # Empty body } elseif {$i == 1} { # "constraints" argument exists; shuffle arguments down, then # make sure that the constraints are satisfied. set constraints $script set script $answer set answer [lindex $args 0] foreach constraint $constraints { if {![info exists testConfig($constraint)] || !$testConfig($constraint)} { return } } } else { error "wrong # args: must be \"test name description ?constraints? script answer\"" } memory tag $name set code [catch {uplevel $script} result] if {$code != 0} { print_verbose $name $description $script \ $code $result } elseif {[string compare $result $answer] == 0} then { if $VERBOSE then { if {$VERBOSE > 0} { print_verbose $name $description $script \ $code $result } puts stdout "++++ $name PASSED" } } else { print_verbose $name $description $script \ $code $result puts stdout "---- Result should have been:" puts stdout "$answer" puts stdout "---- $name FAILED" } } proc dotests {file args} { global TESTS set savedTests $TESTS set TESTS $args source $file set TESTS $savedTests } proc normalizeMsg {msg} { regsub "\n$" [string tolower $msg] "" msg regsub -all "\n\n" $msg "\n" msg regsub -all "\n\}" $msg "\}" msg return $msg } proc makeFile {contents name} { set fd [open $name w] fconfigure $fd -translation lf if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { puts -nonewline $fd $contents } else { puts $fd $contents } close $fd } proc removeFile {name} { file delete $name } proc makeDirectory {name} { file mkdir $name } proc removeDirectory {name} { file delete -force $name } proc viewFile {name} { global tcl_platform testConfig if {($tcl_platform(platform) == "macintosh") || \ ($testConfig(unixExecs) == 0)} { set f [open $name] set data [read -nonewline $f] close $f return $data } else { exec cat $name } } # Locate tcltest executable set tcltest [list [info nameofexecutable]] if {$tcltest == "{}"} { set tcltest {} puts "Unable to find tcltest executable, multiple process tests will fail." } itk3.4/tests/interp.test0000644003604700454610000000332412632343337014041 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Make sure that slave interpreters can be created and loaded # with [incr Tcl] / [incr Tk]... # ---------------------------------------------------------------------- test interp-1.1 {create a slave interp with [incr Tk]} { interp create slave load "" Itcl slave load "" Tk slave load "" Itk slave list [slave eval "namespace children :: ::itk"] [interp delete slave] } {::itk {}} test interp-1.2 {can load [incr Tk] into a safe interp} { safe::interpCreate slave safe::loadTk slave load "" Itcl slave set result [list [catch {load "" Itk slave} msg] $msg] safe::interpDelete slave set result } {0 {}} test interp-1.3 {errors are okay when slave interp is deleted} { interp create slave load "" Itcl slave load "" Tk slave load "" Itk slave slave eval { label .l bind .l {error "dying!"} } interp delete slave } {} ::tcltest::cleanupTests exit itk3.4/tests/toplevel.test0000644003604700454610000001460212453243363014372 0ustar dgp771div# # Tests for [incr Tk] widgets based on itk::Toplevel # ---------------------------------------------------------------------- # 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Toplevel mega-widget # ---------------------------------------------------------------------- test toplevel-1.1 {define a toplevel mega-widget class} { option add *TestToplevel.background linen option add *TestToplevel.cursor "" option add *TestToplevel.foreground navy option add *TestToplevel.highlight white option add *TestToplevel.normal ivory option add *TestToplevel.text "" itcl::class TestToplevel { inherit itk::Toplevel constructor {args} { itk_component add test1 { label $itk_interior.t1 } { keep -background -foreground -cursor keep -text } pack $itk_component(test1) -side left -padx 2 eval itk_initialize $args } public method do {cmd} { eval $cmd } private variable status "" itk_option define -background background Background {} { lappend status "background: $itk_option(-background)" } } TestToplevel .#auto } {.testToplevel0} test toplevel-1.2 {check the list of configuration options} { .testToplevel0 configure } {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-menu menu Menu {} {}} {-takefocus takeFocus TakeFocus 0 0} {-text text Text {} {}} {-title title Title {} {}}} test toplevel-1.3 {check the list components} { lsort [.testToplevel0 component] } {hull test1} test toplevel-1.4 {check the propagation of configuration options} { .testToplevel0 configure -background red list [.testToplevel0 component hull cget -background] \ [.testToplevel0 component test1 cget -background] \ [.testToplevel0 do {set status}] } {red red {{background: linen} {background: red}}} test toplevel-1.5 {mega-widgets show up on the object list} { itcl::find objects .testToplevel* } {.testToplevel0} test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} { destroy .testToplevel0 itcl::find objects .testToplevel* } {} test toplevel-1.7 {when an mega-widget object is deleted, its window and any components are destroyed } { TestToplevel .delme set label [.delme component test1] itcl::delete object .delme list [winfo exists .delme] [winfo exists $label] } {0 0} test toplevel-1.8 {when a mega-widget object is deleted, its window and any components are destroyed (even if in another window) } { catch {destroy .t1} catch {destroy .t2} catch {rename .t2 {}} catch {itcl::delete class ButtonTop} itcl::class ButtonTop { inherit itk::Toplevel constructor {args} { eval itk_initialize $args itk_component add button { button $itk_option(-container).b -text Button } {} pack $itk_component(button) } itk_option define -container container Container {} } toplevel .t1 ButtonTop .t2 -container .t1 set button [.t2 component button] itcl::delete object .t2 set result [list $button [winfo exists $button]] itcl::delete class ButtonTop destroy .t1 set result } {.t1.b 0} test toplevel-1.9 {when a window that contains a megawidget component is destroyed, the component is removed from the megawidget} { catch {destroy .t1} catch {destroy .t2} catch {rename .t2 {}} catch {itcl::delete class ButtonTop} itcl::class ButtonTop { inherit itk::Toplevel constructor {args} { eval itk_initialize $args itk_component add button { button $itk_option(-container).b -text Button } {} pack $itk_component(button) } itk_option define -container container Container {} } toplevel .t1 ButtonTop .t2 -container .t1 set result [list [.t2 component]] destroy .t1 lappend result [list [.t2 component]] itcl::delete object .t2 itcl::delete class ButtonTop set result } {{button hull} hull} test toplevel-1.10 {when destroying a component that is inside another window protect against that case where one component destroy actually destroys other contained components} { catch {destroy .t1} catch {destroy .t2} catch {rename .t2 {}} catch {itcl::delete class ButtonTop} itcl::class ButtonTop { inherit itk::Toplevel constructor {args} { eval itk_initialize $args # Note, the component names matter here since # [.t2 component] returns names in hash order. # We need to delete cframe first since it # is the parent of cbutton. itk_component add cframe { button $itk_option(-container).cframe } {} pack $itk_component(cframe) itk_component add cbutton { button $itk_component(cframe).b -text Button } {} pack $itk_component(cbutton) } itk_option define -container container Container {} } toplevel .t1 ButtonTop .t2 -container .t1 set result [list [.t2 component]] # destructor should destroy cframe but not cbutton itcl::delete object .t2 lappend result [winfo exists .t1.cframe] destroy .t1 itcl::delete class ButtonTop set result } {{hull cframe cbutton} 0} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestToplevel ::tcltest::cleanupTests exit itk3.4/tests/option.test0000644003604700454610000001316412453243363014052 0ustar dgp771div# # Basic tests for [incr Tk] mega-widgets # ---------------------------------------------------------------------- # 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Component option processing # ---------------------------------------------------------------------- test option-1.1 {create a widget for the following tests} { itcl::class TestOptComp { inherit itk::Widget constructor {args} { itk_component add test1 { label $itk_interior.t1 } { keep -background -foreground -cursor keep -text } pack $itk_component(test1) -side left -padx 2 eval itk_initialize $args } private variable status "" public method action {info} { lappend status $info } public method do {cmd} { eval $cmd } itk_option define -status status Status {} { lappend status $itk_option(-status) } } itcl::class TestOptWidget { inherit itk::Widget constructor {args} { itk_component add test1 { label $itk_interior.t1 } { keep -background -foreground -cursor keep -text } pack $itk_component(test1) -side left -padx 2 eval itk_initialize $args } public method do {cmd} { eval $cmd } } TestOptWidget .#auto } {.testOptWidget0} test option-1.2 {"keep" can be called more than once} { .testOptWidget0 do { itk_component add k0 { TestOptComp $itk_interior.k0 -status "create" } { keep -background -foreground -cursor keep -background -foreground -cursor keep -status keep -status } pack $itk_component(k0) } .testOptWidget0 configure -status "foo" .testOptWidget0 component k0 do {set status} } {create foo} test option-1.3 {"rename" can be called more than once} { .testOptWidget0 do { itk_component add k1 { TestOptComp $itk_interior.k1 -status "create" } { rename -status -test test Test rename -status -test test Test } pack $itk_component(k1) } .testOptWidget0 configure -test "bar" .testOptWidget0 component k1 do {set status} } {create bar} test option-1.4 {"ignore" overrides keep and rename} { .testOptWidget0 do { itk_component add k2 { TestOptComp $itk_interior.k2 -status "create" } { keep -status rename -status -test test Test ignore -status } pack $itk_component(k2) } .testOptWidget0 configure -status k2 -test k2 .testOptWidget0 component k2 do {set status} } {create foo bar} # ---------------------------------------------------------------------- # Option processing with "usual" command # ---------------------------------------------------------------------- test option-2.1 {create a widget for the following tests} { TestOptComp .testUsual } {.testUsual} test option-2.2 {register some "usual" code} { itk::usual TestOptComp-test {keep -cursor -foreground} } {} test option-2.3 {query back "usual" code} { itk::usual TestOptComp-test } {keep -cursor -foreground} test option-2.4 {query back unknown "usual" code} { itk::usual xyzzyxyzzy } {} test option-2.5 {add a component using "usual" code} { .testUsual do { itk_component add u0 { label $itk_interior.u0 -text "Usual Test #0" } { usual TestOptComp-test } pack $itk_component(u0) } .testUsual configure -foreground green -cursor gumby list [.testUsual component u0 cget -foreground] \ [.testUsual component u0 cget -cursor] } {green gumby} test option-2.6 {override "usual" options} { .testUsual do { itk_component add u1 { label $itk_interior.u1 -text "Usual Test #1" } { usual TestOptComp-test ignore -cursor keep -background } pack $itk_component(u1) } .testUsual configure -foreground red -background white -cursor dot list [.testUsual component u1 cget -foreground] \ [.testUsual component u1 cget -background] \ [.testUsual component u1 cget -cursor] } {red white gumby} set unique 0 foreach widget {button canvas checkbutton entry frame label listbox menu menubutton message radiobutton scale scrollbar text toplevel} { set name "c[incr unique]" test option-2.7.$name {verify "usual" options for all Tk widgets} { .testUsual do [format { itk_component add %s { %s $itk_interior.%s } } $name $widget $name] } $name } # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestOptComp TestOptWidget ::tcltest::cleanupTests exit itk3.4/tests/public.test0000644003604700454610000000576412453243363014027 0ustar dgp771div# # Public variables as configuration options # ---------------------------------------------------------------------- # 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Define a base class with public variables and a simple mega-widget # ---------------------------------------------------------------------- test public-1.1 {define base class and simple mega-widget class} { itcl::class test_public_base { public variable null public variable background "not used" public variable message } itcl::configbody test_public_base::message { global ::test_public_status lappend test_public_status "message: $message" } itcl::configbody test_public_base::background { global ::test_public_status lappend test_public_status "background: $background" } option add *TestPublic.background red option add *TestPublic.foreground white option add *TestPublic.cursor trek option add *TestPublic.message "Hello, World!" itcl::class TestPublic { inherit itk::Widget test_public_base constructor {args} { itk_component add mesg { label $itk_interior.mesg } { keep -background -foreground -cursor rename -text -message message Message } pack $itk_component(mesg) -side left -padx 2 eval itk_initialize $args } } set testobj [TestPublic .#auto] pack $testobj } {} test public-1.2 {check the list of configuration options} { $testobj configure } {{-background background Background red red} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor trek trek} {-foreground foreground Foreground white white} {-message message Message {Hello, World!} {Hello, World!}} {-null {} {} {} {}}} test public-1.3 {uninitialized public variables are set to ""} { $testobj info variable null } {public variable ::test_public_base::null {} {}} test public-1.4 {config code gets fired off} { set test_public_status "" $testobj configure -background blue -message "All Clear" set test_public_status } {{background: blue} {message: All Clear}} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestPublic test_public_base ::tcltest::cleanupTests exit itk3.4/tests/all0000644003604700454610000000122612453243363012330 0ustar dgp771div# This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all" when running tclTest # in this directory. # ------------------------------------------------------------------ # THIS SCRIPT IS NOW DEPRECATED! It is kept for older Tcl # installations that don't have the "tcltest" package. # Instead, use the "all.tcl" script to run the test suite. # ------------------------------------------------------------------ foreach i [lsort [glob *.test]] { if [string match l.*.test $i] { # This is an SCCS lock file; ignore it. continue } puts stdout $i if [catch {source $i} msg] { puts $msg } } itk3.4/tests/widget.test0000644003604700454610000003264312453243363014030 0ustar dgp771div# # Tests for [incr Tk] widgets based on itk::Widget # ---------------------------------------------------------------------- # 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Simple mega-widget # ---------------------------------------------------------------------- test widget-1.1 {define a simple mega-widget class} { option add *TestWidget.background linen option add *TestWidget.borderWidth 2 option add *TestWidget.command "" option add *TestWidget.cursor "" option add *TestWidget.foreground navy option add *TestWidget.highlight white option add *TestWidget.normal ivory option add *TestWidget.text "" itcl::class TestWidget { inherit itk::Widget constructor {args} { itk_component add test1 { label $itk_interior.t1 } { keep -background -foreground -cursor keep -text } pack $itk_component(test1) -side left -padx 2 itk_component add test2 { button $itk_interior.t2 -text "Push Me" } { keep -foreground -cursor -borderwidth -command rename -background -normal normal Background rename -activebackground -highlight highlight Foreground } pack $itk_component(test2) -side right -fill x -pady 2 eval itk_initialize $args } private variable status "" public method action {info} { lappend status $info } public method do {cmd} { eval $cmd } itk_option define -status status Status {} { lappend status $itk_option(-status) } } TestWidget .#auto } {.testWidget0} pack .testWidget0 test widget-1.2 {check the list of configuration options} { .testWidget0 configure } {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} set unique 0 foreach test { {-background {-background background Background linen linen}} {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}} {-clientdata {-clientdata clientData ClientData {} {}}} {-command {-command command Command {} {}}} {-cursor {-cursor cursor Cursor {} {}}} {-foreground {-foreground foreground Foreground navy navy}} {-highlight {-highlight highlight Foreground white white}} {-normal {-normal normal Background ivory ivory}} {-status {-status status Status {} {}}} {-text {-text text Text {} {}}} } { set opt [lindex $test 0] set result [lindex $test 1] test widget-1.3.[incr unique] {check individual configuration options} { .testWidget0 configure $opt } $result } set unique 0 foreach test { {-background red} {-borderwidth 1} {-clientdata "foo bar"} {-command {puts "hello!"}} {-cursor trek} {-foreground IndianRed} {-highlight MistyRose} {-normal MistyRose2} {-status "test message"} {-text "Label:"} } { set opt [lindex $test 0] set value [lindex $test 1] test widget-1.4.[incr unique] {set individual configuration options} { list [.testWidget0 configure $opt $value] \ [.testWidget0 cget $opt] \ [.testWidget0 do "set itk_option($opt)"] } [list "" $value $value] } test widget-1.5 {check the list components} { lsort [.testWidget0 component] } {hull test1 test2} set unique 0 foreach test { {hull .testWidget0} {test1 .testWidget0.t1} {test2 .testWidget0.t2} } { set name [lindex $test 0] set win [lindex $test 1] test widget-1.6 {check the window for each component} { list [.testWidget0 component $name] \ [.testWidget0 do "set itk_component($name)"] } [list $win $win] } test widget-1.7 {check the propagation of configuration options} { list [.testWidget0 component hull cget -cursor] \ [.testWidget0 component test1 cget -cursor] \ [.testWidget0 component test2 cget -cursor] } {trek trek trek} test widget-1.8 {check the propagation of configuration options} { list [.testWidget0 component hull cget -background] \ [.testWidget0 component test1 cget -background] \ [.testWidget0 component test2 cget -background] } {red red MistyRose2} test widget-1.9 {check the propagation of configuration options} { list [.testWidget0 component test1 cget -text] \ [.testWidget0 component test2 cget -text] } {Label: {Push Me}} test widget-1.10 {check the invocation of "config" code} { .testWidget0 do {set status} } {{} {test message}} test widget-1.11a {configure using the "code" command} { .testWidget0 do {configure -command [itcl::code $this action "button press"]} .testWidget0 cget -command } {namespace inscope ::TestWidget {::.testWidget0 action {button press}}} test widget-1.11b {execute some code created by "code" command} { .testWidget0 do {set status ""} .testWidget0 component test2 invoke .testWidget0 configure -status "in between" .testWidget0 component test2 invoke .testWidget0 do {set status} } {{button press} {in between} {button press}} test widget-1.12a {components can be added on the fly} { .testWidget0 do { itk_component add test3 { label $itk_interior.t3 -text "Temporary" } { keep -background -foreground -cursor } } } {test3} test widget-1.12b {components can be added on the fly} { .testWidget0 do { pack $itk_component(test3) -fill x } } {} test widget-1.13 {new components show up on the component list} { lsort [.testWidget0 component] } {hull test1 test2 test3} test widget-1.14 {new components are initialized properly} { list [.testWidget0 component test3 cget -background] \ [.testWidget0 component test3 cget -foreground] \ [.testWidget0 component test3 cget -cursor] } {red IndianRed trek} test widget-1.15 {components can be deleted like ordinary widgets} { destroy [.testWidget0 component test3] } {} test widget-1.16 {dead components are removed from the component list} { lsort [.testWidget0 component] } {hull test1 test2} test widget-1.17 {use "configbody" command to change "config" code} { itcl::configbody TestWidget::status {lappend status "new"} } {} test widget-1.18 {"config" code can really change} { .testWidget0 do {set status ""} .testWidget0 configure -status "test message" .testWidget0 configure -status "another" .testWidget0 do {set status} } {new new} test widget-1.19 {"config" code can change back} { itcl::configbody TestWidget::status {lappend status $itk_option(-status)} } {} test widget-1.20 {mega-widgets show up on the object list} { itcl::find objects .testWidget* } {.testWidget0} test widget-1.21 {when a mega-widget is destroyed, its object is deleted} { destroy .testWidget0 itcl::find objects .testWidget* } {} test widget-1.22 {recreate a test widget} { TestWidget .testWidget0 itcl::find objects .testWidget* } {.testWidget0} test widget-1.23 {when an object is deleted the widget is destroyed} { itcl::delete object .testWidget0 winfo exists .testWidget0 } {0} test widget-1.24 {recreate another test widget} { TestWidget .testWidget } {.testWidget} test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} { list [lsort [.testWidget component]] \ [.testWidget configure] \ [catch {destroy [.testWidget component test1]}] \ [.testWidget component] \ [.testWidget do {return [lsort [array names itk_component]]}] \ [.testWidget configure] } {{hull test1 test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 0 {hull test2} {hull test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}}}} test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} { set comp [.testWidget component test2] list [bindtags $comp] \ [bind itk-destroy-$comp ] \ [catch {.testWidget do {itk_component delete test2}}] \ [bindtags $comp] \ [bind itk-destroy-$comp ] \ [.testWidget configure] } {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}} test widget-1.27 {when a mega-widget object is deleted, its window and any components are destroyed (even if in another window) } { catch {destroy .t1} catch {rename .t1.bw {}} catch {itcl::delete class ButtonWidget} itcl::class ButtonWidget { inherit itk::Widget constructor {args} { eval itk_initialize $args itk_component add button { button $itk_option(-container).b -text Button } {} pack $itk_component(button) } itk_option define -container container Container {} } toplevel .t1 frame .t1.f ButtonWidget .t1.bw -container .t1.f pack .t1.f pack .t1.bw set button [.t1.bw component button] itcl::delete object .t1.bw set result [list $button [winfo exists $button]] destroy .t1 itcl::delete class ButtonWidget set result } {.t1.f.b 0} test widget-1.28 {when a window that contains a megawidget component is destroyed, the component is removed from the megawidget} { catch {destroy .t1} catch {rename .t1.bw {}} catch {itcl::delete class ButtonWidget} itcl::class ButtonWidget { inherit itk::Widget constructor {args} { eval itk_initialize $args itk_component add button { button $itk_option(-container).b -text Button } {} pack $itk_component(button) } itk_option define -container container Container {} } toplevel .t1 frame .t1.f ButtonWidget .t1.bw -container .t1.f pack .t1.f pack .t1.bw set result [list [.t1.bw component]] destroy .t1.f lappend result [list [.t1.bw component]] itcl::delete object .t1.bw destroy .t1 itcl::delete class ButtonWidget set result } {{button hull} hull} test widget-1.29 {when destroying a component that is inside another window protect against that case where one component destroy actually destroys other contained components} { catch {destroy .t1} catch {rename .t1.bw {}} catch {itcl::delete class ButtonWidget} itcl::class ButtonWidget { inherit itk::Widget constructor {args} { eval itk_initialize $args # Note, the component names matter here since # [.t2 component] returns names in hash order. # We need to delete cframe first since it # is the parent of cbutton. itk_component add cframe { button $itk_option(-container).cframe } {} pack $itk_component(cframe) itk_component add cbutton { button $itk_component(cframe).b -text Button } {} pack $itk_component(cbutton) } itk_option define -container container Container {} } toplevel .t1 frame .t1.f ButtonWidget .t1.bw -container .t1.f pack .t1.f pack .t1.bw set result [list [.t1.bw component]] # destructor should destroy cframe but not cbutton itcl::delete object .t1.bw lappend result [winfo exists .t1.f.cframe] destroy .t1 itcl::delete class ButtonWidget set result } {{hull cframe cbutton} 0} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestWidget ::tcltest::cleanupTests exit itk3.4/tests/privacy.test0000644003604700454610000000703612453243363014220 0ustar dgp771div# # Privacy options for components # ---------------------------------------------------------------------- # 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 namespace import -force ::tcltest::* ::tcltest::loadTestedCommands # ---------------------------------------------------------------------- # Define a base class with public variables and a simple mega-widget # ---------------------------------------------------------------------- test privacy-1.1 {define simple mega-widget class} { itcl::class TestPrivacy { inherit itk::Widget constructor {args} { eval itk_initialize $args } method do {args} { return [eval $args] } } set testobj [TestPrivacy .#auto] pack $testobj } {} test privacy-1.2 {"itk_component add" requires certain arguments} { list [catch {$testobj do itk_component add foo} msg] $msg \ [catch {$testobj do itk_component add foo bar baz qux} msg] $msg } {1 {wrong # args: should be "itk_component add ?-protected? ?-private? ?--? name createCmds ?optionCmds?"} 1 {wrong # args: should be "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?}} test privacy-1.3 {"itk_component add" rejects invalid options} { list [catch { $testobj do itk_component add -foo bar baz qux } msg] $msg \ [catch { $testobj do itk_component add -- -foo {label $itk_interior.l} } msg] $msg } {1 {bad option "-foo": should be -private, -protected or --} 0 -foo} test privacy-1.4 {"itk_component add" recognizes privacy options} { list [catch { $testobj do itk_component add -protected x {label $itk_interior.x} } msg] $msg \ [catch { $testobj do itk_component add -private y {label $itk_interior.y} } msg] $msg } {0 x 0 y} test privacy-1.5 {protected/private components are hidden} { list [lsort [$testobj component]] \ [lsort [$testobj do component]] } {{-foo hull} {-foo hull x y}} test privacy-1.6 {define a derived class and add protected/private comps} { itcl::class TestMorePrivacy { inherit TestPrivacy constructor {args} { eval itk_initialize $args } method do {args} { return [eval $args] } } set testobj2 [TestMorePrivacy .#auto] $testobj2 TestPrivacy::do itk_component add -private x { label $itk_interior.x } $testobj2 TestPrivacy::do itk_component add -protected y { label $itk_interior.y } $testobj2 TestPrivacy::do itk_component add z { label $itk_interior.z } } {z} test privacy-1.7 {components are visible depending on namespace context} { list [lsort [$testobj2 component]] \ [lsort [$testobj2 do component]] \ [lsort [$testobj2 TestPrivacy::do component]] } {{hull z} {hull y z} {hull x y z}} # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestPrivacy TestMorePrivacy ::tcltest::cleanupTests exit itk3.4/tests/all.tcl0000755003604700454610000000053412453243363013115 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 tcltest 2.1 tcltest::testsDirectory [file dir [info script]] tcltest::runAllTests return itk3.4/library/0000755003604700454610000000000012663605160012136 5ustar dgp771divitk3.4/library/Archetype.itk0000644003604700454610000000657512464663567014626 0ustar dgp771div# # itk::Archetype # ---------------------------------------------------------------------- # Base class for all widgets in the [incr Tk] Toolkit. Provides # facilities to merge widget options into a composite list of options # for the overall widget. Derived classes add widgets and methods to # specialize behavior. # # METHODS: # configure # configure -option # configure -option value ?-option value?... # Used to set/query configuration options # # component # component ? ...? # Invokes the given as a method on the component # called . # # itk_component add # Creates a component widget and merges its options into # the composite option list for the overall widget # # itk_component delete ?...? # Destroys a component widget and removes its options from # the composite option list # # itk_option add ?...? # Adds the option belonging to a class or component # widget into the option list. Options can be added even # if they were not originally kept when the component was # created. # # itk_option remove ?...? # Removes the option belonging to a class or component # widget from the option list. This allows a derived class # to turn off or redefine undesirable options inherited from # a base class. # # WIDGET ATTRIBUTES: # none # # ---------------------------------------------------------------------- # 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. itcl::class itk::Archetype { constructor {args} { _initOptionInfo eval itk_initialize $args } destructor { _deleteOptionInfo } method cget {option} @Archetype-cget method configure {{option ""} args} \ @Archetype-configure method config {{option ""} args} { eval configure $option $args } method component {{name ""} args} \ @Archetype-component protected method itk_component {option args} \ @Archetype-itk_component protected method itk_option {option args} \ @Archetype-itk_option protected method itk_initialize {args} \ @Archetype-itk_initialize protected variable itk_option protected variable itk_component protected variable itk_interior "" # ------------------------------------------------------------------ # Options common to all widgets # ------------------------------------------------------------------ itk_option define -clientdata clientData ClientData "" # ------------------------------------------------------------------ # Private methods needed for option management # ------------------------------------------------------------------ private method _initOptionInfo {} @Archetype-init private method _deleteOptionInfo {} @Archetype-delete } itk3.4/library/tclIndex0000644003604700454610000000110212435425502013622 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(::itk::Archetype) [list source [file join $dir Archetype.itk]] set auto_index(::itk::Toplevel) [list source [file join $dir Toplevel.itk]] set auto_index(::itk::Widget) [list source [file join $dir Widget.itk]] itk3.4/library/Widget.itk0000644003604700454610000000503012453243363014070 0ustar dgp771div# # itk::Widget # ---------------------------------------------------------------------- # Base class for ordinary widgets in the [incr Tk] Toolkit. Creates # a frame to contain the widget. Derived classes add widgets and # methods to specialize behavior. # # METHODS: # # WIDGET ATTRIBUTES: # switch: -background .... normal background color for widget # name: background # class: Background # # switch: -cursor ........ cursor used when pointer is inside # name: cursur widget # class: Cursur # # ---------------------------------------------------------------------- # 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. itcl::class itk::Widget { inherit itk::Archetype # ------------------------------------------------------------------ # CONSTRUCTOR # ------------------------------------------------------------------ constructor {args} { # # Create a window with the same name as this object # set itk_hull [namespace tail $this] set itk_interior $itk_hull itk_component add hull { frame $itk_hull -class [namespace tail [info class]] } { keep -background -cursor } bind itk-delete-$itk_hull [list itcl::delete object $this] set tags [bindtags $itk_hull] bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] eval itk_initialize $args } destructor { if {[winfo exists $itk_hull]} { set tags [bindtags $itk_hull] set i [lsearch $tags itk-delete-$itk_hull] if {$i >= 0} { bindtags $itk_hull [lreplace $tags $i $i] } destroy $itk_hull } itk_component delete hull set components [component] foreach component $components { set path($component) [component $component] } foreach component $components { if {[winfo exists $path($component)]} { destroy $path($component) } } } private variable itk_hull "" } itk3.4/library/itk.tcl0000644003604700454610000001216212462752125013434 0ustar dgp771div# # itk.tcl # ---------------------------------------------------------------------- # Invoked automatically upon startup to customize the interpreter # for [incr Tk]. # ---------------------------------------------------------------------- # 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. # # Provide transparent access to all [incr Tk] commands # if {$tcl_platform(os) == "MacOS"} { source -rsrc itk:tclIndex } else { lappend auto_path ${itk::library} } # ---------------------------------------------------------------------- # USAGE: itk::remove_destroy_hook # # Used internally via "itk_component delete" when disconnecting a # component from the mega-widget that contains it. # Each component has a special binding for the event # that causes it to disconnect itself from its parent when destroyed. # This procedure removes the binding from the binding tag list and # deletes the binding. It is much easier to implement this in # Tcl than C. # ---------------------------------------------------------------------- proc ::itk::remove_destroy_hook {widget} { if {![winfo exists $widget]} {return} set tags [bindtags $widget] set i [lsearch $tags "itk-destroy-$widget"] if {$i >= 0} { bindtags $widget [lreplace $tags $i $i] } bind itk-destroy-$widget {} } # # Define "usual" option-handling code for the Tk widgets: # itk::usual Button { keep -background -cursor -foreground -font keep -activebackground -activeforeground -disabledforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Canvas { keep -background -cursor keep -insertbackground -insertborderwidth -insertwidth keep -insertontime -insertofftime keep -selectbackground -selectborderwidth -selectforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Checkbutton { keep -background -cursor -foreground -font keep -activebackground -activeforeground -disabledforeground keep -selectcolor keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Entry { keep -background -cursor -foreground -font keep -insertbackground -insertborderwidth -insertwidth keep -insertontime -insertofftime keep -selectbackground -selectborderwidth -selectforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Frame { keep -background -cursor } itk::usual Label { keep -background -cursor -foreground -font keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Listbox { keep -background -cursor -foreground -font keep -selectbackground -selectborderwidth -selectforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Menu { keep -background -cursor -foreground -font keep -activebackground -activeforeground -disabledforeground keep -selectcolor -tearoff } itk::usual Menubutton { keep -background -cursor -foreground -font keep -activebackground -activeforeground -disabledforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Message { keep -background -cursor -foreground -font keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Radiobutton { keep -background -cursor -foreground -font keep -activebackground -activeforeground -disabledforeground keep -selectcolor keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Scale { keep -background -cursor -foreground -font -troughcolor keep -activebackground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Scrollbar { keep -background -cursor -troughcolor keep -activebackground -activerelief keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Text { keep -background -cursor -foreground -font keep -insertbackground -insertborderwidth -insertwidth keep -insertontime -insertofftime keep -selectbackground -selectborderwidth -selectforeground keep -highlightcolor -highlightthickness rename -highlightbackground -background background Background } itk::usual Toplevel { keep -background -cursor } itk3.4/library/Toplevel.itk0000644003604700454610000000507712453243363014452 0ustar dgp771div# # itk::Toplevel # ---------------------------------------------------------------------- # Base class for toplevel windows in the [incr Tk] Toolkit. Creates # a new toplevel window to contain the widget. Derived classes add # widgets and methods to specialize behavior. # # WIDGET ATTRIBUTES: # switch: -background .... normal background color for widget # name: background # class: Background # # switch: -cursor ........ cursor for widget # name: cursor # class: Cursor # # switch: -title ......... title given to window manager # name: title # class: Title # # ---------------------------------------------------------------------- # 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. itcl::class itk::Toplevel { inherit itk::Archetype constructor {args} { # # Create a toplevel window with the same name as this object # set itk_hull [namespace tail $this] set itk_interior $itk_hull itk_component add hull { toplevel $itk_hull -class [namespace tail [info class]] } { keep -menu -background -cursor -takefocus } bind itk-delete-$itk_hull [list itcl::delete object $this] set tags [bindtags $itk_hull] bindtags $itk_hull [linsert $tags 0 itk-delete-$itk_hull] eval itk_initialize $args } destructor { if {[winfo exists $itk_hull]} { set tags [bindtags $itk_hull] set i [lsearch $tags itk-delete-$itk_hull] if {$i >= 0} { bindtags $itk_hull [lreplace $tags $i $i] } destroy $itk_hull } itk_component delete hull set components [component] foreach component $components { set path($component) [component $component] } foreach component $components { if {[winfo exists $path($component)]} { destroy $path($component) } } } itk_option define -title title Title "" { wm title $itk_hull $itk_option(-title) } private variable itk_hull "" } itk3.4/library/Archetype.itk.orig0000644003604700454610000000657512463245026015546 0ustar dgp771div# # itk::Archetype # ---------------------------------------------------------------------- # Base class for all widgets in the [incr Tk] Toolkit. Provides # facilities to merge widget options into a composite list of options # for the overall widget. Derived classes add widgets and methods to # specialize behavior. # # METHODS: # configure # configure -option # configure -option value ?-option value?... # Used to set/query configuration options # # component # component ? ...? # Invokes the given as a method on the component # called . # # itk_component add # Creates a component widget and merges its options into # the composite option list for the overall widget # # itk_component delete ?...? # Destroys a component widget and removes its options from # the composite option list # # itk_option add ?...? # Adds the option belonging to a class or component # widget into the option list. Options can be added even # if they were not originally kept when the component was # created. # # itk_option remove ?...? # Removes the option belonging to a class or component # widget from the option list. This allows a derived class # to turn off or redefine undesirable options inherited from # a base class. # # WIDGET ATTRIBUTES: # none # # ---------------------------------------------------------------------- # 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. itcl::class itk::Archetype { constructor {args} { _initOptionInfo eval itk_initialize $args } destructor { _deleteOptionInfo } method cget {option} @Archetype-cget method configure {{option ""} args} \ @Archetype-configure method config {{option ""} args} { eval configure $option $args } method component {{name ""} args} \ @Archetype-component protected method itk_component {option args} \ @Archetype-itk_component protected method itk_option {option args} \ @Archetype-itk_option protected method itk_initialize {args} \ @Archetype-itk_initialize protected variable itk_option protected variable itk_component protected variable itk_interior "" # ------------------------------------------------------------------ # Options common to all widgets # ------------------------------------------------------------------ itk_option define -clientdata clientData ClientData "" # ------------------------------------------------------------------ # Private methods needed for option management # ------------------------------------------------------------------ private method _initOptionInfo {} @Archetype-init private method _deleteOptionInfo {} @Archetype-delete } itk3.4/demos/0000755003604700454610000000000012663605160011601 5ustar dgp771divitk3.4/demos/README0000644003604700454610000000045612435425502012463 0ustar dgp771div DEMOS ------------------------------------------------------------------------ This directory contains some simple demos which show nifty things you can build using [incr Tk]: itkedit ......... Simple split-screen editor written with [incr Widgets] in ~220 lines of code! itk3.4/demos/itkedit0000644003604700454610000001637212435425502013167 0ustar dgp771div#!/bin/sh #\ exec wish8.4 "$0" # ====================================================================== # Simple text editor built with [incr Widgets] # ---------------------------------------------------------------------- # AUTHOR: Michael J. McLennan # CLASS: Object-Oriented Programming with [incr Tcl] # ====================================================================== package require Iwidgets 4.0 option add *edit.width 5i startupFile option add *edit.height 4i startupFile option add *Fileselectiondialog.width 4i startupFile option add *Fileselectiondialog.height 5i startupFile # ---------------------------------------------------------------------- set FileWindows 0 # ---------------------------------------------------------------------- # Dialog boxes # ---------------------------------------------------------------------- iwidgets::messagedialog .notice -title "itkedit: Notice" \ -bitmap info -buttonboxpos e -modality application .notice hide OK .notice hide Help .notice buttonconfigure Cancel -text "Dismiss" iwidgets::messagedialog .confirm -title "itkedit: Confirm" \ -bitmap questhead -modality application .confirm hide Help .confirm buttonconfigure OK -text "Yes" .confirm buttonconfigure Cancel -text "No" iwidgets::fileselectiondialog .files -title "itkedit: Files" \ -childsitepos s -modality application .files hide Help set PaneMenu "[.files childsite].panes" iwidgets::optionmenu $PaneMenu -labeltext "Edit Window:" pack $PaneMenu -pady 6 # ---------------------------------------------------------------------- # USAGE: file_load # # Initiates the process of loading a new text file for editing. # Pops up a Fileselectiondialog, allowing the user to select a # file for editing. If the user pushes the "load" button, the # file is loaded. # ---------------------------------------------------------------------- proc file_load {} { global FileName PaneMenu .files buttonconfigure OK -text "Load" if {[.files activate]} { set fname [.files get] set cmd { set fid [open $fname r] set text [read $fid] close $fid } if {[catch $cmd err] != 0} { .notice configure -bitmap error \ -text "Cannot load file \"$fname\":\n$err" .notice activate return } set pane [$PaneMenu get] set win [.edit childsite $pane] clear_text $win $win.text insert end $text $win.text configure -labeltext "file: $fname" set FileName($win) $fname } } # ---------------------------------------------------------------------- # USAGE: file_save_as # # Initiates the process of saving the current text into a particular # file. Pops up a Fileselectiondialog, allowing the user to select # a file for saving. If the user pushes the "save" button, the # file is saved. # ---------------------------------------------------------------------- proc file_save_as {} { global FileName PaneMenu .files buttonconfigure OK -text "Save" if {[.files activate]} { set pane [$PaneMenu get] set win [.edit childsite $pane] set FileName($win) [.files get] file_save $win } } # ---------------------------------------------------------------------- # USAGE: file_save # # Saves the context of into its associated file. Does the # dirty work to finish the file_save_as operation. # ---------------------------------------------------------------------- proc file_save {win} { global FileName FileChanged set cmd { set fid [open $FileName($win) w] puts $fid [$win.text get 1.0 end] close $fid set FileChanged($win) 0 $win.text configure -labeltext "file: $FileName($win)" } if {[catch $cmd err] != 0} { .notice configure -bitmap error \ -text "Cannot save file \"$FileName($win)\":\n$err" .notice activate } } # ---------------------------------------------------------------------- # USAGE: clear_text ?? # # Clears the text area associated with , making sure to save # any pending changes. If no is specified, then all text # areas are cleared. # ---------------------------------------------------------------------- proc clear_text {{areas ""}} { global FileName FileChanged FileWindows if {$areas == ""} { for {set i 0} {$i < $FileWindows} {incr i} { set pane "area #[expr $i+1]" lappend areas [.edit childsite $pane] } } foreach win $areas { if {$FileChanged($win)} { set fname [file tail $FileName($win)] .confirm configure -text "File \"$fname\" has changed.\nSave changes?" if {[.confirm activate]} { file_save $win } } $win.text delete 1.0 end set FileChanged($win) 0 } } # ---------------------------------------------------------------------- # USAGE: split_view # # Adds another editing pane to the current editor. # ---------------------------------------------------------------------- proc split_view {} { global FileName FileChanged FileWindows PaneMenu set pane "area #[incr FileWindows]" .edit add $pane -minimum 100 $PaneMenu insert end $pane set win [.edit childsite $pane] set FileName($win) untitled.txt set FileChanged($win) 0 iwidgets::scrolledtext $win.text -wrap none -labeltext "file: $FileName($win)" \ -hscrollmode none -vscrollmode dynamic -visibleitems 1x1 pack $win.text -expand yes -fill both bind [$win.text component text] " set FileChanged($win) 1 " } frame .mbar -borderwidth 2 -relief raised pack .mbar -side top -fill x # ---------------------------------------------------------------------- # FILE menu # ---------------------------------------------------------------------- menubutton .mbar.file -text "File" -underline 0 -menu .mbar.file.menu pack .mbar.file -side left -padx 4 menu .mbar.file.menu .mbar.file.menu add command -label "Load..." \ -accelerator " ^L" -underline 0 -command file_load bind . { .mbar.file.menu invoke "Load..." } .mbar.file.menu add command -label "Save As..." \ -accelerator " ^S" -underline 0 -command file_save_as bind . { .mbar.file.menu invoke "Save As..." } .mbar.file.menu add separator .mbar.file.menu add command -label "Quit" \ -accelerator " ^Q" -underline 0 -command {clear_text; exit} bind . { .mbar.file.menu invoke Quit } # ---------------------------------------------------------------------- # VIEW menu # ---------------------------------------------------------------------- menubutton .mbar.view -text "View" -underline 0 -menu .mbar.view.menu pack .mbar.view -side left -padx 4 menu .mbar.view.menu .mbar.view.menu add command -label "Split" \ -underline 0 -command split_view # ---------------------------------------------------------------------- # Editor # ---------------------------------------------------------------------- iwidgets::panedwindow .edit -orient horizontal pack .edit -expand yes -fill both split_view wm title . "itkedit" wm protocol . WM_DELETE_WINDOW { .mbar.file.menu invoke Quit } after idle { update idletasks wm minsize . [winfo reqwidth .] [winfo reqheight .] } itk3.4/generic/0000755003604700454610000000000012663605160012106 5ustar dgp771divitk3.4/generic/itkStubLib.c0000644003604700454610000000316312453243363014331 0ustar dgp771div/* * itkStubLib.c -- * * Stub object that will be statically linked into extensions that wish * to access Itk. * * Copyright (c) 1998-1999 by XXXX * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * We need to ensure that we use the stub macros so that this file contains * no references to any of the stub functions. This will make it possible * to build an extension that references Tcl_InitStubs but doesn't end up * including the rest of the stub functions. */ #ifndef USE_TCL_STUBS #define USE_TCL_STUBS #endif #undef USE_TCL_STUB_PROCS #ifndef USE_ITK_STUBS #define USE_ITK_STUBS #endif #undef USE_ITK_STUB_PROCS #include "itk.h" ItkStubs *itkStubsPtr; /* *---------------------------------------------------------------------- * * Itk_InitStubs -- * * Tries to initialise the stub table pointers and ensures that * the correct version of Itk is loaded. * * Results: * The actual version of Itk that satisfies the request, or * NULL to indicate that an error occurred. * * Side effects: * Sets the stub table pointers. * *---------------------------------------------------------------------- */ CONST char * Itk_InitStubs (interp, version, exact) Tcl_Interp *interp; CONST char *version; int exact; { CONST char *actualVersion; actualVersion = Tcl_PkgRequireEx(interp, "Itk", (CONST84 char *)version, exact, (ClientData *) &itkStubsPtr); if (actualVersion == NULL) { itkStubsPtr = NULL; return NULL; } return actualVersion; } itk3.4/generic/itk_archetype.c0000644003604700454610000041775012663605110015116 0ustar dgp771div/* * ------------------------------------------------------------------------ * PACKAGE: [incr Tk] * DESCRIPTION: Building mega-widgets with [incr Tcl] * * [incr Tk] provides a framework for building composite "mega-widgets" * using [incr Tcl] classes. It defines a set of base classes that are * specialized to create all other widgets. * * This part adds C implementations for some of the methods in the * base class itk::Archetype. * * Itk_ArchComponentCmd <=> itk_component * Itk_ArchOptionCmd <=> itk_option * Itk_ArchInitCmd <=> itk_initialize * Itk_ArchCompAccessCmd <=> component * Itk_ArchConfigureCmd <=> configure * Itk_ArchCgetCmd <=> cget * * Itk_ArchInitOptsCmd <=> _initOptionInfo (used to set things up) * Itk_ArchDeleteOptsCmd <=> _deleteOptionInfo (used to clean things up) * * ======================================================================== * 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 #include "itk.h" /* * Info associated with each Archetype mega-widget: */ typedef struct ArchInfo { ItclObject *itclObj; /* object containing this info */ Tk_Window tkwin; /* window representing this mega-widget */ Tcl_HashTable components; /* list of all mega-widget components */ Tcl_HashTable options; /* list of all mega-widget options */ ItkOptList order; /* gives ordering of options */ } ArchInfo; /* * Each component widget in an Archetype mega-widget: */ typedef struct ArchComponent { ItclMember *member; /* contains protection level for this comp */ Tcl_Command accessCmd; /* access command for component widget */ Tk_Window tkwin; /* Tk window for this component widget */ char *pathName; /* Tk path name for this component widget. We can't use the tkwin pointer after the window has been destroyed so we need to save a copy for use in Itk_ArchCompDeleteCmd() */ } ArchComponent; /* * Each option in an Archetype mega-widget: */ typedef struct ArchOption { char *switchName; /* command-line switch for this option */ char *resName; /* resource name in X11 database */ char *resClass; /* resource class name in X11 database */ char *init; /* initial value for option */ int flags; /* flags representing option state */ Itcl_List parts; /* parts relating to this option */ } ArchOption; /* * Flag bits for ArchOption state: */ #define ITK_ARCHOPT_INIT 0x01 /* option has been initialized */ /* * Various parts of a composite option in an Archetype mega-widget: */ typedef int (Itk_ConfigOptionPartProc) _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char* newVal)); typedef struct ArchOptionPart { ClientData clientData; /* data associated with this part */ Itk_ConfigOptionPartProc *configProc; /* update when new vals arrive */ Tcl_CmdDeleteProc *deleteProc; /* clean up after clientData */ ClientData from; /* token that indicates who * contributed this option part */ } ArchOptionPart; /* * Info kept by the itk::option-parser namespace and shared by * all option processing commands: */ typedef struct ArchMergeInfo { Tcl_HashTable usualCode; /* usual option handling code for the * various widget classes */ ArchInfo *archInfo; /* internal option info for mega-widget */ ArchComponent *archComp; /* component being merged into mega-widget */ Tcl_HashTable *optionTable; /* table of valid configuration options * for component being merged */ } ArchMergeInfo; /* * Used to capture component widget configuration options when a * new component is being merged into a mega-widget: */ typedef struct GenericConfigOpt { char *switchName; /* command-line switch for this option */ char *resName; /* resource name in X11 database */ char *resClass; /* resource class name in X11 database */ char *init; /* initial value for this option */ char *value; /* current value for this option */ char **storage; /* storage for above strings */ ArchOption *integrated; /* integrated into this mega-widget option */ ArchOptionPart *optPart; /* integrated as this option part */ } GenericConfigOpt; /* * Options that are propagated by a "configure" method: */ typedef struct ConfigCmdline { Tcl_Obj *objv[4]; /* objects representing "configure" command */ } ConfigCmdline; /* * FORWARD DECLARATIONS */ static void Itk_DelMergeInfo _ANSI_ARGS_((char* cdata)); static int Itk_ArchInitOptsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void Itk_DelArchInfo _ANSI_ARGS_((ClientData cdata)); static int Itk_ArchDeleteOptsCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchComponentCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompAddCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompDeleteCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptKeepCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptIgnoreCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptRenameCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptUsualCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchInitCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionAddCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchOptionRemoveCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCompAccessCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchConfigureCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_ArchCgetCmd _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int Itk_PropagateOption _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char *newval)); static int Itk_PropagatePublicVar _ANSI_ARGS_((Tcl_Interp *interp, ItclObject *contextObj, ClientData cdata, CONST char *newval)); static int Itk_ArchSetOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, CONST char *name, CONST char *value)); static int Itk_ArchConfigOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *name, char *value)); static void Itk_ArchOptConfigError _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt)); static void Itk_ArchOptAccessError _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt)); static int Itk_GetArchInfo _ANSI_ARGS_((Tcl_Interp *interp, ItclObject* contextObj, ArchInfo **infoPtr)); static ArchComponent* Itk_CreateArchComponent _ANSI_ARGS_(( Tcl_Interp *interp, ArchInfo *info, char *name, ItclClass *cdefn, Tcl_Command accessCmd)); static void Itk_DelArchComponent _ANSI_ARGS_((ArchComponent *archComp)); static int Itk_GetArchOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *switchName, char *resName, char *resClass, CONST char *defVal, char *currVal, ArchOption **aoPtr)); static void Itk_InitArchOption _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, ArchOption *archOpt, CONST char *defVal, char *currVal)); static void Itk_DelArchOption _ANSI_ARGS_((ArchOption *archOpt)); static ArchOptionPart* Itk_CreateOptionPart _ANSI_ARGS_(( Tcl_Interp *interp, ClientData cdata, Itk_ConfigOptionPartProc* cproc, Tcl_CmdDeleteProc *dproc, ClientData from)); static int Itk_AddOptionPart _ANSI_ARGS_((Tcl_Interp *interp, ArchInfo *info, char *switchName, char *resName, char *resClass, CONST char *defVal, char *currVal, ArchOptionPart *optPart, ArchOption **raOpt)); static ArchOptionPart* Itk_FindArchOptionPart _ANSI_ARGS_(( ArchInfo *info, char *switchName, ClientData from)); static int Itk_RemoveArchOptionPart _ANSI_ARGS_((ArchInfo *info, char *switchName, ClientData from)); static int Itk_IgnoreArchOptionPart _ANSI_ARGS_((ArchInfo *info, GenericConfigOpt *opt)); static void Itk_DelOptionPart _ANSI_ARGS_((ArchOptionPart *optPart)); static ConfigCmdline* Itk_CreateConfigCmdline _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_Command accessCmd, char *switchName)); static void Itk_DeleteConfigCmdline _ANSI_ARGS_((ClientData cdata)); static Tcl_HashTable* Itk_CreateGenericOptTable _ANSI_ARGS_((Tcl_Interp *interp, char *options)); static void Itk_DelGenericOptTable _ANSI_ARGS_((Tcl_HashTable *tPtr)); static GenericConfigOpt* Itk_CreateGenericOpt _ANSI_ARGS_((Tcl_Interp *interp, char *switchName, Tcl_Command accessCmd)); static void Itk_DelGenericOpt _ANSI_ARGS_((GenericConfigOpt* opt)); static Tcl_HashTable* ItkGetObjsWithArchInfo _ANSI_ARGS_((Tcl_Interp *interp)); static void ItkFreeObjsWithArchInfo _ANSI_ARGS_((ClientData cdata, Tcl_Interp *interp)); /* * ------------------------------------------------------------------------ * Itk_ArchetypeInit() * * Invoked by Itk_Init() whenever a new interpreter is created to * declare the procedures used in the itk::Archetype base class. * ------------------------------------------------------------------------ */ int Itk_ArchetypeInit(interp) Tcl_Interp *interp; /* interpreter to be updated */ { ArchMergeInfo *mergeInfo; Tcl_Namespace *parserNs; /* * Declare all of the C routines that are integrated into * the Archetype base class. */ if (Itcl_RegisterObjC(interp, "Archetype-init", Itk_ArchInitOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-delete", Itk_ArchDeleteOptsCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_component", Itk_ArchComponentCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_option", Itk_ArchOptionCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-itk_initialize", Itk_ArchInitCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-component", Itk_ArchCompAccessCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-configure",Itk_ArchConfigureCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK || Itcl_RegisterObjC(interp, "Archetype-cget",Itk_ArchCgetCmd, (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) { return TCL_ERROR; } /* * Create the namespace containing the option parser commands. */ mergeInfo = (ArchMergeInfo*)ckalloc(sizeof(ArchMergeInfo)); Tcl_InitHashTable(&mergeInfo->usualCode, TCL_STRING_KEYS); mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; mergeInfo->optionTable = NULL; parserNs = Tcl_CreateNamespace(interp, "::itk::option-parser", (ClientData)mergeInfo, Itcl_ReleaseData); if (!parserNs) { Itk_DelMergeInfo((char*)mergeInfo); Tcl_AddErrorInfo(interp, "\n (while initializing itk)"); return TCL_ERROR; } Itcl_PreserveData((ClientData)mergeInfo); Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo); Tcl_CreateObjCommand(interp, "::itk::option-parser::keep", Itk_ArchOptKeepCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore", Itk_ArchOptIgnoreCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::rename", Itk_ArchOptRenameCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); Tcl_CreateObjCommand(interp, "::itk::option-parser::usual", Itk_ArchOptUsualCmd, (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL); /* * Add the "itk::usual" command to register option handling code. */ Tcl_CreateObjCommand(interp, "::itk::usual", Itk_UsualCmd, (ClientData)mergeInfo, Itcl_ReleaseData); Itcl_PreserveData((ClientData)mergeInfo); return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_DelMergeInfo() * * Destroys the "merge" info record shared by commands in the * itk::option-parser namespace. Invoked automatically when the * namespace containing the parsing commands is destroyed and there * are no more uses of the data. * ------------------------------------------------------------------------ */ static void Itk_DelMergeInfo(cdata) char* cdata; /* data to be destroyed */ { ArchMergeInfo *mergeInfo = (ArchMergeInfo*)cdata; Tcl_HashEntry *entry; Tcl_HashSearch place; Tcl_Obj *codePtr; assert(mergeInfo->optionTable == NULL); entry = Tcl_FirstHashEntry(&mergeInfo->usualCode, &place); while (entry) { codePtr = (Tcl_Obj*)Tcl_GetHashValue(entry); Tcl_DecrRefCount(codePtr); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&mergeInfo->usualCode); ckfree((char*)mergeInfo); } /* * ------------------------------------------------------------------------ * Itk_ArchInitOptsCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::_initOptionInfo * method. This method should be called out in the constructor for * each object, to initialize the object so that it can be used with * the other access methods in this file. Allocates some extra * data associated with the object at the C-language level. * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchInitOptsCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int newEntry, result; ArchInfo *info; ItclClass *contextClass; ItclObject *contextObj; Tcl_HashTable *objsWithArchInfo; Tcl_HashEntry *entry; Command *cmdPtr; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot use \"", token, "\" without an object context", (char*)NULL); return TCL_ERROR; } /* * Create some archetype info for the current object and * register it on the list of all known objects. */ objsWithArchInfo = ItkGetObjsWithArchInfo(interp); info = (ArchInfo*)ckalloc(sizeof(ArchInfo)); info->itclObj = contextObj; info->tkwin = NULL; /* not known yet */ Tcl_InitHashTable(&info->components, TCL_STRING_KEYS); Tcl_InitHashTable(&info->options, TCL_STRING_KEYS); Itk_OptListInit(&info->order, &info->options); entry = Tcl_CreateHashEntry(objsWithArchInfo, (char*)contextObj, &newEntry); if (!newEntry) { Itk_DelArchInfo( Tcl_GetHashValue(entry) ); } Tcl_SetHashValue(entry, (ClientData)info); /* * Make sure that the access command for this object * resides in the global namespace. If need be, move * the command. */ result = TCL_OK; cmdPtr = (Command*)contextObj->accessCmd; if (cmdPtr->nsPtr != (Namespace*)Tcl_GetGlobalNamespace(interp)) { Tcl_Obj *oldNamePtr, *newNamePtr; oldNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, contextObj->accessCmd, oldNamePtr); Tcl_IncrRefCount(oldNamePtr); newNamePtr = Tcl_NewStringObj("::", -1); Tcl_AppendToObj(newNamePtr, Tcl_GetCommandName(interp, contextObj->accessCmd), -1); Tcl_IncrRefCount(newNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(oldNamePtr, (int*)NULL), Tcl_GetStringFromObj(newNamePtr, (int*)NULL)); Tcl_DecrRefCount(oldNamePtr); Tcl_DecrRefCount(newNamePtr); } return result; } /* * ------------------------------------------------------------------------ * Itk_DelArchInfo() * * Invoked when the option info associated with an itk::Archetype * widget is no longer needed. This usually happens when a widget * is destroyed. Frees the given bundle of data and removes it * from the global list of Archetype objects. * ------------------------------------------------------------------------ */ static void Itk_DelArchInfo(cdata) ClientData cdata; /* client data for Archetype objects */ { ArchInfo *info = (ArchInfo*)cdata; Tcl_HashEntry *entry; Tcl_HashSearch place; ArchOption *archOpt; ArchComponent *archComp; /* * Destroy all component widgets. */ entry = Tcl_FirstHashEntry(&info->components, &place); while (entry) { archComp = (ArchComponent*)Tcl_GetHashValue(entry); Itk_DelArchComponent(archComp); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&info->components); /* * Destroy all information associated with configuration options. */ entry = Tcl_FirstHashEntry(&info->options, &place); while (entry) { archOpt = (ArchOption*)Tcl_GetHashValue(entry); Itk_DelArchOption(archOpt); entry = Tcl_NextHashEntry(&place); } Tcl_DeleteHashTable(&info->options); Itk_OptListFree(&info->order); ckfree((char*)info); } /* * ------------------------------------------------------------------------ * Itk_ArchDeleteOptsCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::_deleteOptionInfo * method. This method should be called out in the destructor for each * object, to clean up data allocated by Itk_ArchInitOptsCmd(). * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchDeleteOptsCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { ItclClass *contextClass; ItclObject *contextObj; Tcl_HashTable *objsWithArchInfo; Tcl_HashEntry *entry; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { char *token = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot use \"", token, "\" without an object context", (char*)NULL); return TCL_ERROR; } /* * Find the info associated with this object. * Destroy the data and remove it from the global list. */ objsWithArchInfo = ItkGetObjsWithArchInfo(interp); entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj); if (entry) { Itk_DelArchInfo( Tcl_GetHashValue(entry) ); Tcl_DeleteHashEntry(entry); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_ArchComponentCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Handles the following options: * * itk_component add ?-protected? ?-private? ?--? \ * ?? * * itk_component delete ?...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchComponentCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { char *cmd, *token, c; int length; /* * Check arguments and handle the various options... */ if (objc < 2) { cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "wrong # args: should be one of...\n", " ", cmd, " add ?-protected? ?-private? ?--? name createCmds ?optionCmds?\n", " ", cmd, " delete name ?name name...?", (char*)NULL); return TCL_ERROR; } token = Tcl_GetStringFromObj(objv[1], (int*)NULL); c = *token; length = strlen(token); /* * Handle: itk_component add... */ if (c == 'a' && strncmp(token, "add", length) == 0) { if (objc < 4) { Tcl_WrongNumArgs(interp, 1, objv, "add ?-protected? ?-private? ?--? name createCmds ?optionCmds?"); return TCL_ERROR; } return Itk_ArchCompAddCmd(dummy, interp, objc-1, objv+1); } /* * Handle: itk_component delete... */ else if (c == 'd' && strncmp(token, "delete", length) == 0) { if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "delete name ?name name...?"); return TCL_ERROR; } return Itk_ArchCompDeleteCmd(dummy, interp, objc-1, objv+1); } /* * Flag any errors. */ cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); Tcl_AppendResult(interp, "bad option \"", token, "\": should be one of...\n", " ", cmd, " add name createCmds ?optionCmds?\n", " ", cmd, " delete name ?name name...?", (char*)NULL); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itk_ArchCompAddCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Adds a new component widget into the mega-widget, * integrating its configuration options into the master list. * * itk_component add ?-protected? ?-private? ?--? \ * * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchCompAddCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { Tcl_HashEntry *entry = NULL; char *path = NULL; ArchComponent *archComp = NULL; ArchMergeInfo *mergeInfo = NULL; Tcl_Obj *objNamePtr = NULL; Tcl_Obj *tmpNamePtr = NULL; Tcl_Obj *winNamePtr = NULL; Tcl_Obj *hullNamePtr = NULL; int pLevel = ITCL_PUBLIC; int newEntry, result; CONST char *cmd, *token, *resultStr; char *name; Tcl_Namespace *parserNs; ItclClass *contextClass, *ownerClass; ItclObject *contextObj; ArchInfo *info; Itcl_CallFrame frame, *uplevelFramePtr, *oldFramePtr; Tcl_Command accessCmd; Tcl_Obj *objPtr; Tcl_DString buffer; /* * Get the Archetype info associated with this widget. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access components without an object context", (char*)NULL); return TCL_ERROR; } if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) { return TCL_ERROR; } /* * Look for options like "-protected" or "-private". */ cmd = Tcl_GetStringFromObj(objv[0], (int*)NULL); while (objc > 1) { token = Tcl_GetStringFromObj(objv[1], (int*)NULL); if (*token != '-') { break; } else if (strcmp(token,"-protected") == 0) { pLevel = ITCL_PROTECTED; } else if (strcmp(token,"-private") == 0) { pLevel = ITCL_PRIVATE; } else if (strcmp(token,"--") == 0) { objc--; objv++; break; } else { Tcl_AppendResult(interp, "bad option \"", token, "\": should be -private, -protected or --", (char*)NULL); return TCL_ERROR; } objc--; objv++; } if (objc < 3 || objc > 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", cmd, " ?-protected? ?-private? ?--? name createCmds ?optionCmds?", (char*)NULL); return TCL_ERROR; } /* * See if a component already exists with the symbolic name. */ name = Tcl_GetStringFromObj(objv[1], (int*)NULL); entry = Tcl_CreateHashEntry(&info->components, name, &newEntry); if (!newEntry) { Tcl_AppendResult(interp, "component \"", name, "\" already defined", (char*)NULL); return TCL_ERROR; } /* * If this component is the "hull" for the mega-widget, then * move the object access command out of the way before * creating the component, so it is not accidentally deleted. */ Tcl_DStringInit(&buffer); objNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objNamePtr); Tcl_IncrRefCount(objNamePtr); if (strcmp(name, "hull") == 0) { tmpNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, tmpNamePtr); Tcl_AppendToObj(tmpNamePtr, "-widget-", -1); Tcl_IncrRefCount(tmpNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(objNamePtr, (int*)NULL), Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } } /* * Execute the to create the component widget. * Do this one level up, in the scope of the calling routine. */ uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); oldFramePtr = _Tcl_ActivateCallFrame(interp, uplevelFramePtr); if (Tcl_EvalObj(interp, objv[2]) != TCL_OK) { goto compFail; } /* * Take the result from the widget creation commands as the * path name for the new component. Make a local copy of * this, since the interpreter will get used in the mean time. */ resultStr = Tcl_GetStringResult(interp); path = (char*)ckalloc((unsigned)(strlen(resultStr)+1)); strcpy(path, resultStr); /* * Look for the access command token in the context of the * calling namespace. By-pass any protection at this point. */ accessCmd = Tcl_FindCommand(interp, path, (Tcl_Namespace*)NULL, /* flags */ 0); if (!accessCmd) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot find component access command \"", path, "\" for component \"", name, "\"", (char*)NULL); goto compFail; } winNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, accessCmd, winNamePtr); Tcl_IncrRefCount(winNamePtr); (void) _Tcl_ActivateCallFrame(interp, oldFramePtr); /* * Create the component record. Set the protection level * according to the "-protected" or "-private" option. */ ownerClass = contextClass; uplevelFramePtr = _Tcl_GetCallFrame(interp, 1); if (uplevelFramePtr && Itcl_IsClassNamespace(uplevelFramePtr->nsPtr)) { ownerClass = (ItclClass*)uplevelFramePtr->nsPtr->clientData; } archComp = Itk_CreateArchComponent(interp, info, name, ownerClass, accessCmd); if (!archComp) { goto compFail; } Tcl_SetHashValue(entry, (ClientData)archComp); archComp->member->protection = pLevel; /* * If this component is the "hull" for the mega-widget, then * move the hull widget access command to a different name, * and move the object access command back into place. This * way, when the widget name is used as a command, the object * access command will handle all requests. */ if (strcmp(name, "hull") == 0) { hullNamePtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_GetCommandFullName(interp, accessCmd, hullNamePtr); Tcl_AppendToObj(hullNamePtr, "-itk_hull", -1); Tcl_IncrRefCount(hullNamePtr); result = TclRenameCommand(interp, Tcl_GetStringFromObj(winNamePtr, (int*)NULL), Tcl_GetStringFromObj(hullNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } Tcl_DecrRefCount(winNamePtr); /* winNamePtr keeps current name */ winNamePtr = hullNamePtr; hullNamePtr = NULL; result = TclRenameCommand(interp, Tcl_GetStringFromObj(tmpNamePtr, (int*)NULL), Tcl_GetStringFromObj(objNamePtr, (int*)NULL)); if (result != TCL_OK) { goto compFail; } } /* * Add a binding onto the new component, so that when its * window is destroyed, it will automatically remove itself * from its parent's component list. Avoid doing these things * for the "hull" component, since it is a special case and * these things are not really necessary. */ else { Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, "bindtags ", -1); Tcl_DStringAppend(&buffer, path, -1); if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) { goto compFail; } Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, "bind itk-destroy-", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " [itcl::code ", -1); Tcl_DStringAppend(&buffer, Tcl_GetStringFromObj(objNamePtr,(int*)NULL), -1); Tcl_DStringAppend(&buffer, " itk_component delete ", -1); Tcl_DStringAppend(&buffer, name, -1); Tcl_DStringAppend(&buffer, "]\n", -1); Tcl_DStringAppend(&buffer, "bindtags ", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " {itk-destroy-", -1); Tcl_DStringAppend(&buffer, path, -1); Tcl_DStringAppend(&buffer, " ", -1); Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1); Tcl_DStringAppend(&buffer, "}", -1); if (Tcl_Eval(interp, Tcl_DStringValue(&buffer)) != TCL_OK) { goto compFail; } } /* * Query the list of configuration options for this widget, * so we will know which ones are valid. Build an option * table to represent these, so they can be found quickly * by the option parsing commands in "itk::option-parser". */ Tcl_DStringTrunc(&buffer, 0); Tcl_DStringAppendElement(&buffer, Tcl_GetStringFromObj(winNamePtr, (int*)NULL)); Tcl_DStringAppendElement(&buffer, "configure"); result = Tcl_Eval(interp, Tcl_DStringValue(&buffer)); if (result != TCL_OK) { goto compFail; } Tcl_DStringSetLength(&buffer, 0); Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1); /* * Find the "itk::option-parser" namespace and get the data * record shared by all of the parsing commands. */ parserNs = Tcl_FindNamespace(interp, "::itk::option-parser", (Tcl_Namespace*)NULL, TCL_LEAVE_ERR_MSG); if (!parserNs) { goto compFail; } mergeInfo = (ArchMergeInfo*)parserNs->clientData; assert(mergeInfo); /* * Initialize the data record used by the option parsing commands. * Store a table of valid configuration options, along with the * info for the mega-widget that is being updated. */ mergeInfo->optionTable = Itk_CreateGenericOptTable(interp, Tcl_DStringValue(&buffer)); if (!mergeInfo->optionTable) { goto compFail; } mergeInfo->archInfo = info; mergeInfo->archComp = archComp; /* * Execute the option-handling commands in the "itk::option-parser" * namespace. If there are no option-handling commands, invoke * the "usual" command instead. */ if (objc != 4) { objPtr = Tcl_NewStringObj("usual", -1); Tcl_IncrRefCount(objPtr); } else { objPtr = objv[3]; } result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, parserNs, /* isProcCallFrame */ 0); if (result == TCL_OK) { result = Tcl_EvalObj(interp, objPtr); Tcl_PopCallFrame(interp); } if (objc != 4) { Tcl_DecrRefCount(objPtr); } if (result != TCL_OK) { goto compFail; } Itk_DelGenericOptTable(mergeInfo->optionTable); mergeInfo->optionTable = NULL; mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; ckfree(path); Tcl_DStringFree(&buffer); if (objNamePtr) { Tcl_DecrRefCount(objNamePtr); } if (tmpNamePtr) { Tcl_DecrRefCount(tmpNamePtr); } if (winNamePtr) { Tcl_DecrRefCount(winNamePtr); } if (hullNamePtr) { Tcl_DecrRefCount(hullNamePtr); } Tcl_SetResult(interp, name, TCL_VOLATILE); return TCL_OK; /* * If any errors were encountered, clean up and return. */ compFail: if (archComp) { Itk_DelArchComponent(archComp); } if (entry) { Tcl_DeleteHashEntry(entry); } if (path) { ckfree(path); } if (mergeInfo && mergeInfo->optionTable) { Itk_DelGenericOptTable(mergeInfo->optionTable); mergeInfo->optionTable = NULL; mergeInfo->archInfo = NULL; mergeInfo->archComp = NULL; } Tcl_DStringFree(&buffer); if (objNamePtr) { Tcl_DecrRefCount(objNamePtr); } if (tmpNamePtr) { Tcl_DecrRefCount(tmpNamePtr); } if (winNamePtr) { Tcl_DecrRefCount(winNamePtr); } if (hullNamePtr) { Tcl_DecrRefCount(hullNamePtr); } /* * Add error info and return. */ objPtr = Tcl_NewStringObj((char*)NULL, 0); Tcl_AppendToObj(objPtr, "\n (while creating component \"", -1); Tcl_AppendToObj(objPtr, name, -1); Tcl_AppendToObj(objPtr, "\" for widget \"", -1); Tcl_GetCommandFullName(contextObj->classDefn->interp, contextObj->accessCmd, objPtr); Tcl_AppendToObj(objPtr, "\")", -1); Tcl_IncrRefCount(objPtr); Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL)); Tcl_DecrRefCount(objPtr); return TCL_ERROR; } /* * ------------------------------------------------------------------------ * Itk_ArchCompDeleteCmd() * * Invoked by [incr Tcl] to handle the itk::Archetype::itk_component * method. Removes an existing component widget from a mega-widget, * and removes any configuration options associated with it. * * itk_component delete ? ...? * * Returns TCL_OK/TCL_ERROR to indicate success/failure. * ------------------------------------------------------------------------ */ /* ARGSUSED */ static int Itk_ArchCompDeleteCmd(dummy, interp, objc, objv) ClientData dummy; /* unused */ Tcl_Interp *interp; /* current interpreter */ int objc; /* number of arguments */ Tcl_Obj *CONST objv[]; /* argument objects */ { int i; char *token; ItclClass *contextClass; ItclObject *contextObj; ArchInfo *info; Tcl_HashEntry *entry; Tcl_HashSearch place; Itcl_ListElem *elem; ArchComponent *archComp; ArchOption *archOpt; ArchOptionPart *optPart; Itcl_List delOptList; Tcl_DString buffer; /* * Get the Archetype info associated with this widget. */ if (Itcl_GetContext(interp, &contextClass, &contextObj) != TCL_OK || !contextObj) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "cannot access components without an object context", (char*)NULL); return TCL_ERROR; } if (Itk_GetArchInfo(interp, contextObj, &info) != TCL_OK) { return TCL_ERROR; } /* * Scan through the list of component names and delete each * one. Make sure that each component exists. */ for (i=1; i < objc; i++) { token = Tcl_GetStringFromObj(objv[i], (int*)NULL); entry = Tcl_FindHashEntry(&info->components, token); if (!entry) { Tcl_AppendResult(interp, "name \"", token, "\" is not a component", (char*)NULL); return TCL_ERROR; } archComp = (ArchComponent*)Tcl_GetHashValue(entry); /* * Clean up the binding tag that causes the widget to * call this method automatically when destroyed. * Ignore errors if anything goes wrong. */ Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, "itk::remove_destroy_hook ", -1); Tcl_DStringAppend(&buffer, archComp->pathName, -1); (void) Tcl_Eval(interp, Tcl_DStringValue(&buffer)); Tcl_ResetResult(interp); Tcl_DStringFree(&buffer); Tcl_UnsetVar2(interp, "itk_component", token, 0); Tcl_DeleteHashEntry(entry); /* * Clean up the options that belong to the component. Do this * by scanning through all available options and looking for * those that belong to the component. If we remove them as * we go, we'll mess up Tcl_NextHashEntry. So instead, we * build up a list of options to remove, and then remove the * options below. */ Itcl_InitList(&delOptList); entry = Tcl_FirstHashEntry(&info->options, &place); while (entry) { archOpt = (ArchOption*)Tcl_GetHashValue(entry); elem = Itcl_FirstListElem(&archOpt->parts); while (elem) { optPart = (ArchOptionPart*)Itcl_GetListValue(elem); if (optPart->from == (ClientData)archComp) { Itcl_AppendList(&delOptList, (ClientData)entry); } elem = Itcl_NextListElem(elem); } entry = Tcl_NextHashEntry(&place); } /* * Now that we've figured out which options to delete, * go through the list and remove them. */ elem = Itcl_FirstListElem(&delOptList); while (elem) { entry = (Tcl_HashEntry*)Itcl_GetListValue(elem); token = Tcl_GetHashKey(&info->options, entry); Itk_RemoveArchOptionPart(info, token, (ClientData)archComp); elem = Itcl_NextListElem(elem); } Itcl_DeleteList(&delOptList); Itk_DelArchComponent(archComp); } return TCL_OK; } /* * ------------------------------------------------------------------------ * Itk_ArchOptKeepCmd() * * Invoked by [incr Tcl] to handle the "keep" command in the itk * option parser. Integrates a list of component configuration options * into a mega-widget, so that whenever the mega-widget is updated, * the component will be updated as well. * * Handles the following syntax: * * keep